[灌水]将EXCEL表格转换为AutoCAD图形

asahix

有些工程图纸中有大量的数据信息，并以表格形式出现，如果这些表格有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

王咣生

能减少很大工作量的程序!

BDYCAD

我也想要這樣的一個功能. 但是我的EXCEL文件和你的不同, 我又不懂這個語言, 所以我把我的EXCEL文件放上來. 你看看有沒有辦法做出來. 我的意思是要在CAD把X坐標和Y坐標組成一個點在CAD里面用PLINE畫出來可不可以做得到呀?

myfreemind

不错!

asahix

你是想用坐标值画线？当然可以，只用一个画二维多义线功能，如下(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

BDYCAD

樓上. 我不懂VBA的. 不過我不知道你上面的程序能不能把EXCEL文件的數組成坐標在CAD畫出來呀/ 你的程序的意思好象是說用VBA在CAD畫 4 段直线, 不是在EXCEL里讀出坐標畫出來喔.難怪程序這麼短. 多多向大俠學習.



＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿
　我愛ＣＡＤ．　　多多指教．

asahix

楼上？啥意思？
不懂？......
”EXCEL里讀出坐標畫出來“ 第一个程序里已经实现了嘛！

asahix

请教：
你的曲线是不是镜片？

BDYCAD

是啊，大俠你幫手把這個程序做給我用好吧．　Thank you : )

asahix

对不起，太忙，以后吧！