CAD的VBA如何读取EXCEL中的数据？？

sa3226390

如题：

CAD的VBA如何读取EXCEL单元格中的数据？？比如说读取EXCEL中的数据直接做多段线、曲线等？

知道的朋友说说。

刚学习VBA不太熟悉，看到的例子都是用pionts(0 to 5)等二维做。想不明白怎么提取excel中（data1,data2)这种坐标式的数据？？？

fjfhgdwfn

Set xl = CreateObject("excel.application")

创建EXCEL

xl.sheets(1).cell(i,II).value

引用单元格

sa3226390

谢谢

yxp

Attribute VB_Name = "Module1"
Dim Excel As Excel.Application
Dim ExcelSheet As Object
Dim ExcelWorkbook As Object

Public Function merge(str1 As String, str2 As String)

    Excel.Range(str1 & ":" & str2).Select
    
    Excel.Selection.merge
    Excel.Selection.VerticalAlignment = xlVAlignCenter
    Excel.Selection.HorizontalAlignment = xlCenter
    Excel.Selection.Orientation = xlVertical

End Function

Public Function quit()
    Dim ret As Integer
    ret = MsgBox("是否关闭并保存Excel？", vbYesNo)
    If (ret = vbYes) Then
        Dim strname As String
        strname = InputBox("please input excel file name")
        ExcelWorkbook.SaveAs strname
        Excel.Application.quit
        Set Excel = Nothing
   
    End If

End Function

Public Function border(str1 As String, str2 As String)

    Excel.Range(str1 & ":" & str2).Select
   
 
    Excel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Excel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Excel.Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Excel.Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Excel.Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Excel.Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Excel.Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Excel.Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
 

End Function

Public Function Border_bold(str1 As String, str2 As String)
    Excel.Range(str1 & ":" & str2).Select
    Excel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Excel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Excel.Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Excel.Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Excel.Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Excel.Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Excel.Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Excel.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Function

Public Function writeExcel()
    Dim returnObj As ComSheet
    Dim sheet As Integer
   
    Dim basePnt As Variant
    Dim rangeRow As Integer
    Dim rangeColumn As Integer
    Dim rangeRowMax As Integer
    Dim rangeColumnMax As Integer
    Dim cell1 As Object
    Dim cell2 As Object
   
    On Error Resume Next
 
    Set Excel = CreateObject("Excel.Application")
  
   
       
    Set ExcelWorkbook = Excel.Workbooks.Add
    Set ExcelSheet = Excel.ActiveSheet
    Excel.Visible = True
 
   
    On Error Resume Next
   
    ' The following example waits for a selection from the user
 
    ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select an object"

    Dim name
    name = returnObj.ObjectName
    Dim str As String
    str = returnObj.TextString
   
    If Not (name = "TDbSheet") Then
        Exit Function
    End If
   
    nRowNum = returnObj.RowNum
    nColumnNum = returnObj.ColumnNum
   
    For j = 0 To nColumnNum - 1 Step 1
        For i = 0 To nRowNum - 1 Step 1
            If (returnObj.IsRange(i, j)) Then
                rangeRow = returnObj.rangeRow(i, j)
                rangeColumn = returnObj.rangeColumn(i, j)
                rangeRowMax = returnObj.rangeRowMax(i, j)
                rangeColumnMax = returnObj.rangeColumnMax(i, j)
                Set cell1 = ExcelSheet.Cells(rangeRow + 1, rangeColumn + 1)
                Set cell2 = ExcelSheet.Cells(rangeRowMax + 1, rangeColumnMax + 1)
                Excel.Range(cell1, cell2).Select
    
                Excel.Selection.merge
                Excel.Selection.VerticalAlignment = xlVAlignCenter
                Excel.Selection.HorizontalAlignment = xlCenter
                'Excel.Selection.Orientation = xlVertical
   
               
            End If
            ExcelSheet.Cells(i + 1, j + 1).Value = returnObj.Text(i, j)
        Next i
    Next j
   

   
   

    returnObj.Color = acRed
   

   
