'全自动生成图纸目录
'   图框可以是不同的，但必须包含有相同的关键字(比如：GS_A2和GS_A1,他们都是图纸中使用的结构图框，含有相同的关键字GS_)
'   图框的排放顺序是从上到下从左到右
Sub AutoTZML()
    Dim S1 As String
    'On Error Resume Next
    S1 = InputBox("图库块文件名或文件名中的关键字", "田草CAD工具箱")
    If S1 = "" Then Exit Sub '用户选择了取消
    
    ZoomAll
    
    Dim I As Integer
    Dim BList() As AcadEntity
    Dim E As AcadEntity
    Dim B As AcadBlockReference
    '将图中所以图框参照块添加到选择集中
    For Each E In ThisDrawing.ModelSpace
        If E.ObjectName = "AcDbBlockReference" Then
            Set B = E
            Prompt B.name & vbCrLf
            If InStr(B.name, S1) > 0 Then
                ReDim Preserve BList(I)
                Set BList(I) = E
                I = I + 1
            End If
        End If
    Next
    If UBound(BList) > 1 Then
        BlockPaiXu BList
    Else
        Prompt "图中未发现图块名称或名称中包含" & S1 & "关键字的图块"
        Exit Sub
    End If
    
    Dim N As Integer
    N = UBound(BList)
    Dim Pmin As Variant, Pmax As Variant
    Dim TempP(2)  As Double
    Dim P1 As Variant, P2 As Variant
    Dim xScale As Double '图框的缩放倍数
    
    Dim T() As String
    ReDim T(N)
    Dim SSet As AcadSelectionSet
    Set SSet = CreateSelectionSet("XXXXX")
    Dim M As Long
    For I = 0 To N
        Set B = BList(I)
        B.GetBoundingBox Pmin, Pmax
        xScale = B.XScaleFactor
        TempP(0) = Pmax(0):                     TempP(1) = Pmin(1):                     TempP(2) = 0
        P1 = TempP: P2 = TempP
        P1(0) = TempP(0) - 10600 * xScale:      P1(1) = TempP(1) + 1000 * xScale:       P1(2) = 0
        P2(0) = TempP(0) - 5200 * xScale:       P2(1) = TempP(1) + 3400 * xScale:       P1(2) = 0

        SSet.Select acSelectionSetCrossing, P1, P2
        
        For M = 0 To SSet.Count - 1
            If SSet.item(M).ObjectName = "AcDbText" Or SSet.item(M).ObjectName = "AcDbMText" Then '多行文字和单行文字
                T(I) = T(I) & ";" & SSet.item(M).textString
            ElseIf SSet.item(M).ObjectName = "TDbText" Then '天正的单行文字
                T(I) = T(I) & ";" & SSet.item(M).text
            End If
        Next
        T(I) = Right(T(I), Len(T(I)) - 1)
        SSet.Clear
    Next
    
    Dim S2 As String
    S2 = InputBox("输入图纸编号的前缀", "田草CAD工具箱")
    If S2 = "" Then Exit Sub '用户选择了取消
    Dim BH() As String
    ReDim BH(N)
    For I = 0 To N
        BH(I) = S2 & Format(I + 1, "00") & "/" & Format(N + 1, "00")
    Next I
    
    '创建匿名块。
    Dim TZML  As AcadBlock
    Set TZML = ThisDrawing.Blocks.Add(Point3D(0, 0, 0), "*J")

    Dim J As Integer
    Dim XH As AcadText
    With TZML
        For J = 0 To N + 1               'n行需要n+1条线。
            .AddLine Point3D(0, -500 * J, 0), Point3D(12000, -500 * J, 0)
        Next J
        '绘制竖向分割线
        .AddLine Point3D(0, 0, 0), Point3D(0, -500 * I, 0)
        .AddLine Point3D(1000, 0, 0), Point3D(1000, -500 * I, 0)
        .AddLine Point3D(10000, 0, 0), Point3D(10000, -500 * I, 0)
        .AddLine Point3D(12000, 0, 0), Point3D(12000, -500 * I, 0)
         '添加序号
        For J = 0 To N
            Set XH = .AddText(J + 1, Point3D(500, -500 * J - 250, 0), 300)
            XH.Alignment = acAlignmentMiddleCenter
            XH.Move Point3D(0, 0, 0), Point3D(500, -500 * J - 250, 0)
            Set XH = .AddText(T(J), Point3D(1500, -500 * J - 250, 0), 300)
            XH.Alignment = acAlignmentMiddleLeft
            XH.Move Point3D(0, 0, 0), Point3D(1500, -500 * J - 250, 0)
            Set XH = .AddText(BH(J), Point3D(10500, -500 * J - 250, 0), 300)
            XH.Alignment = acAlignmentMiddleLeft
            XH.Move Point3D(0, 0, 0), Point3D(10500, -500 * J - 250, 0)
        Next J
   End With
   'TZML.Explodable = False
    Dim P As Variant
    ThisDrawing.Utility.InitializeUserInput 1, ""
    P = ThisDrawing.Utility.GetPoint(, "图纸目录插入点")
    ThisDrawing.ModelSpace.InsertBlock P, TZML.name, 1, 1, 1, 0
    End
End Sub