|
|
有些工程图纸中有大量的数据信息，并以表格形式出现，如果这些表格有EXCEL文件，或使用EXCEL作成比较方便，然后使用本程序转换成图形将有意想不到的效果。
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 |
|
置顶卡
请点击此处下载