End Function

 
Public Sub readExcel()
    Dim Excel_cad As Excel.Application
    Dim ExcelSheet_cad As Object

    On Error Resume Next
   
    Set Excel_cad = GetObject(, "Excel.Application")
    If Err <> 0 Then
        MsgBox ("请先打开一EXCEL文件，并框选中要复制的单元格。")
        Set Excel_cad = Nothing
        Exit Sub
    End If
    Dim sheet As ComSheet
    Set ExcelSheet_cad = Excel_cad.ActiveSheet
    
    Dim rowStart As Integer
    Dim columnStart As Integer
    rowStart = Excel_cad.Selection.row             '起点
    columnStart = Excel_cad.Selection.column       '起点
   
 
    Set sheet = New ComSheet
    Dim row As Integer
    Dim col As Integer
    sheetrow = Excel_cad.Selection.Rows.Count
    sheetcol = Excel_cad.Selection.Columns.Count
    If (sheetrow < 1 Or sheetcol < 1) Then
        Set ExcelSheet_cad = Nothing
        Set Excel_cad = Nothing
        Exit Sub
    End If
   
    Dim ret As Integer
    ret = MsgBox("是否在图中新建一表格？Y-新建，N-更新(注意行列匹配)。", vbYesNo)
    If (ret = vbNo) Then
        ThisDrawing.Utility.GetEntity sheet, basePnt, "Select an object"
        Dim name
        name = sheet.ObjectName
        
        nRowNum = returnObj.RowNum
        nColumnNum = returnObj.ColumnNum

   
        If Not (name = "TDbSheet") Then
            MsgBox ("选择失败！ 请正确选择天正表格。")
            Set ExcelSheet_cad = Nothing
            Set Excel_cad = Nothing
            Exit Sub
        End If
        If (sheetrow <> sheet.RowNum) Or (sheetcol <> sheet.ColumnNum) Then
            MsgBox ("表格行数或列数不匹配！ 请正确选择天正表格。")
            Set ExcelSheet_cad = Nothing
            Set Excel_cad = Nothing
            Exit Sub
        End If
     
        '先把合并单元格恢复
        For j = 0 To sheetrow - 1 Step 1
            For i = 0 To sheetcol - 1 Step 1
                Dim IsMerged As Boolean
                IsMerged = sheet.IsRange(j, i)
                If (IsMerged = True) Then
                    sheet.ExplodeCell j, i
                End If
             Next i
        Next j
   
    Else
        sheet.Create sheetrow, sheetcol
    End If
   
          
           
   
    For j = 0 To sheetrow - 1 Step 1
        For i = 0 To sheetcol - 1 Step 1
            Dim str As String

            Dim r As Range
            Dim IsMerge As Boolean
            flag = ExcelSheet_cad.Cells(rowStart + j, columnStart + i).MergeCells
            IsMerge = sheet.IsRange(j, i)

            If (flag = True And IsMerge = False) Then
                Set r = ExcelSheet_cad.Cells(rowStart + j, columnStart + i).MergeArea
                MergeStartR = r.row - rowStart        '相对于TDbSheet
                MergeStartC = r.column - columnStart
                MergeCNum = r.Columns.Count
                MergeRNum = r.Rows.Count
                sheet.merge MergeStartR, MergeStartC, MergeRNum, MergeCNum
            End If
            If (IsMerge = False) Then
               str = ExcelSheet_cad.Cells(rowStart + j, columnStart + i).Text ' sr modify by .Value 2004/6/14
               sheet.SetCellText j, i, str
            End If
        Next i
    Next j
    ThisDrawing.Regen (acAllViewports)
   
    'Excel.Application.quit
    Set ExcelSheet_cad = Nothing
    Set Excel_cad = Nothing
   
    
End Sub
 
Public Sub sheet2Excel()
    Dim OpenFlag As Boolean
    OpenFlag = True
   
    Dim Excel_cad As Excel.Application
    Dim ExcelSheet_cad As Object
    Dim ExcelWorkbook_cad As Object

    Dim returnObj As ComSheet
    Dim sheet As Integer
   
    Dim basePnt As Variant
    Dim rangeRow As Integer
    Dim rangeColumn As Integer
    Dim rangeRowMax As Integer
    Dim rangeColumnMax As Integer
    Dim cell1 As Object
    Dim cell2 As Object
   
    On Error Resume Next
 
    Dim rowStart As Integer
    Dim columnStart As Integer
    rowStart = 1            '起点
    columnStart = 0         '起点

    
    ' The following example waits for a selection from the user
 
    ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select an object"

    Dim name
    name = returnObj.ObjectName

    If Not (name = "TDbSheet") Then
        Exit Sub
    End If
   
    nRowNum = returnObj.RowNum                'ComSheet行数
    nColumnNum = returnObj.ColumnNum          'ComSheet列数
   
