[软件相关] 另一款国产office表格转CAD的软件Truetable

帮忙给我一个吧！谢谢

york.ruan@britoil.com.sg

顶

我自己编了一个程序，用的时候粘到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

在哪里呀