通过VBA，从XLS的VBA编辑器，通过XLS生成DWG

Sub Draw_Lines()
Dim selRng As Range
Dim lineData As Variant
Dim DataStart, DataEnd, DataRange
Dim WorkSheetInput As String, DataInput As String, ChartInput As String
Dim i As Integer, j As Integer, NumRows As Integer
Dim numcols As Integer, StartRow As Integer, EndRow As Integer, StartCol As Integer, EndCol As Integer
Dim MinY As Double, MaxY As Double, MinX As Double, MaxX As Double, MaxWidth As Double
' Switch to AutoCAD
Dim acad As AutoCAD.AcadApplication
Dim adoc As AutoCAD.AcadDocument
Dim aspace As AcadBlock
Dim appNum As String
On Error GoTo ErrorHandler
appNum = acadVerNum
If appNum = "" Then
    Exit Sub
End If
On Error Resume Next
Set acad = GetObject(, "Autocad.Application." & appNum)
If Err.Number = 429 Then
Err.Clear
On Error GoTo 0
Set acad = CreateObject("Autocad.Application." & appNum)
If Err Then
Exit Sub
End If
End If
acad.WindowState = acMax
Set adoc = acad.ActiveDocument
Set aspace = adoc.ActiveLayout.Block
' Get the chart data from Excel
Application.ScreenUpdating = False
' Need to selection the chart data from the worksheet
DataInput = "INSULATOR_SWING"
ChartInput = "CHART_DATA"
Worksheets(ChartInput).Activate
StartRow = 5 ' Need to have method to verify start location with other program
StartCol = 1
EndRow = LastRow(Worksheets(ChartInput))
EndCol = LastCol(Worksheets(ChartInput))
'EndRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
'EndCol = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count
DataStart = Cells(StartRow, StartCol).Address(False, False)
DataEnd = Cells(EndRow, EndCol).Address(False, False)
DataRange = DataStart + ":" + DataEnd
Set selRng = Worksheets(ChartInput).Range(DataRange)
'Set selRng = Selection
lineData = selRng.Value2
MaxX = Worksheets(DataInput).Cells(8, 11)
MinX = Worksheets(DataInput).Cells(7, 11)
NumRows = UBound(lineData, 1) ' Number of Rows
numcols = UBound(lineData, 2) ' Number of Columns
MaxY = 0 ' Reset MaxY Value
For j = 2 To numcols
    If lineData(NumRows, j) > MaxY Then
        MaxY = lineData(NumRows, j)
    End If
Next j
adoc.SetVariable "LTSCALE", (MaxX / 40)
Dim LineTypeObject As AcadLineType
Dim oSpline As AcadSpline
Dim oLWPline As AcadPolyline
Dim GraphLineHor, GraphLineVer, GridLineHor, GridLineVer, TickLine, ChartLine As AcadLine
Dim TickLabel As AcadText
Dim AxixLabel, TempText As AcadText
Dim TextString As String
Dim LineType As String
Dim LayerName As String
Dim TxtLayName As String
Dim BrdrLayName As String
Dim GridLayName As String
Dim Xscale As Double
Dim ticklength As Double
Xscale = 1#  ' 2.5  need to add as an input ?  On the excel sheet?
Dim TextPoint(0 To 2) As Double
Dim GridStart(0 To 2) As Double
Dim GridEnd(0 To 2) As Double
Dim GraphStartPt(0 To 2) As Double
Dim GraphXEndPt(0 To 2) As Double
Dim GraphYEndPt(0 To 2) As Double
Dim TickPtStart(0 To 2) As Double
Dim TickPtEnd(0 To 2) As Double
' Setup Layers for text, grids, and borders
TxtLayName = "Text"
BrdrLayName = "Border"
GridLayName = "Grid"
MakeSetLayer (TxtLayName)
MakeSetLayer (BrdrLayName)
MakeSetLayer (GridLayName)
'Set LineTypeObject = AcadLineType.Load(LineType, LineTypeFileName)
On Error Resume Next
adoc.Linetypes.Load "DOT", "acad.lin"
'--------------------------------------------------------------------
' TO DO.....
' Draw the Grid lines and axis lines
' Need to: Create layers for the various items
'           1. Grid lines with appropriate color
'           2. Graph borders ""
'           3. Text ""
'           4. Graphed data ""
'
' Need to give the user the option for scaling the
' horizontal data?
'
' Label the chart data series
' Draw a border around the graph
' Added the Title information at the top of the graph
'
'--------------------------------------------------------------------
' Round up to the nearest 100 to obtain the
' extents of the chart border
MaxX = (100 * Int(MaxX / 100)) * Xscale
MaxY = (100 * Int(MaxY / 100)) + 100
' Size the 'tick' and text
ticklength = 0.02 * (MaxX / Xscale)
If ticklength > 10 Then ticklength = 10
' Set the polyline width
MaxWidth = (MaxX / 200) / Xscale
' Set the layer for the border and ticks
'MakeSetLayer (BrdrLayName)
aspace.ActiveLayer = BrdrLayName
' Define the border of the chart
GraphStartPt(0) = 0#: GraphStartPt(1) = 0#: GraphStartPt(2) = 0#
GraphXEndPt(0) = MaxX: GraphXEndPt(1) = 0#: GraphXEndPt(2) = 0#
GraphYEndPt(0) = 0#: GraphYEndPt(1) = MaxY: GraphYEndPt(2) = 0#
' Horizontal Axis Line
Set GraphLineHor = aspace.AddLine(GraphStartPt, GraphXEndPt) ' need to change the color
With GraphLineHor
    .Color = 1
    .LineType = "BYLAYER"
