插入层'；Dr中的列表
大家好，不久前，我编写了一些VBA代码，将图层列表插入绘图区域。它在每个层中绘制一条线，旁边放置一个文本，数据字段链接到该线的层。可以给我一个Lisp版本的吗？我试着用我有限的Lisp知识和投降。。。
这是VBA代码。。。
Public Sub LAYERLIST()
On Error Resume Next
Dim TextStr As String
Dim Lay As AcadLayer
Dim MTxt As AcadMText
Dim SP(0 To 2), EP(0 To 2), Width As Double
Dim n As Double
Dim LayName As String
Dim lineObj As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
Dim TxtInsertPoint(0 To 2) As Double
Dim IPoint(0 To 2) As Double
Dim VarPoint As Variant
Dim LayID As String
Dim m As Integer
Dim Counter As Integer
Dim TotalLayCount As Integer
Dim RowCount As Integer
Dim ColumnIndex As Integer
Dim TextId As String
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item("0")
TotalLayCount = ThisDrawing.Layers.Count
Width = 0
VarPoint = ThisDrawing.Utility.GetPoint(IPoint, "Select a Point:")
If Err Then End
m = 0
Counter = 0
RowCount = InputBox("There are " & TotalLayCount & " layers in this drawing." & vbCrLf & "Enter Number of Rows in the layer list:", "Enter Number of Rows")
For Each Lay In ThisDrawing.Layers
Counter = Counter + 1
If Counter > RowCount Then
ColumnIndex = ColumnIndex + 1
Counter = 0
n = 0
End If
n = n + 8
startPoint(0) = VarPoint(0) + (ColumnIndex * 70)
startPoint(1) = VarPoint(1) - n
startPoint(2) = VarPoint(2)
endPoint(0) = VarPoint(0) + 25 + (ColumnIndex * 70)
endPoint(1) = VarPoint(1) - n
endPoint(2) = VarPoint(2)
ThisDrawing.ActiveLayer = Lay
LayID = Lay.ObjectID
Set lineObj = ThisDrawing.ActiveLayout.Block.AddLine(startPoint, endPoint)
TextId = lineObj.ObjectID
TextStr = "%<\AcObjProp Object(" & TextId & ").Layer>%"
TxtInsertPoint(0) = VarPoint(0) + (ColumnIndex * 70) + 30
TxtInsertPoint(1) = 2 + (VarPoint(1) - n)
TxtInsertPoint(2) = VarPoint(2)
Set MTxt = ThisDrawing.ModelSpace.AddMText(TxtInsertPoint, Width, TextStr)
MTxt.Height = 2
MTxt.AttachmentPoint = acAttachmentPointMiddleLeft
ZoomExtents
Next
Update
ZoomExtents
MsgBox "Done..."
End Sub
Public Sub TXTLIST()
Dim MTxtAs AcadMText
Dim TxtStyle As AcadTextStyle
Dim startPoint(0 To 2) As Double
Dim VarPoint As Variant
Dim n As Integer
Dim Str As String
Dim Width As Double
VarPoint = ThisDrawing.Utility.GetPoint(, "Select a Point:")
n = 0
For Each TxtStyle In ThisDrawing.TextStyles
If Not TxtStyle.Name = "" Then
ThisDrawing.ActiveTextStyle = TxtStyle
n = n + 1
startPoint(0) = VarPoint(0)
startPoint(1) = VarPoint(1) + (n + 1)
startPoint(2) = VarPoint(2)
Str = TxtStyle.Name
Width = 0
Set MTxt = ThisDrawing.ModelSpace.AddMText(startPoint, Width, Str)
MTxt.AttachmentPoint = acAttachmentPointMiddleLeft
MTxt.Height = 1
End If
Next
Update
MsgBox "Done..."
End Sub
Public Sub DIMLIST()
Dim DimObjAs AcadDimAligned
Dim DimStyle As AcadDimStyle
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
Dim TxtPosition(0 To 2) As Double
Dim VarPoint As Variant
Dim n As Integer
VarPoint = ThisDrawing.Utility.GetPoint(, "Select a Point:")
n = 0
For Each DimStyle In ThisDrawing.DimStyles
If Not DimStyle.Name = "" Then
ThisDrawing.ActiveDimStyle = DimStyle
n = n + 4
startPoint(0) = VarPoint(0)
startPoint(1) = VarPoint(1) + (n + 1)
startPoint(2) = VarPoint(2)
endPoint(0) = VarPoint(0) + 1
endPoint(1) = VarPoint(1) + (n + 1)
endPoint(2) = VarPoint(2)
TxtPosition(0) = VarPoint(0) + (n + 0.5)
TxtPosition(1) = VarPoint(1) + (n + 2)
TxtPosition(2) = VarPoint(2)
Set DimObj = ThisDrawing.ModelSpace.AddDimAligned(startPoint, endPoint, TxtPosition)
End If
Next
Update
MsgBox "Done..."
End Sub
页:
[1]