VBA实现Excel与CAD表格互转

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

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

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

Public MinP As DoublePublic MaxP As Double

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

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