建筑新时代论坛 » CAD应用及二次开发 » CAD开发爱好者联盟 » 能用VBA编程在AUTO中绘制表格吗?怎么做啊?

shenhongxin 发表于 2007-6-3 11:10

能用VBA编程在AUTO中绘制表格吗?怎么做啊?

谢谢大家了,我不太懂:handshake

gscxf2006 发表于 2007-6-27 22:18

Dim acadapp As Object     ''AcadApplication
Dim acaddoc As Object      ''AcadDocument
Dim acadMos As Object       ''AcadModelSpace
Dim a As Range

Set acadapp = GetObject(, "autocad.application")
Set acaddoc = acadapp.ActiveDocument
Set acadMos = acaddoc.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 = acadMos.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 = acadMos.AddLine(stPnt, edPnt)
    End If
    txtHeight = a.Font.Size
    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 = acadMos.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 = acadMos.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 = acadMos.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 = acadMos.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 = acadMos.AddLine(stPnt, edPnt)
    End If
Next

Application.WindowState = xlMinimized
acadapp.WindowState = acMax
acadapp.Visible = True
acadapp.ZoomAll
Set acadapp = Nothing
Set acaddoc = Nothing
Set acadMos = Nothing

gscxf2006 发表于 2007-6-27 22:20

EXCEL转到CAD

iceman999 发表于 2007-6-28 15:23

[quote]原帖由 [i]gscxf2006[/i] 于 2007-6-27 22:20 发表 [url=http://www.jzcad.com/bbs/redirect.php?goto=findpost&pid=184663&ptid=27550][img]http://www.jzcad.com/bbs/images/common/back.gif[/img][/url]
EXCEL转到CAD [/quote]
:handshake 棒极了！

GZM98950 发表于 2007-7-26 10:33

很好的,我试试,学习一下

lee_2007 发表于 2007-7-29 11:05

怎么不行啊， 我把代码输进去提示好多错误

查看完整版本: 能用VBA编程在AUTO中绘制表格吗?怎么做啊?