是将EXCEL表格转换成CAD表格的完整代码，包括文字和表格的转换，有兴趣的朋友可以试用一下，欢迎提出宝贵意见，相互交流。
请将下列代码粘贴到记事本中，另存为“FormETC.frm”，可以有VB打开或者导入EXCEL VBA中。
VERSION 5.00Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} FormETC Caption = "表格转换" ClientHeight = 1515 ClientLeft = 45 ClientTop = 435 ClientWidth = 3735 OleObjectBlob = "FormETC.frx":0000 StartUpPosition = 1 '所有者中心EndAttribute VB_Name = "FormETC"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = FalseOption 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 Subexitflag: 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 FunctionFunction 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 FunctionFunction 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
