|
我自己编了一个程序，用的时候粘到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
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 End Sub | 
楼主
发表于 2006-10-25 18:23
提升卡
变色卡
