[灌水]将EXCEL表格转换为AutoCAD图形
有些工程图纸中有大量的数据信息，并以表格形式出现，如果这些表格有EXCEL文件，或使用EXCEL作成比较方便，然后使用本程序转换成AutoCAD图形将有意想不到的效果。Private Sub ExportToACAD()
On Error Resume Next
Dim objAcad As Object ''AcadApplication
Dim objAcadDoc As Object ''AcadDocument
Dim objModelSpace As Object ''AcadModelSpace
Dim msgResult As Integer
Dim a As Range
If Selection Is Nothing Then MsgBox "Nothing Selected!": Exit Sub
msgResult = MsgBox("您共选择了" & Selection.Rows.Count & "行、" & Selection.Columns.Count & "列，" _
& Chr(13) & "请注意一些对齐方式可能被忽略！" _
& Chr(13) & "继续吗？", vbOKCancel, "选择")
If msgResult = vbCancel Then Exit Sub
Err.Clear
Set objAcad = GetObject(, "autocad.application")
If Err.Number = 0 Then GoTo Finish
Err.Clear
Set objAcad = CreateObject("autocad.application")
Finish: '''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
MsgBox "You must have AutoCAD installed to run this Macro!", vbCritical, "Export to ACAD"
Exit Sub
End If
On Error GoTo errHandler
Set objAcadDoc = objAcad.Documents.Add
Set objModelSpace = objAcadDoc.ModelSpace
Dim textObj As Object ''AcadText
Dim lineObj As Object ''AcadLine
Dim insPnt(0 To 2) As Double
Dim stPnt(0 To 2) As Double
Dim edPnt(0 To 2) As Double
Dim txtHeight As Double
Const txtClearance As Double = 2
Static startY As Double
startY = Selection.Rows(Selection.Rows.Count).Top - Selection.Rows(1).Top
For Each a In Selection
If a.Borders(xlEdgeTop).LineStyle = xlContinuous Then
stPnt(0) = a.Left: stPnt(1) = startY - a.Top: stPnt(2) = 0
edPnt(0) = a.Left + a.Width: edPnt(1) = stPnt(1): edPnt(2) = 0
Set lineObj = objModelSpace.AddLine(stPnt, edPnt)
End If
If a.Borders(xlEdgeLeft).LineStyle = xlContinuous Then
stPnt(0) = a.Left: stPnt(1) = startY - a.Top: stPnt(2) = 0
edPnt(0) = stPnt(0): edPnt(1) = startY - a.Top - a.Height: edPnt(2) = 0
Set lineObj = objModelSpace.AddLine(stPnt, edPnt)
End If
txtHeight = a.Font.Size / 1.5
If Trim(a.Text) <> "" Then
If a.HorizontalAlignment = xlCenter Then
insPnt(0) = a.Left + a.Width / 2
insPnt(1) = startY - a.Top - a.Height / 2
insPnt(2) = 0
Set textObj = objModelSpace.AddText(a.Text, insPnt, txtHeight)
textObj.Alignment = 10'acAlignmentMiddleCenter
textObj.TextAlignmentPoint = insPnt
ElseIf a.HorizontalAlignment = xlLeft Or (a.HorizontalAlignment = xlGeneral And _
Not IsNumeric(a.Text)) Then
insPnt(0) = a.Left + txtClearance
insPnt(1) = startY - a.Top - a.Height / 2
insPnt(2) = 0
Set textObj = objModelSpace.AddText(a.Text, insPnt, txtHeight)
textObj.Alignment = 9 'acAlignmentMiddleLeft
textObj.TextAlignmentPoint = insPnt
Else
insPnt(0) = a.Left + a.Width - txtClearance
insPnt(1) = startY - a.Top - a.Height / 2
insPnt(2) = 0
Set textObj = objModelSpace.AddText(a.Text, insPnt, txtHeight)
textObj.Alignment = 11'acAlignmentMiddleRight
textObj.TextAlignmentPoint = insPnt
End If
End If
Next a
For Each a In Selection.Offset(Selection.Rows.Count - 1, 0). _
Resize(1, Selection.Columns.Count)
If a.Borders(xlEdgeBottom).LineStyle = xlContinuous Then
stPnt(0) = a.Left: stPnt(1) = startY - a.Top - a.Height: stPnt(2) = 0
edPnt(0) = a.Left + a.Width: edPnt(1) = stPnt(1): edPnt(2) = 0
Set lineObj = objModelSpace.AddLine(stPnt, edPnt)
End If
Next
For Each a In Selection.Offset(0, Selection.Columns.Count - 1). _
Resize(Selection.Rows.Count, 1)
If a.Borders(xlEdgeRight).LineStyle = xlContinuous Then
stPnt(0) = a.Left + a.Width: stPnt(1) = startY - a.Top: stPnt(2) = 0
edPnt(0) = stPnt(0): edPnt(1) = startY - a.Top - a.Height: edPnt(2) = 0
Set lineObj = objModelSpace.AddLine(stPnt, edPnt)
End If
Next
Application.WindowState = xlMinimized
objAcad.WindowState = acMax
objAcad.Visible = True
objAcad.ZoomAll
Set objAcad = Nothing
Set objAcadDoc = Nothing
Set objModelSpace = Nothing
Exit Sub
errHandler:
MsgBox "在该系统中不能正常运行！" & Chr(10) & Err.Description, vbCritical, "Export to ACAD"
objAcad.Close
End Sub
回复
能减少很大工作量的程序! 我也想要這樣的一個功能. 但是我的EXCEL文件和你的不同, 我又不懂這個語言, 所以我把我的EXCEL文件放上來. 你看看有沒有辦法做出來. 我的意思是要在CAD把X坐標和Y坐標組成一個點在CAD里面用PLINE畫出來可不可以做得到呀?不错! 你是想用坐标值画线？当然可以，只用一个画二维多义线功能，如下(4段直线）：
Dim plineObj as AcadLWPloyline
Dm points( 0 to 9) As Double
points(0) = 25: points(1) = 25
points(2) = 25: points(3) = 50
points(4) = 50: points(5) = 50
points(6) = 75: points(7) = 20
points(8) = 100: points(9) = 100
set plineObj= ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
ZoomAll
如果要闭合再加上一句：
plineObj.Closed = True 樓上. 我不懂VBA的. 不過我不知道你上面的程序能不能把EXCEL文件的數組成坐標在CAD畫出來呀/ 你的程序的意思好象是說用VBA在CAD畫 4 段直线, 不是在EXCEL里讀出坐標畫出來喔.難怪程序這麼短. 多多向大俠學習.
＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿
我愛ＣＡＤ． 多多指教． 楼上？啥意思？
不懂？......
”EXCEL里讀出坐標畫出來“ 第一个程序里已经实现了嘛！ 请教：
你的曲线是不是镜片？ 是啊，大俠你幫手把這個程序做給我用好吧． Thank you : ) 对不起，太忙，以后吧！