[编程交流] 插入层'；Dr中的列表

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 MTxt  As 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 DimObj  As 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