CAD的VBA如何读取EXCEL中的数据？？
<p>如题：</p><p>CAD的VBA如何读取EXCEL单元格中的数据？？比如说读取EXCEL中的数据直接做多段线、曲线等？</p><p>知道的朋友说说。</p><p>刚学习VBA不太熟悉，看到的例子都是用pionts(0 to 5)等二维做。想不明白怎么提取excel中（data1,data2)这种坐标式的数据？？？</p><p></p> <p>Set xl = CreateObject("excel.application")</p><p>创建EXCEL</p><p>xl.sheets(1).cell(i,II).value</p><p>引用单元格</p> 谢谢 <p>Attribute VB_Name = "Module1"<br/>Dim Excel As Excel.Application<br/>Dim ExcelSheet As Object<br/>Dim ExcelWorkbook As Object</p><p></p><p><br/>Public Function merge(str1 As String, str2 As String)</p><p> Excel.Range(str1 & ":" & str2).Select<br/> <br/> Excel.Selection.merge<br/> Excel.Selection.VerticalAlignment = xlVAlignCenter<br/> Excel.Selection.HorizontalAlignment = xlCenter<br/> Excel.Selection.Orientation = xlVertical</p><p>End Function</p><p><br/>Public Function quit()<br/> Dim ret As Integer<br/> ret = MsgBox("是否关闭并保存Excel？", vbYesNo)<br/> If (ret = vbYes) Then<br/> Dim strname As String<br/> strname = InputBox("please input excel file name")<br/> ExcelWorkbook.SaveAs strname<br/> Excel.Application.quit<br/> Set Excel = Nothing<br/> <br/> End If</p><p>End Function</p><p><br/>Public Function border(str1 As String, str2 As String)</p><p> Excel.Range(str1 & ":" & str2).Select<br/> <br/> <br/> Excel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone<br/> Excel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone<br/> With Excel.Selection.Borders(xlEdgeLeft)<br/> .LineStyle = xlContinuous<br/> .Weight = xlThin<br/> .ColorIndex = xlAutomatic<br/> End With<br/> With Excel.Selection.Borders(xlEdgeTop)<br/> .LineStyle = xlContinuous<br/> .Weight = xlThin<br/> .ColorIndex = xlAutomatic<br/> End With<br/> With Excel.Selection.Borders(xlEdgeBottom)<br/> .LineStyle = xlContinuous<br/> .Weight = xlThin<br/> .ColorIndex = xlAutomatic<br/> End With<br/> With Excel.Selection.Borders(xlEdgeRight)<br/> .LineStyle = xlContinuous<br/> .Weight = xlThin<br/> .ColorIndex = xlAutomatic<br/> End With<br/> With Excel.Selection.Borders(xlInsideVertical)<br/> .LineStyle = xlContinuous<br/> .Weight = xlThin<br/> .ColorIndex = xlAutomatic<br/> End With<br/> With Excel.Selection.Borders(xlInsideHorizontal)<br/> .LineStyle = xlContinuous<br/> .Weight = xlThin<br/> .ColorIndex = xlAutomatic<br/> End With<br/> </p><p>End Function</p><p>Public Function Border_bold(str1 As String, str2 As String)<br/> Excel.Range(str1 & ":" & str2).Select<br/> Excel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone<br/> Excel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone<br/> With Excel.Selection.Borders(xlEdgeLeft)<br/> .LineStyle = xlContinuous<br/> .Weight = xlMedium<br/> .ColorIndex = xlAutomatic<br/> End With<br/> With Excel.Selection.Borders(xlEdgeTop)<br/> .LineStyle = xlContinuous<br/> .Weight = xlMedium<br/> .ColorIndex = xlAutomatic<br/> End With<br/> With Excel.Selection.Borders(xlEdgeBottom)<br/> .LineStyle = xlContinuous<br/> .Weight = xlMedium<br/> .ColorIndex = xlAutomatic<br/> End With<br/> With Excel.Selection.Borders(xlEdgeRight)<br/> .LineStyle = xlContinuous<br/> .Weight = xlMedium<br/> .ColorIndex = xlAutomatic<br/> End With<br/> Excel.Selection.Borders(xlInsideVertical).LineStyle = xlNone<br/> Excel.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone</p><p>End Function</p><p>Public Function writeExcel()<br/> Dim returnObj As ComSheet<br/> Dim sheet As Integer<br/> <br/> Dim basePnt As Variant<br/> Dim rangeRow As Integer<br/> Dim rangeColumn As Integer<br/> Dim rangeRowMax As Integer<br/> Dim rangeColumnMax As Integer<br/> Dim cell1 As Object<br/> Dim cell2 As Object<br/> <br/> On Error Resume Next<br/> <br/> Set Excel = CreateObject("Excel.Application")<br/> <br/> <br/> <br/> Set ExcelWorkbook = Excel.Workbooks.Add<br/> Set ExcelSheet = Excel.ActiveSheet<br/> Excel.Visible = True<br/> <br/> <br/> On Error Resume Next<br/> <br/> ' The following example waits for a selection from the user<br/> <br/> ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select an object"</p><p> Dim name<br/> name = returnObj.ObjectName<br/> Dim str As String<br/> str = returnObj.TextString<br/> <br/> If Not (name = "TDbSheet") Then<br/> Exit Function<br/> End If<br/> <br/> nRowNum = returnObj.RowNum<br/> nColumnNum = returnObj.ColumnNum<br/> <br/> For j = 0 To nColumnNum - 1 Step 1<br/> For i = 0 To nRowNum - 1 Step 1<br/> If (returnObj.IsRange(i, j)) Then<br/> rangeRow = returnObj.rangeRow(i, j)<br/> rangeColumn = returnObj.rangeColumn(i, j)<br/> rangeRowMax = returnObj.rangeRowMax(i, j)<br/> rangeColumnMax = returnObj.rangeColumnMax(i, j)<br/> Set cell1 = ExcelSheet.Cells(rangeRow + 1, rangeColumn + 1)<br/> Set cell2 = ExcelSheet.Cells(rangeRowMax + 1, rangeColumnMax + 1)<br/> Excel.Range(cell1, cell2).Select<br/> <br/> Excel.Selection.merge<br/> Excel.Selection.VerticalAlignment = xlVAlignCenter<br/> Excel.Selection.HorizontalAlignment = xlCenter<br/> 'Excel.Selection.Orientation = xlVertical<br/> <br/> <br/> End If<br/> ExcelSheet.Cells(i + 1, j + 1).Value = returnObj.Text(i, j)<br/> Next i<br/> Next j<br/> </p><p> <br/> </p><p> returnObj.Color = acRed<br/> </p><p> <br/>End Function</p><p><br/> <br/>Public Sub readExcel()<br/> Dim Excel_cad As Excel.Application<br/> Dim ExcelSheet_cad As Object</p><p> On Error Resume Next<br/> <br/> Set Excel_cad = GetObject(, "Excel.Application")<br/> If Err <> 0 Then<br/> MsgBox ("请先打开一EXCEL文件，并框选中要复制的单元格。")<br/> Set Excel_cad = Nothing<br/> Exit Sub<br/> End If<br/> Dim sheet As ComSheet<br/> Set ExcelSheet_cad = Excel_cad.ActiveSheet<br/> <br/> Dim rowStart As Integer<br/> Dim columnStart As Integer<br/> rowStart = Excel_cad.Selection.row '起点<br/> columnStart = Excel_cad.Selection.column '起点<br/> <br/> <br/> Set sheet = New ComSheet<br/> Dim row As Integer<br/> Dim col As Integer<br/> sheetrow = Excel_cad.Selection.Rows.Count<br/> sheetcol = Excel_cad.Selection.Columns.Count<br/> If (sheetrow < 1 Or sheetcol < 1) Then<br/> Set ExcelSheet_cad = Nothing<br/> Set Excel_cad = Nothing<br/> Exit Sub<br/> End If<br/> <br/> Dim ret As Integer<br/> ret = MsgBox("是否在图中新建一表格？Y-新建，N-更新(注意行列匹配)。", vbYesNo)<br/> If (ret = vbNo) Then<br/> ThisDrawing.Utility.GetEntity sheet, basePnt, "Select an object"<br/> Dim name<br/> name = sheet.ObjectName<br/> <br/> nRowNum = returnObj.RowNum<br/> nColumnNum = returnObj.ColumnNum</p><p> <br/> If Not (name = "TDbSheet") Then<br/> MsgBox ("选择失败！ 请正确选择天正表格。")<br/> Set ExcelSheet_cad = Nothing<br/> Set Excel_cad = Nothing<br/> Exit Sub<br/> End If<br/> If (sheetrow <> sheet.RowNum) Or (sheetcol <> sheet.ColumnNum) Then<br/> MsgBox ("表格行数或列数不匹配！ 请正确选择天正表格。")<br/> Set ExcelSheet_cad = Nothing<br/> Set Excel_cad = Nothing<br/> Exit Sub<br/> End If<br/> <br/> '先把合并单元格恢复<br/> For j = 0 To sheetrow - 1 Step 1<br/> For i = 0 To sheetcol - 1 Step 1<br/> Dim IsMerged As Boolean<br/> IsMerged = sheet.IsRange(j, i)<br/> If (IsMerged = True) Then<br/> sheet.ExplodeCell j, i<br/> End If<br/> Next i<br/> Next j<br/> <br/> Else<br/> sheet.Create sheetrow, sheetcol<br/> End If<br/> <br/> <br/> <br/> <br/> For j = 0 To sheetrow - 1 Step 1<br/> For i = 0 To sheetcol - 1 Step 1<br/> Dim str As String</p><p> Dim r As Range<br/> Dim IsMerge As Boolean<br/> flag = ExcelSheet_cad.Cells(rowStart + j, columnStart + i).MergeCells<br/> IsMerge = sheet.IsRange(j, i)</p><p> If (flag = True And IsMerge = False) Then<br/> Set r = ExcelSheet_cad.Cells(rowStart + j, columnStart + i).MergeArea<br/> MergeStartR = r.row - rowStart '相对于TDbSheet<br/> MergeStartC = r.column - columnStart<br/> MergeCNum = r.Columns.Count<br/> MergeRNum = r.Rows.Count<br/> sheet.merge MergeStartR, MergeStartC, MergeRNum, MergeCNum<br/> End If<br/> If (IsMerge = False) Then<br/> str = ExcelSheet_cad.Cells(rowStart + j, columnStart + i).Text ' sr modify by .Value 2004/6/14<br/> sheet.SetCellText j, i, str<br/> End If<br/> Next i<br/> Next j<br/> ThisDrawing.Regen (acAllViewports)<br/> <br/> 'Excel.Application.quit<br/> Set ExcelSheet_cad = Nothing<br/> Set Excel_cad = Nothing<br/> <br/> <br/>End Sub<br/> <br/>Public Sub sheet2Excel()<br/> Dim OpenFlag As Boolean<br/> OpenFlag = True<br/> <br/> Dim Excel_cad As Excel.Application<br/> Dim ExcelSheet_cad As Object<br/> Dim ExcelWorkbook_cad As Object</p><p> Dim returnObj As ComSheet<br/> Dim sheet As Integer<br/> <br/> Dim basePnt As Variant<br/> Dim rangeRow As Integer<br/> Dim rangeColumn As Integer<br/> Dim rangeRowMax As Integer<br/> Dim rangeColumnMax As Integer<br/> Dim cell1 As Object<br/> Dim cell2 As Object<br/> <br/> On Error Resume Next<br/> <br/> Dim rowStart As Integer<br/> Dim columnStart As Integer<br/> rowStart = 1 '起点<br/> columnStart = 0 '起点</p><p> <br/> ' The following example waits for a selection from the user<br/> <br/> ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select an object"</p><p> Dim name<br/> name = returnObj.ObjectName</p><p> If Not (name = "TDbSheet") Then<br/> Exit Sub<br/> End If<br/> <br/> nRowNum = returnObj.RowNum 'ComSheet行数<br/> nColumnNum = returnObj.ColumnNum 'ComSheet列数<br/> <br/>' Dim ret As Integer<br/>' ret = MsgBox("是否在图中新建一Excel表单？Y-新建，N-更新已有表单的选中区域(注意行列匹配)。", vbYesNo)<br/>' If (ret = vbNo) Then<br/>' On Error Resume Next<br/>' Set Excel_cad = GetObject(, "Excel.Application")<br/>' If Err <> 0 Then<br/>' MsgBox ("请先打开一EXCEL文件，并框选中要复制的单元格。")<br/>' Set Excel_cad = Nothing<br/>' Exit Sub<br/>' End If<br/>'<br/>' OpenFlag = False<br/>' rowStart = Excel_cad.Selection.row '起点<br/>' columnStart = Excel_cad.Selection.column '起点<br/>' sheetrow = Excel_cad.Selection.Rows.Count<br/>' sheetcol = Excel_cad.Selection.Columns.Count<br/>' If (sheetrow <> nRowNum) Or (sheetcol <> nColumnNum) Then<br/>' MsgBox ("所选EXCEL表格与天正表格行数或列数不匹配！")<br/>' Set Excel_cad = Nothing<br/>' End If<br/>' Else<br/> OpenFlag = True<br/> Set Excel_cad = CreateObject("Excel.Application")<br/> Set ExcelWorkbook_cad = Excel_cad.Workbooks.Add<br/> 'End If<br/> Set ExcelSheet_cad = Excel_cad.ActiveSheet<br/> <br/> '标题<br/> Set cell1 = ExcelSheet_cad.Cells(rowStart, columnStart + 1)<br/> Set cell2 = ExcelSheet_cad.Cells(rowStart, columnStart + nColumnNum)<br/> <br/> Excel_cad.Range(cell1, cell2).Select<br/> Excel_cad.Selection.merge<br/> Excel_cad.Selection.VerticalAlignment = xlVAlignCenter<br/> Excel_cad.Selection.HorizontalAlignment = xlCenter<br/> Excel_cad.Cells(rowStart, columnStart + 1).Value = returnObj.Title<br/> <br/> <br/> For j = 0 To nColumnNum - 1 Step 1<br/> For i = 0 To nRowNum - 1 Step 1<br/> If (OpenFlag = True) Then<br/> If (returnObj.IsRange(i, j)) Then<br/> rangeRow = returnObj.rangeRow(i, j)<br/> rangeColumn = returnObj.rangeColumn(i, j)<br/> If (i = rangeRow And j = rangeColumn) Then<br/> rangeRowMax = returnObj.rangeRowMax(i, j)<br/> rangeColumnMax = returnObj.rangeColumnMax(i, j)<br/> Set cell1 = ExcelSheet_cad.Cells(rangeRow + rowStart + 1, rangeColumn + columnStart + 1)<br/> Set cell2 = ExcelSheet_cad.Cells(rangeRowMax + rowStart + 1, rangeColumnMax + columnStart + 1)<br/> If returnObj.TextColor(i, j) > 0 Then<br/> Excel_cad.Range(cell1, cell2).Interior.Color = returnObj.TextColor(i, j)<br/> Excel_cad.Range(cell1, cell2).Interior.Pattern = xlSolid<br/> End If<br/> Excel_cad.Range(cell1, cell2).Select<br/> Excel_cad.Selection.merge<br/> Excel_cad.Selection.VerticalAlignment = xlVAlignCenter<br/> Excel_cad.Selection.HorizontalAlignment = xlCenter<br/> End If<br/> Else<br/> If returnObj.TextColor(i, j) > 0 Then<br/> ExcelSheet_cad.Cells(i + rowStart + 1, j + columnStart + 1).Interior.Color = returnObj.TextColor(i, j)<br/> ExcelSheet_cad.Cells(i + rowStart + 1, j + columnStart + 1).Interior.Pattern = xlSolid<br/> End If<br/> End If<br/> ExcelSheet_cad.Cells(i + rowStart + 1, j + columnStart + 1).Value = returnObj.Text(i, j)<br/> Else<br/> ExcelSheet_cad.Cells(i + rowStart, j + columnStart).Value = returnObj.Text(i, j)<br/> End If<br/> Next i<br/> Next j<br/> <br/> Excel_cad.Visible = True<br/> Set ExcelWorkbook_cad = Nothing<br/> Set ExcelSheet_cad = Nothing<br/> Set Excel_cad = Nothing</p><p>End Sub</p><p><br/></p> 最好先判断EXCEL是否已经运行。<br/> If DetectExcel() = False Then<br/> 'MsgBox "EXCEL没有运行!"<br/>Set e1 = CreateObject("Excel.application")<br/>e1.Visible = True<br/>e1.Workbooks.add<br/>Set ew = e1.ActiveWorkbook.Sheets("sheet1")<br/><br/>Else<br/>Set e1 = GetObject(, "Excel.application")<br/>e1.Workbooks.add<br/>Set ew = e1.ActiveWorkbook.ActiveSheet<br/>End If
页:
[1]