VBA实现Excel与CAD表格互转

▎案例需求

最近换了工作，专职给单位做VBA开发的。很幸运，领导很重视利用VBA来提高效率，实现一些办公流程的自动化。其中有一项内容就是利用Excel数据批量绘制CAD图纸。

关于CAD VBA的东西，会更新几篇，也是作为自己的备忘。本篇文章更新Excel与CAD表格互相导出导入。

▎具体效果（Excel表格导入CAD）

支持合并单元格，如需更细致的需求，需要修改代码相应部分。

▎详细源代码（Excel表格导入CAD）

窗体源代码都在这里，源文件我就不放了。VB画个窗体还是轻轻松松的。

Option ExplicitPrivate Sub cmdCancel_Click() Unload MeEnd SubPrivate Sub cmdOK_Click() On Error Resume Next '获取插入点坐标 Dim ptInsert(2) As Double ptInsert(0) = txtX.Text: ptInsert(1) = txtY.Text: ptInsert(2) = 0 '获取并连接当前但开的excel程序及当前表 Dim excelApp As Object Dim excelSheet As Object Set excelApp = GetObject(, "excel.application") If Err <> 0 Then MsgBox "Excel程序未运行,请打开Excel程序!" Err.Clear Exit Sub End If Set excelSheet = excelApp.activesheet '保存要转化的区域 Dim ranges As Object If optAll.Value = True Then Set ranges = excelSheet.usedrange ElseIf optSelect = True Then Set ranges = excelApp.Selection End If '对每个单元进行操作 Dim excelRg As Object For Each excelRg In ranges addTableAndText ranges, excelRg, ptInsert Next excelRg '释放Excel对象 Set excelSheet = Nothing Set excelApp = NothingEnd Sub'转化表格的函数Public Function addTableAndText(ByVal ranges As Object, ByVal excelRg As Object, ByVal ptInsert As Variant) '声明一个AcadLine对象,以便后续对其处理 Dim objLine As AcadLine '声明四个坐标变量 Dim ptLT(2) As Double Dim ptLB(2) As Double Dim ptRT(2) As Double Dim ptRB(2) As Double '声明一个单元格对象来求顶点坐标 Dim rg11 As Object Set rg11 = excelRg.Offset(1, 1) '获取四个顶点的坐标 ptLT(0) = ptInsert(0) + excelRg.Left * 0.8 - ranges.Left * 0.8 ptLT(1) = ptInsert(1) - (excelRg.top - ranges.top) ptLT(2) = 0 ptRB(0) = ptInsert(0) + rg11.Left * 0.8 - ranges.Left * 0.8 ptRB(1) = ptInsert(1) - (rg11.top - ranges.top) ptRB(2) = 0 ptLB(0) = ptLT(0) ptLB(1) = ptRB(1) ptLB(2) = 0 ptRT(0) = ptRB(0) ptRT(1) = ptLT(1) ptRT(2) = 0 '左侧线 If excelRg.Column = ranges.Column And excelRg.borders.Item(1).linestyle > 0 Then Set objLine = ThisDrawing.ModelSpace.AddLine(ptLT, ptLB) setTableColor objLine, excelRg.borders.Item(1).color End If '右侧线 If excelRg.borders.Item(2).linestyle > 0 Then Set objLine = ThisDrawing.ModelSpace.AddLine(ptRT, ptRB) setTableColor objLine, excelRg.borders.Item(2).color End If '上边线 If excelRg.row = ranges.row And excelRg.borders.Item(3).linestyle > 0 Then Set objLine = ThisDrawing.ModelSpace.AddLine(ptLT, ptRT) setTableColor objLine, excelRg.borders.Item(3).color End If '下边线 If excelRg.borders.Item(4).linestyle > 0 Then Set objLine = ThisDrawing.ModelSpace.AddLine(ptLB, ptRB) setTableColor objLine, excelRg.borders.Item(4).color End If '添加文字 Dim objText As AcadText Set objText = ThisDrawing.ModelSpace.AddText(excelRg.Text, ptLB, excelRg.Font.Size * 0.9) '设置文字的颜色 setTextColor objText, excelRg.Font.color '设置文字的对其方式 setTextAlignMent objText, ptLT, ptRBEnd Function'改变表格的颜色Public Function setTableColor(ByVal objEntity As AcadEntity, ByVal color As Long) If optTableColor2.Value = True Then If cmbTableColor.Text = "By Layer" Then Exit Function ElseIf cmbTableColor.Text = "红色" Then objEntity.color = acRed ElseIf cmbTableColor.Text = "绿色" Then objEntity.color = acGreen ElseIf cmbTableColor.Text = "蓝色" Then objEntity.color = acBlue End If Exit Function End If Dim colorR As Long Dim colorG As Long Dim colorB As Long If optTableColor1.Value = True Then If color <> 0 Then Dim entityColor As AcadAcCmColor Set entityColor = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.19") colorR = color And 255 colorG = (color And 65280) / 256 colorB = (color And 16711680) / 65536 entityColor.SetRGB colorR, colorG, colorB objEntity.TrueColor = entityColor End If End IfEnd Function'改变文字的颜色Public Function setTextColor(ByVal objEntity As AcadEntity, ByVal color As Long) If optTextColor2.Value = True Then If cmbTextColor.Text = "By Layer" Then Exit Function ElseIf cmbTextColor.Text = "红色" Then objEntity.color = acRed ElseIf cmbTextColor.Text = "绿色" Then objEntity.color = acGreen ElseIf cmbTextColor.Text = "蓝色" Then objEntity.color = acBlue End If Exit Function End If Dim colorR As Long Dim colorG As Long Dim colorB As Long If optTextColor1.Value = True Then If color <> 0 Then Dim entityColor As AcadAcCmColor Set entityColor = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.19") colorR = color And 255 colorG = (color And 65280) / 256 colorB = (color And 16711680) / 65536 entityColor.SetRGB colorR, colorG, colorB objEntity.TrueColor = entityColor End If End IfEnd Function'文字的对齐Public Function setTextAlignMent(ByVal objText As AcadText, ByVal ptLT As Variant, ByVal ptRB As Variant) Dim ptMC(2) As Double ptMC(0) = (ptLT(0) + ptRB(0)) / 2 ptMC(1) = (ptLT(1) + ptRB(1)) / 2 ptMC(2) = 0 If optTextAlignment1.Value = True Then objText.Alignment = acAlignmentMiddleCenter objText.Move objText.TextAlignmentPoint, ptMC Exit Function End If Dim ptML(2) As Double ptML(0) = ptLT(0) ptML(1) = (ptLT(1) + ptRB(1)) / 2 ptML(2) = 0 If optTextAlignment2.Value = True Then objText.Alignment = acAlignmentMiddleLeft objText.Move objText.TextAlignmentPoint, ptML Exit Function End If Dim ptMR(2) As Double ptMR(0) = ptRB(0) ptMR(1) = (ptLT(1) + ptRB(1)) / 2 ptMR(2) = 0 If optTextAlignment3.Value = True Then objText.Alignment = acAlignmentMiddleRight objText.Move objText.TextAlignmentPoint, ptMR End IfEnd FunctionPrivate Sub cmdPickPoint_Click() On Error Resume Next Dim pt As Variant UserForm1.Hide pt = ThisDrawing.Utility.GetPoint(, "请选择插入点:") txtX.Text = pt(0): txtY.Text = pt(1) UserForm1.showEnd Sub'设置下拉框的内容Public Function addCombbox() cmbTableColor.AddItem "By Layer" cmbTableColor.AddItem "红色" cmbTableColor.AddItem "绿色" cmbTableColor.AddItem "蓝色" cmbTextColor.AddItem "By Layer" cmbTextColor.AddItem "红色" cmbTextColor.AddItem "绿色" cmbTextColor.AddItem "蓝色"End FunctionPrivate Sub optTableColor1_Change() If optTableColor1.Value = True Then cmbTableColor.Enabled = False cmbTableColor.Text = "" End IfEnd SubPrivate Sub optTableColor2_Click() If optTableColor2.Value = True Then cmbTableColor.Enabled = True cmbTableColor.Text = "By Layer" End IfEnd SubPrivate Sub optTextColor1_Change() If optTextColor1.Value = True Then cmbTextColor.Enabled = False cmbTextColor.Text = "" End IfEnd SubPrivate Sub optTextColor2_Change() If optTextColor2.Value = True Then cmbTextColor.Enabled = True cmbTextColor.Text = "By Layer" End IfEnd SubPrivate Sub UserForm_Initialize() txtX.Text = 0: txtY.Text = 0 optAll.Value = True optTableColor1.Value = True optTextColor1.Value = True addCombbox optTextAlignment1.Value = TrueEnd Sub