'    Dim ret As Integer
'    ret = MsgBox("是否在图中新建一Excel表单？Y-新建，N-更新已有表单的选中区域(注意行列匹配)。", vbYesNo)
'    If (ret = vbNo) Then
'        On Error Resume Next
'        Set Excel_cad = GetObject(, "Excel.Application")
'        If Err <> 0 Then
'            MsgBox ("请先打开一EXCEL文件，并框选中要复制的单元格。")
'            Set Excel_cad = Nothing
'            Exit Sub
'        End If
'
'        OpenFlag = False
'        rowStart = Excel_cad.Selection.row             '起点
'        columnStart = Excel_cad.Selection.column       '起点
'        sheetrow = Excel_cad.Selection.Rows.Count
'        sheetcol = Excel_cad.Selection.Columns.Count
'        If (sheetrow <> nRowNum) Or (sheetcol <> nColumnNum) Then
'            MsgBox ("所选EXCEL表格与天正表格行数或列数不匹配！")
'            Set Excel_cad = Nothing
'        End If
'    Else
        OpenFlag = True
        Set Excel_cad = CreateObject("Excel.Application")
        Set ExcelWorkbook_cad = Excel_cad.Workbooks.Add
    'End If
    Set ExcelSheet_cad = Excel_cad.ActiveSheet
   
    '标题
    Set cell1 = ExcelSheet_cad.Cells(rowStart, columnStart + 1)
    Set cell2 = ExcelSheet_cad.Cells(rowStart, columnStart + nColumnNum)
   
    Excel_cad.Range(cell1, cell2).Select
    Excel_cad.Selection.merge
    Excel_cad.Selection.VerticalAlignment = xlVAlignCenter
    Excel_cad.Selection.HorizontalAlignment = xlCenter
    Excel_cad.Cells(rowStart, columnStart + 1).Value = returnObj.Title
       
   
    For j = 0 To nColumnNum - 1 Step 1
        For i = 0 To nRowNum - 1 Step 1
            If (OpenFlag = True) Then
               If (returnObj.IsRange(i, j)) Then
                   rangeRow = returnObj.rangeRow(i, j)
                   rangeColumn = returnObj.rangeColumn(i, j)
                   If (i = rangeRow And j = rangeColumn) Then
                        rangeRowMax = returnObj.rangeRowMax(i, j)
                        rangeColumnMax = returnObj.rangeColumnMax(i, j)
                        Set cell1 = ExcelSheet_cad.Cells(rangeRow + rowStart + 1, rangeColumn + columnStart + 1)
                        Set cell2 = ExcelSheet_cad.Cells(rangeRowMax + rowStart + 1, rangeColumnMax + columnStart + 1)
                        If returnObj.TextColor(i, j) > 0 Then
                             Excel_cad.Range(cell1, cell2).Interior.Color = returnObj.TextColor(i, j)
                             Excel_cad.Range(cell1, cell2).Interior.Pattern = xlSolid
                        End If
                        Excel_cad.Range(cell1, cell2).Select
                        Excel_cad.Selection.merge
                        Excel_cad.Selection.VerticalAlignment = xlVAlignCenter
                        Excel_cad.Selection.HorizontalAlignment = xlCenter
                    End If
               Else
                   If returnObj.TextColor(i, j) > 0 Then
                      ExcelSheet_cad.Cells(i + rowStart + 1, j + columnStart + 1).Interior.Color = returnObj.TextColor(i, j)
                      ExcelSheet_cad.Cells(i + rowStart + 1, j + columnStart + 1).Interior.Pattern = xlSolid
                   End If
               End If
               ExcelSheet_cad.Cells(i + rowStart + 1, j + columnStart + 1).Value = returnObj.Text(i, j)
            Else
                ExcelSheet_cad.Cells(i + rowStart, j + columnStart).Value = returnObj.Text(i, j)
            End If
        Next i
    Next j
   
    Excel_cad.Visible = True
    Set ExcelWorkbook_cad = Nothing
    Set ExcelSheet_cad = Nothing
    Set Excel_cad = Nothing

End Sub

adison

最好先判断EXCEL是否已经运行。
 If DetectExcel() = False Then
  'MsgBox "EXCEL没有运行!"
Set e1 = CreateObject("Excel.application")
e1.Visible = True
e1.Workbooks.add
Set ew = e1.ActiveWorkbook.Sheets("sheet1")

Else
Set e1 = GetObject(, "Excel.application")
e1.Workbooks.add
Set ew = e1.ActiveWorkbook.ActiveSheet
End If