做一个DWG，从XLS，VBA，从xls的VBA编辑
我有一个：第一个
xls，列块名为att1，标记到attn，标记可以是大约15个att。列，在同一行，具有att值。最后一列设置订单号或为空，以插入块。同一行中的所有数据＜br＞第二个＜br＞dwt模板，模型空间为空＜br＞Adoc的块集合＜br＞用户的所有功能＜br＞在模型空间中填充一行块，宽度为纸张空间宽度，并有一条线将每个块与子块连接起来。＜br＞这是一种统一的电路，没有分支＜br＞除phat/project外的第四个分支。dwg＜br＞希望很清楚＜br＞第5次将dwg打印为pdf文件＜br＞6次打开pdf文件＜br＞用户将永远不会操作dwg，这是一个商业人士，没有ACAD技能
希望这是清楚的
或者至少我需要从xls看到xls VBA到dwg，而不是acad VBA到dwg
提前感谢
这是我心目中的一个项目，在XLS和DWT中都没有实现
我只是想知道这是否可能，以及XLS VBA到ACAD的第一步。
用户站当然会持有XLS，这是ACAD VBA的补充，ACAD，
提前谢谢。
**** Hidden Message ***** 我使用一些旧代码从Excel工作簿中包含的数据在ACAD中创建图形。
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.5need 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.Number0 Then
'MsgBox Err.Description
End If
End Sub
另外两种方法是使用lisp读取单个单元格值并查看getexel，从而获得excel。对于lsp，另一种替代方法是生成csv文件，然后再次使用lisp创建dwg。对我来说，使用lisp更舒服。
页:
[1]