End With
'Vertical Axis Line
Set GraphLineVer = aspace.AddLine(GraphStartPt, GraphYEndPt)
With GraphLineVer
    .Color = 1
    .LineType = "BYLAYER"
End With
' Set the current layer to "Text" for the labels
MakeSetLayer (TxtLayName)
' Label Horizontal Axis
TextPoint(0) = MaxX / 2
TextPoint(1) = -2.1 * ticklength * Xscale
TextPoint(2) = 0#
TextString = "HORIZONTAL SPAN"
Set TempText = aspace.AddText(TextString, TextPoint, ticklength * 1.5 * Xscale)
With TempText
    .Alignment = acAlignmentTopCenter
    .TextAlignmentPoint = TextPoint
    .Color = 2#
End With
' Label Vertical Axis
TextPoint(1) = MaxY / 2
TextPoint(0) = -2.1 * ticklength * Xscale
TextPoint(2) = 0#
TextString = "VERTICAL SPAN"
Set TempText = aspace.AddText(TextString, TextPoint, ticklength * 1.5 * Xscale)
With TempText
    .Rotation = pi() / 2
    .Alignment = acAlignmentBottomCenter
    .TextAlignmentPoint = TextPoint
    .Color = 2#
End With
' Place and label the tick marks and grid lines
' Draw ticks and lable for the horizontal axis
For i = 1 To MaxX / (100 * Xscale)
    MakeSetLayer (BrdrLayName)
    TickPtStart(0) = CDbl(i * Xscale * 100): TickPtStart(1) = 0#: TickPtStart(2) = 0#
    TickPtEnd(0) = CDbl(i * Xscale * 100): TickPtEnd(1) = (-1 * ticklength): TickPtEnd(2) = 0#
    Set TickLine = aspace.AddLine(TickPtStart, TickPtEnd)
    
    With TickLine
        .Color = 1#
        .LineType = "BYLAYER"
    End With
        
    ' Label the ticks
    MakeSetLayer (TxtLayName)
    TextString = CStr(i * 100)
    TickPtEnd(1) = (-1.1 * ticklength)
    Set TickLabel = aspace.AddText(TextString, TickPtEnd, ticklength * 0.8 * Xscale)
     
    With TickLabel
        .Alignment = acAlignmentTopCenter
        .TextAlignmentPoint = TickPtEnd
        .Color = 2#
    End With
    
    GridStart(0) = TickPtStart(0): GridStart(1) = TickPtStart(1): GridStart(2) = TickPtStart(2)
    GridEnd(0) = CDbl(i * Xscale * 100): GridEnd(1) = MaxY: GridEnd(2) = 0#
    Set GridLineVer = aspace.AddLine(GridStart, GridEnd)
    With GridLineVer
        .Color = 1#
        .LineType = "DOT"
    End With
          
