将EXCEL表格转换成CAD表格的完整代码

是将EXCEL表格转换成CAD表格的完整代码，包括文字和表格的转换，有兴趣的朋友可以试用一下，欢迎提出宝贵意见，相互交流。

请将下列代码粘贴到记事本中，另存为“FormETC.frm”，可以有VB打开或者导入EXCEL VBA中。

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} FormETC
   Caption         =   "表格转换"
   ClientHeight    =   1515
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   3735
   OleObjectBlob   =   "FormETC.frx":0000
   StartUpPosition =   1  '所有者中心
End
Attribute VB_Name = "FormETC"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Sub ChangeExcelToCADText(StartLine As Integer, EndLine As Integer, StartCor As Integer, EndCor As Integer)

      Dim AcadApp As AutoCAD.AcadApplication
      Dim CellText As AutoCAD.AcadText
      Dim TextPoint(2)  As Double
  

      Dim i As Integer, j As Integer
      Dim CellWith As Double, CellHigh As Double
      Dim StartX As Double, StartY As Double
      Dim EndX As Double, EndY As Double
      Dim LastX As Double, LastY As Double '上一行或列最后的坐标
      Dim TableWith As Double, TableHeight  As Double '表格的总宽，总高
      Dim ActivateCellAddress As CellAddress
     
      On Error GoTo exitflag
      Me.Caption = "转换中，请稍候..."
      Set AcadApp = GetObject(, "AutoCAD.Application")
     
      TableWith = GetTableWith(StartLine, EndLine, StartCor, EndCor)
      TableHeight = GetTableHeight(StartLine, EndLine, StartCor, EndCor)
     
      StartX = 0
      StartY = 0
      EndX = TableWith
      EndY = StartY
      LastX = 0
      LastY = 0
      AcadApp.ActiveDocument.SendCommand ("Line " & StartX & "," & StartY & " " & EndX & "," & EndY & "  ")
     
      '画横线
      For i = StartLine To EndLine
        DoEvents
        CellHigh = Range(Chr(StartCor) & i).Height
        StartX = 0
        StartY = LastY - CellHigh
        LastX = 0
        LastY = StartY
        EndX = TableWith
        EndY = StartY

        For j = StartCor To EndCor
            ActivateCellAddress = GetCellAddressSub(Range(Chr(j) & i).MergeArea.Address)
           
            LastX = LastX + Range(Chr(j) & i).Width
           
           '写文字
            If Range(Chr(j) & i).MergeArea.Address = Range(Chr(j) & i).Address And _
            Trim(Range(Chr(j) & i).MergeArea.Text) <> "" Then
               EndX = LastX - Range(Chr(j) & i).Width
               TextPoint(0) = EndX + Range(Chr(j) & i).Width / 2
               TextPoint(1) = LastY + Range(Chr(j) & i).Height / 2
               Set CellText = AcadApp.ActiveDocument.ModelSpace.AddText(Range(Chr(j) & i).Text, _
                               TextPoint, Range(Chr(j) & i).Font.Size)
               CellText.Alignment = acAlignmentMiddle
               CellText.TextAlignmentPoint = TextPoint
               CellText.Update
            End If
            If ActivateCellAddress.EndLine <> i And ActivateCellAddress.StartCor = j Then
               EndX = LastX - Range(Chr(j) & i).Width
               If Trim(Range(Chr(j) & i).Text) <> "" Then
                    TextPoint(0) = EndX + Range(Chr(j) & i).MergeArea.Width / 2
                    TextPoint(1) = EndY - Range(Chr(j) & i).MergeArea.Height / 2 + Range(Chr(j) & i).Height
                   
                    Set CellText = AcadApp.ActiveDocument.ModelSpace.AddText(Range(Chr(j) & i).Text, _
                                    TextPoint, Range(Chr(j) & i).Font.Size)
                    CellText.Alignment = acAlignmentMiddle
                    CellText.TextAlignmentPoint = TextPoint
                    CellText.Update
               End If
               If Abs(StartX - EndX) > 0.0000001 Then
                  AcadApp.ActiveDocument.SendCommand ("Line " & StartX & "," & StartY & " " & EndX & "," & EndY & "  ")
               End If
            End If
            If ActivateCellAddress.EndCor = j And ActivateCellAddress.EndLine <> i Then
               StartX = LastX
            End If
        Next j
       
        EndX = TableWith
        If Abs(StartX - EndX) > 0.0000001 Then
           AcadApp.ActiveDocument.SendCommand ("Line " & StartX & "," & StartY & " " & EndX & "," & EndY & "  ")
        End If
      Next i
     
     '画竖线
      StartX = 0
      StartY = 0
      EndX = 0
      EndY = TableHeight
      AcadApp.ActiveDocument.SendCommand ("Line " & StartX & "," & StartY & " " & EndX & "," & EndY & "  ")

      For i = StartCor To EndCor
         DoEvents
         CellWith = Range(Chr(i) & StartLine).Width
         LastX = StartX
         LastY = 0
         StartX = LastX + CellWith
         StartY = 0
         EndX = StartX
         EndY = TableHeight
         For j = StartLine To EndLine
            ActivateCellAddress = GetCellAddressSub(Range(Chr(i) & j).MergeArea.Address)
            LastY = LastY - Range(Chr(i) & j).Height
            If ActivateCellAddress.EndCor <> i And ActivateCellAddress.StartLine = j Then
               EndY = LastY + Range(Chr(i) & j).Height
               If Abs(StartY - EndY) > 0.0000001 Then
                  AcadApp.ActiveDocument.SendCommand ("Line " & StartX & "," & StartY & " " & EndX & "," & EndY & "  ")
               End If
            End If
            If ActivateCellAddress.EndLine = j And ActivateCellAddress.EndCor <> i Then
               StartY = LastY
            End If

        Next j
        EndY = TableHeight
        If Abs(StartY - EndY) > 0.0000001 Then
           AcadApp.ActiveDocument.SendCommand ("Line " & StartX & "," & StartY & " " & EndX & "," & EndY & "  ")
        End If
   
      Next i

      MsgBox "转换成功"
      Exit Sub