▎具体效果（CAD表格导入Excel）

支持合并单元格，如需更细致的需求，需要修改代码相应部分。

▎详细源代码（CAD表格导入Excel）

由于涉及到类代码，这里放个代码截图。

Dim dicHorizontalLine As VariantDim dicVerticalLine As VariantDim arrText() As CTextDim fileConst WRITE_LOG = 0Dim WorkDrawingSub ReadTable() 'file.WriteLine "Type;Object;TagID;Position;Track;Segment;Accuracy;Note;SetupOffset" SelectionName = "ss1" Dim sset As AcadSelectionSet Dim element As AcadEntity For Each sset In ThisDrawing.SelectionSets If sset.Name = SelectionName Then sset.Delete Exit For End If Next Erase arrText Set dicHorizontalLine = CreateObject("Scripting.Dictionary") Set dicVerticalLine = CreateObject("Scripting.Dictionary") 'Set dicText = CreateObject("Scripting.Dictionary") Dim txt As AcadText Dim txtNum As Integer txtNum = 0 Set sset = ThisDrawing.SelectionSets.Add(SelectionName) Dim objType As String sset.SelectOnScreen If sset.Count > 0 Then For Each element In sset objType = element.ObjectName Select Case objType Case "AcDbLine" AddLine element.StartPoint, element.EndPoint Case "AcDbText" Set txt = element If 1 Then On Error Resume Next txtNum = UBound(arrText) End If txtNum = txtNum + 1 ReDim Preserve arrText(1 To txtNum) Set arrText(txtNum) = New CText arrText(txtNum).TextString = txt.TextString Dim MinPoint, MaxPoint txt.GetBoundingBox MinPoint, MaxPoint arrText(txtNum).SetMaxPoint MaxPoint arrText(txtNum).SetMinPoint MinPoint 'GetBoundingBox End Select Next If WRITE_LOG = 1 Then SaveLines dicHorizontalLine, "Horizontal" SaveLines dicVerticalLine, "Vertical" Dim fsObj Set fsObj = CreateObject("Scripting.FileSystemObject") Set file = fsObj.CreateTextFile(ThisDrawing.Path & "\debug.csv", True) file.WriteLine "Remove Horizontal..." End If RemoveShortLines dicHorizontalLine, dicVerticalLine If WRITE_LOG = 1 Then file.WriteLine "Remove Vertical..." End If RemoveShortLines dicVerticalLine, dicHorizontalLine 'DrawLines dicHorizontalLine 'DrawLines dicVerticalLine, False 'DrawTexts ExportExcel If WRITE_LOG = 1 Then file.Close End If End If sset.Delete '??????????" 'dim ttps as 'For Each tps In dicHorizontalLine 'NextEnd SubSub ExportExcel() ' Dim xlApp As Excel.Application ' Dim xlBook As Excel.Workbook ' Dim xlSheet As Excel.WorkSheet Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.workbooks.Add Set xlsheet = xlBook.Worksheets(1) ' 'dicVerticalLine Dim dicHorizontalSort Dim dicVerticalSort Set dicHorizontalSort = CreateObject("Scripting.Dictionary") Set dicVerticalSort = CreateObject("Scripting.Dictionary") SortDic dicHorizontalLine, dicHorizontalSort SortDic dicVerticalLine, dicVerticalSort Dim dicCells Set dicCells = CreateObject("Scripting.Dictionary") iHorizontal = dicHorizontalSort.Count iVertical = dicVerticalSort.Count Dim downH, upH Dim downV, upV Dim x, y Dim col_from, col_to, row_from, row_to Dim strCell As String Dim aCell As CCell Dim txt As CText For Each atxt In arrText Set txt = atxt 'xlSheet.Cells(row, col) = txt 'col = col + 1 x = txt.GetMidX() y = txt.GetMidY() GetScale dicHorizontalLine, y, x, downH, upH GetScale dicVerticalLine, x, y, downV, upV 'Debug.Print x, y, dicHorizontalSort(downH), dicHorizontalSort(upH), dicVerticalSort(downV), dicVerticalSort(upV) 'Debug.Print txt.TextString, downV, x, upV, downH, y, upH 'Debug.Print txt.TextString, dicVerticalSort(downV), x, dicVerticalSort(upV), iHorizontal - dicHorizontalSort(downH), y, iHorizontal - dicHorizontalSort(upH) col_from = dicVerticalSort(downV) - 1 col_to = dicVerticalSort(upV) - 1 row_from = iHorizontal - dicHorizontalSort(upH) row_to = iHorizontal - dicHorizontalSort(downH) strCell = xlsheet.Cells(row_from + 1, col_from + 1) xlsheet.range(xlsheet.Cells(row_from + 1, col_from + 1), xlsheet.Cells(row_to, col_to)).MergeCells = True xlsheet.Cells(row_from + 1, col_from + 1).NumberFormat = "@" strCell = (col_from + 1) & "-" & (row_from + 1) If dicCells.exists(strCell) Then dicCells(strCell).AddText txt Else Set aCell = New CCell aCell.col = col_from + 1 aCell.row = row_from + 1 aCell.AddText txt dicCells.Add strCell, aCell End If Next For Each ecell In dicCells Set aCell = dicCells(ecell) xlsheet.Cells(aCell.row, aCell.col) = aCell.GetString Next If Trim(strCell) <> "" Then strCell = strCell & Chr(10) & txt.TextString Else strCell = txt.TextString End If xlsheet.Cells(row_from + 1, col_from + 1) = txt.TextString '//调整导出数据格式 max_col = CNtoW(xlsheet.usedrange.Columns.Count, xlsheet) max_row = xlsheet.usedrange.Rows.Count xlsheet.Columns("a:" & max_col).EntireColumn.AutoFit Set rng = xlsheet.range("a1:" & max_col & max_row) 调整边框 rng 居中对齐 rng xlApp.Visible = TrueEnd SubSub GetScale(dic, y_x, x_y, down, up) down = -1 up = 9999999 For Each v In dic If dic(v).IsWithin(x_y) Then If v > down And v < y_x Then down = v End If If v < up And v > y_x Then up = v End If End If NextEnd SubSub SortDic(dic, sort) 'j = 0 For Each num In dic i = 1 For Each num1 In dic If num > num1 Then i = i + 1 End If Next 'j = j + 1 sort.Add num, i Next 'For Each num In sort ' Debug.Print num, dicHorizontalSort(num) 'NextEnd SubSub SaveLines(dic, fn) If WRITE_LOG = 1 Then Dim fsObj Set fsObj = CreateObject("Scripting.FileSystemObject") Set file = fsObj.CreateTextFile(ThisDrawing.Path & "\" & fn & ".csv", True) file.WriteLine fn & ";Min;Max" For Each tp In dic For Each ctp In dic(tp).GetPoints file.WriteLine tp & ";" & ctp.MinP & ";" & ctp.MaxP Next Next file.Close End IfEnd SubSub DrawLines(dic, Optional Horizontal As Boolean = True) Dim ctp As CPoint For Each tps In dic For Each tp In dic(tps).GetPoints Set ctp = tp DrawLine tps, ctp.MinP, ctp.MaxP, Horizontal Next NextEnd SubSub DrawTexts() Dim MyText As AcadText For Each txt In arrText 'Set MyText = ThisDrawing.ModelSpace.AddText(txt.TextString, txt.MinPoint, 1) NextEnd SubSub DrawLine(pc, p1, p2, Optional Horizontal As Boolean = True) Dim sp(0 To 2) As Double Dim ep(0 To 2) As Double x_offset = 0 y_offset = 25 If Horizontal Then sp(0) = p1 + x_offset sp(1) = pc + y_offset sp(2) = 0 ep(0) = p2 + x_offset ep(1) = pc + y_offset ep(2) = 0 Else sp(0) = pc + x_offset sp(1) = p1 + y_offset sp(2) = 0 ep(0) = pc + x_offset ep(1) = p2 + y_offset ep(2) = 0 End If Dim MyLine As AcadLine Set MyLine = ThisDrawing.ModelSpace.AddLine(sp, ep)End SubSub RemoveShortLines(ori, ref) Dim ctp As CPoint Dim dicRemove As Variant For Each tps In ori Set dicRemove = CreateObject("Scripting.Dictionary") 'i = 1 For Each tp In ori(tps).GetPoints Set ctp = tp 'Debug.Print "Remove?", tps, tp.MinP, tp.MaxP 'strline = If WRITE_LOG = 1 Then file.WriteLine "Remove?" & ";" & tps & ";" & tp.MinP & ";" & tp.MaxP End If If Not IsBorder(ctp, ref) Then dicRemove.Add ctp, "" End If Next ori(tps).RemoveShortLines (dicRemove) Set dicRemove = Nothing Next For Each tps In ori If ori(tps).Count = 0 Then ori.Remove tps End If NextEnd SubFunction IsBorder(ByVal tp As CPoint, ByVal ref) As Boolean IsBorder = False For Each tps In ref If tps = tp.MinP Or _ tps = tp.MaxP Then IsBorder = True Exit Function End IfNextEnd FunctionSub AddLine(StartPoint, EndPoint) NumDigits = 1 ShortestLine = 0.3 line_len = ((StartPoint(0) - EndPoint(0)) ^ 2 + (StartPoint(1) - EndPoint(1)) ^ 2) ^ 0.5 If line_len < ShortestLine Then Exit Sub StartPoint(0) = Round(StartPoint(0), NumDigits) StartPoint(1) = Round(StartPoint(1), NumDigits) EndPoint(0) = Round(EndPoint(0), NumDigits) EndPoint(1) = Round(EndPoint(1), NumDigits) If StartPoint(0) = EndPoint(0) Then AddLineTo dicVerticalLine, StartPoint(0), StartPoint(1), EndPoint(1) End If If StartPoint(1) = EndPoint(1) Then AddLineTo dicHorizontalLine, StartPoint(1), StartPoint(0), EndPoint(0) End IfEnd SubSub AddLineTo(dicLine, x_y, sp, ep) If dicLine.exists(x_y) Then dicLine(x_y).Add sp, ep Else Dim tps As CPointSet Set tps = New CPointSet tps.Add sp, ep dicLine.Add x_y, tps End IfEnd Sub'/////////////////////////////////////////////////////////////////////' 调整格式'/////////////////////////////////////////////////////////////////////'列数转字母Function CNtoW(ByVal num As Long, sht) As String CNtoW = Replace(sht.Cells(1, num).Address(False, False), "1", "")End FunctionSub 调整边框(rng) With rng.Borders(7) .LineStyle = 1 .ColorIndex = 0 .TintAndShade = 0 .Weight = 2 End With With rng.Borders(8) .LineStyle = 1 .ColorIndex = 0 .TintAndShade = 0 .Weight = 2 End With With rng.Borders(9) .LineStyle = 1 .ColorIndex = 0 .TintAndShade = 0 .Weight = 2 End With With rng.Borders(10) .LineStyle = 1 .ColorIndex = 0 .TintAndShade = 0 .Weight = 2 End With With rng.Borders(11) .LineStyle = 1 .ColorIndex = 0 .TintAndShade = 0 .Weight = 2 End With With rng.Borders(12) .LineStyle = 1 .ColorIndex = 0 .TintAndShade = 0 .Weight = 2 End WithEnd SubSub 居中对齐(rng) With rng .HorizontalAlignment = -4108 .VerticalAlignment = -4108 .WrapText = True .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = -5002 End WithEnd Sub

类模块相关代码：

模块名：CCell

Private TextList() As CTextPublic col As IntegerPublic row As IntegerPublic Sub AddText(txt As CText) Count = 0 If 1 Then On Error Resume Next Count = UBound(TextList) End If Count = Count + 1 ReDim Preserve TextList(1 To Count) Set TextList(Count) = txtEnd SubPublic Function GetString() On Error Resume Next Count = UBound(TextList) If Count = 1 Then GetString = TextList(1).TextString Exit Function End If GetString = "" Dim strList() As String, strTemp As String Dim yList() As Double, yTemp As Double ReDim strList(1 To Count) ReDim yList(1 To Count) For i = 1 To Count 'For Each txt In TextList 'GetString = GetString & Chr(10) & txt.TextString strList(i) = TextList(i).TextString yList(i) = TextList(i).GetMidY Next For i = 1 To Count - 1 For j = i + 1 To Count If yList(i) < yList(j) Then yTemp = yList(i) yList(i) = yList(j) yList(j) = yTemp strTemp = strList(i) strList(i) = strList(j) strList(j) = strTemp End If Next Next GetString = strList(1) For i = 2 To Count GetString = GetString & Chr(10) & strList(i) NextEnd Function

模块名：CPoint

Public MinP As DoublePublic MaxP As Double

模块名：CPointSet

Public Count As IntegerPrivate arrPoints() As CPointPublic Function GetPoints() GetPoints = arrPointsEnd FunctionPublic Function IsWithin(v) As Boolean IsWithin = False For Each p In arrPoints If p.MinP <= v And p.MaxP >= v Then IsWithin = True Exit Function End If NextEnd FunctionPublic Function RemoveShortLines(dicRemove) As Integer RemoveShortLines = Count If Count < 1 Then Exit Function Dim arrP() As CPoint ReDim arrP(1 To Count) j = 0 Dim bRemove As Boolean For i = 1 To Count bRemove = False For Each p In dicRemove If p.MinP = arrPoints(i).MinP And p.MaxP = arrPoints(i).MaxP Then bRemove = True End If Next If Not bRemove Then j = j + 1 Set arrP(j) = arrPoints(i) End If Next If j > 0 Then ReDim Preserve arrP(1 To j) arrPoints = arrP End If Count = j RemoveShortLines = CountEnd FunctionPublic Function RemoveWith(ByVal cpt As CPoint) As Integer If Count = 0 Then Count = 0 RemoveWith = 0 Exit Function End If iRemoveAt = 0 For i = 1 To Count If arrPoints(i).MaxP = cpt.MaxP And arrPoints(i).MinP = cpt.MinP Then iRemoveAt = i Exit For End If Next If iRemoveAt > 0 Then Count = Count - 1 If Count > 0 Then 'If iRemoveAt <= Count Then For j = iRemoveAt To Count arrPoints(j).MaxP = arrPoints(j + 1).MaxP arrPoints(j).MinP = arrPoints(j + 1).MinP Next 'End If ReDim Preserve arrPoints(1 To Count) Else Count = 0 'ReDim arrPoints() End If End If RemoveWith = CountEnd FunctionPublic Sub Add(Point1, Point2) If Point1 > Point2 Then MinP = Point2 MaxP = Point1 Else MinP = Point1 MaxP = Point2 End If If Count > 0 Then For Each point In arrPoints If point.MaxP = MinP Then point.MaxP = MaxP Exit Sub End If If point.MinP = MaxP Then point.MinP = MinP Exit Sub End If If point.MaxP = MaxP And point.MinP = MinP Then Exit Sub Next End If Count = Count + 1 ReDim Preserve arrPoints(1 To Count) Set arrPoints(Count) = New CPoint arrPoints(Count).MinP = MinP arrPoints(Count).MaxP = MaxPEnd Sub


模块名：CText

Private MinPoint(0 To 2) As DoublePrivate MaxPoint(0 To 2) As DoublePublic TextString As String
Public Sub SetMinPoint(p) MinPoint(0) = p(0) MinPoint(1) = p(1) MinPoint(2) = p(2)End Sub
Public Sub SetMaxPoint(p) MaxPoint(0) = p(0) MaxPoint(1) = p(1) MaxPoint(2) = p(2)End Sub
Public Function GetMinPoint() GetMinPoint = MinPointEnd Function
Public Function GetMaxPoint() GetMaxPoint = MaxPoint()End Function
Public Function GetMidX() GetMidX = (MinPoint(0) + MaxPoint(0)) / 2End FunctionPublic Function GetMidY() GetMidY = (MinPoint(1) + MaxPoint(1)) / 2End Function