Next i
' Draw the ticks for the vertical axis
For i = 1 To MaxY / 100
    MakeSetLayer (BrdrLayName)
    TickPtStart(1) = CDbl(i * 100): TickPtStart(0) = 0#: TickPtStart(2) = 0#
    TickPtEnd(1) = CDbl(i * 100): TickPtEnd(0) = (-1 * ticklength): TickPtEnd(2) = 0#
    Set TickLine = aspace.AddLine(TickPtStart, TickPtEnd)
    
    With TickLine
        .Color = 1#
        .LineType = "BYLAYER"
    End With
        
    ' Label the ticks
    MakeSetLayer (TxtLayName)
    TextString = CStr(i * 100)
    Set TickLabel = aspace.AddText(TextString, TickPtEnd, ticklength * 0.8 * Xscale)
     With TickLabel
        .Rotation = pi() / 2
        .Alignment = acAlignmentBottomCenter
        .TextAlignmentPoint = TickPtEnd
        .Color = 2#
    End With
    
    GridStart(0) = 0#: GridStart(1) = TickPtStart(1): GridStart(2) = 0#
    GridEnd(0) = MaxX: GridEnd(1) = CDbl(i * 100): GridEnd(2) = 0#
    Set GridLineHor = aspace.AddLine(GridStart, GridEnd)
    With GridLineHor
        .Color = 1#
        .LineType = "DOT"
    End With
Next i
' Draw the insulator swing graph
'=================================
' example of of creating a spline
'ReDim ptarr(0 To (UBound(lineData, 1) * 3) - 1) As Double
'Dim n
'For i = 1 To UBound(lineData, 1)
'    ptarr(n) = CDbl(lineData(i, 1)): ptarr(n + 1) = CDbl(lineData(i, 2)): ptarr(n + 2) = 0#
'    n = n + 3
'Next i
Dim startPt(0 To 2) As Double
Dim endPt(0 To 2) As Double
'startPt(0) = 0.5: startPt(1) = 0.5: startPt(2) = 0#
'endPt(0) = 0.5: endPt(1) = 0.5: endPt(2) = 0#
'Set oSpline = aspace.AddSpline(ptarr, startPt, endPt)
'=================================
endPt(2) = 0# ' Z coordinate is always zero
startPt(2) = 0#
Dim N
For j = 2 To numcols
    
    ' Create layer for each graph line
    
    ReDim PTARR(0 To (NumRows * 3) - 1) As Double
    PTARR(N) = CDbl(lineData(1, 1) * Xscale)
    PTARR(N + 1) = CDbl(lineData(1, j))
    PTARR(N + 2) = 0#
    N = N + 3
    'startPt(0) = lineData(1, 1): startPt(1) = lineData(1, j)
    
    For i = 1 To NumRows - 1
        endPt(0) = lineData(i + 1, 1) * Xscale: endPt(1) = lineData(i + 1, j)
        PTARR(N) = endPt(0)
        PTARR(N + 1) = endPt(1)
        PTARR(N + 2) = endPt(2)
        
        ' Draw as multiple line segments
        'If startPt(1) >= 0 Then
        '    Set ChartLine = aspace.AddLine(startPt, endPt)
        '    With ChartLine
        '        .Color = 3 + j
        '        .LineType = "BYLAYER"
        '    End With
        'End If
        'startPt(0) = endPt(0): startPt(1) = endPt(1)
        
        N = N + 3
        
    Next i
    
    LayerName = CStr(j - 1) + "-series"
    
    MakeSetLayer (LayerName)
    
    Set oLWPline = aspace.AddPolyline(PTARR)
    With oLWPline
        .Color = 3 + j
        .LineType = "BYLAYER"
        .ConstantWidth = MaxWidth
                
    End With
    
    N = 0
Next j
'' if you need to draw the closed spline then add this line:
'' oSpline.Closed=True
ZoomExtents
Set aspace = Nothing
Set adoc = Nothing
Set acad = Nothing
Application.ScreenUpdating = True
Worksheets(DataInput).Activate ' return to main screen
ErrorHandler:
    If Err.Number  0 Then
        'MsgBox Err.Description
    End If
    
End Sub