exitflag:
      Me.Caption = "表格转换"

End Sub

Function GetCellAddressSub(CellAddress As String) As CellAddress
          Dim i As Integer, j As Integer, C1 As Integer, C2 As Integer, L1 As Integer, L2 As Integer
          Dim str1 As String, str2 As String
          For i = 1 To Len(CellAddress)
            str1 = Mid(CellAddress, i, 1)
            If str1 = "$" Then
              j = j + 1
              If j = 1 Or j = 3 Then
                  C1 = i + 1
              End If
              If j = 2 Then
                 C2 = i - C1
                 L1 = i + 1
                 GetCellAddressSub.StartCor = Asc(Mid(CellAddress, C1, C2))
              End If
              If j = 4 Then
                 C2 = i - C1
                 L1 = i + 1
                 L2 = Len(CellAddress)
                 GetCellAddressSub.EndCor = Asc(Mid(CellAddress, C1, C2))
                 GetCellAddressSub.EndLine = Mid(CellAddress, L1, L2)
                 Exit For
              End If
            End If
            If str1 = ":" Then
                L2 = i - L1
                GetCellAddressSub.StartLine = Mid(CellAddress, L1, L2)
            End If
          Next i
         
          If j = 2 Then
            L2 = Len(CellAddress)
            GetCellAddressSub.StartLine = Mid(CellAddress, L1, L2)
            GetCellAddressSub.EndLine = GetCellAddressSub.StartLine
            GetCellAddressSub.EndCor = GetCellAddressSub.StartCor
          End If

End Function
Function GetTableWith(StartLine As Integer, EndLine As Integer, StartCor As Integer, EndCor As Integer) As Double
    Dim i As Integer
    Dim CellWith As Double

    GetTableWith = 0
    For i = StartCor To EndCor
       CellWith = Range(Chr(i) & StartLine).Width
       GetTableWith = GetTableWith + CellWith
    Next i

End Function
Function GetTableHeight(StartLine As Integer, EndLine As Integer, StartCor As Integer, EndCor As Integer) As Double
      Dim i As Integer
      Dim CellHigh As Double
     
      GetTableHeight = 0

      For i = StartLine To EndLine
        CellHigh = Range(Chr(StartCor) & i).Height
        GetTableHeight = GetTableHeight - CellHigh
      Next i

End Function

Private Sub CommandButton1_Click()
ChangeExcelToCADText Val(TextBox1.Text), Val(TextBox2.Text), Asc(TextBox3.Text), Asc(TextBox4.Text)

End Sub

Private Sub UserForm_Click()

End Sub