智能图签

hh13123

    首先，感谢newer版主！
    之前每次做完设计，就图签的填写整理等，要耗费大量的时间，且很容易出错，在论坛上建议高手能写个智能图签程序，得到newer版主大力支持，准备亲自操刀，再次谢谢！
    说明：        这就是典型的目录结构
        工程名称 ——》 册 ——》 篇 ——》 节 ——》 DWG文件
     （文件夹）  （文件夹） （文件夹） （文件夹）   （文件）
        备注：当工程规模较小，DWG文件较少时，一般就简单的放置在一个目录内。
        

页码部分：
        希望能达到这种效果（鸿业市政道路工程管理），它用的是XML格式文件存储。（以附XML文件），每个工程在其跟目录存储一个XML文件。
        它可以自动搜索当前目录（XML文件所在），提取目录及文件，排序、生成此表。支持鼠标右键可以创建文件夹，添加文件，移除文件。（为通用性，创建文件夹等操作只是数据结构，并非真正在磁盘创建目录）
        但不支持鼠标拖动调整顺序。
一些想法：
        排序，如果设计者作图时已经创建这样一些目录，对一些结构明显的部分，譬如，第一章、第二章等可以通过字段排序。但DWG文件如果取名时没有明显的排序字段，程序无法确定其先后顺序，故，需考虑人工排序，即，用鼠标把文件拖到合适的位置，或者，右键在合适的位置添加文件。
        这里有个问题，人工添加文件的方式，容易产生遗漏，最好还是程序自动搜索该目录结构下所有的DWG文件，并列出，然后人工在表格里拖拽顺序，这样不容易产生遗漏。
        下表的结构成型，就能为页码提供基础了，但还有几个问题需完成，才能最终确定准确的页码。
        1、一个DWG文件里面，可能会有一张或者多张图，程序上可以考虑遍历图形，查找图框块的数量确定一个DWG文件有多少张图。同一个DWG文件内的页码顺序，可以考虑x增量或者y增量确定顺序。
        2、一定要避免刷新页码需逐一打开文件再存盘的问题。技术上我不知道该怎么实现，如果有难度，可否考虑页码形成一个交换文件，图框属性块与交换文件动态关联，不知那种更为容易实现。
        下面表格希望能增加一些字段。
        1、每篇，或者每节可能会有独立页码的情况，能否增加一个选项，页码延续还是重编。
        2、页码的字符提供选项，譬如，可以1，2...100，也可以A,b...Z，或者罗马数组等。
        3、提供构架关键字段排序选择项。
图名部分：一般图名就等于文件名。可提取当前文件名对图名属性块赋值，此赋值在作图过程中用命令按钮赋值，可能会有修改的情况发生，故，不要统一一起赋值。
目录部分：有了页码，图名，就容易形成Excel的目录表格，稍作编辑导入Cad目录表即可。
其余部分：由于每个工程图签的其他部分相对固定，故，作图时考虑外部引用即可，无需再做处理。XML附件：
图框附件：

csharp

现在的 CAD 已经有图纸集功能，和这个类似吧

使用“图纸集特性”选项，可以查看图纸集数据文件（DST）的信息，比如路径和文件名，还有包含与该图纸集相关联的图形文件的文件夹路径，以及任何与该图纸集关联的自定义特性。
以ABCProject图纸集为例
在图纸集管理器中，在“图纸列表”选项卡上，在“ABCProject”上单击右键，然后在快捷菜单上单击“特性”。
在“图纸集特性”对话框的“图纸创建”下，单击“图纸创建样板”。
“图纸创建样板”下列出的文件(ABC.dwt)是用于创建此图纸集中所有新图纸的默认样板。
图纸集中的所有图纸存储在一个或多个文件夹中。
在“图纸集特性”对话框的“图纸创建”下，单击“图纸存储位置”。
“图纸存储位置”下列出的文件夹是存储此图纸集中所有图纸的位置。默认情况下，您创建的所有新图纸也存储在此位置。
单击“确定”关闭“图纸集特性”对话框。
打开Windows资源管理器。
在Windows资源管理器中，浏览到图纸集管理器的“图纸存储位置”下列出的文件夹：MyDocuments\sucai\ViewSheetSet。注意，对于图纸集中的每个图纸（Plans、Elevations和FoundationPlan），都有相应的图形文件。
还要注意，图纸集中的每个图纸都已编号，但是相应的图形文件没有编号。
由于图纸编号是一个图纸特性，并不是图形文件名的一部分，因此可以使用图纸集管理器对图纸重新排序和重新编号，而不必重命名图形文件。
归档图纸集
在工程的关键阶段，可以创建整个图纸集的压缩归档。将自动包括相关的文件，例如，图纸集数据文件、外部参照和打印配置文件。
通过使用“修改归档设置”对话框，可以创建多个命名的归档设置并编辑它们的特性。通过在“修改归档设置”按纽中选择归档文件包类型，一个图纸集可以被归档为ZIP文件、EXE文件或者文件夹。可以在“修改归档设置”对话框中修改这些配置，比如修改归档文件包类型、文件格式和归档文件夹位置。如果想要保护归档的图纸集，通过“修改归档设置”对话框中选择“提示输入密码”复选框，可以设定一个密码。
使用向导创建图纸集
“创建图纸集”向导包含一系列指导你完成创建一个新图纸集过程的页面。可以选择从现有图形文件创建一个图纸集，或者使用现有的图纸集作为新的图纸集基础样板。
为使用“创建图纸集”向导将图形文件组织为一个图纸集，可以通过单击“文件”／“新建图纸集”访问它。
在“创建图纸集”向导的第一页，要选择创建一个图纸集的方法。可以从一个样例图纸集或者现有的图形文件创建一个图纸集。这个向导将指导你执行创建一个新的图纸集需要的所有步骤。一旦你创建了一个图纸集，就可以使用“图纸管理器”查看并修改这个图纸集。

hh13123

csharp 发表于 2014-9-4 07:28
现在的 CAD 已经有图纸集功能，和这个类似吧

使用“图纸集特性”选项，可以查看图纸集数据文件（DST）的 ...

图纸集没有页码功能，它能管理图纸，但没有图签功能！

newer

hh13123 发表于 2014-9-4 11:30
图纸集没有页码功能，它能管理图纸，但没有图签功能！

好大的项目

如果全做出来要考虑的很多了，不是一个小工具就能完成的。

咱们先做你说的那个较小的工程，比如一个专业的，图纸都在一个目录内，把这个目录内的图纸信息生成个图纸目录吧，这个图纸目录是个DWG文件，列出需要的信息。

你把图签和这个DWG的图纸目录图和图片一起贴上来下，可以在帖子里面看到图片，便于讨论。

csharp

既然有xml可以根据xml读出目录、文件名，DBX或Api的readDatabase就可以修改图签了，函数发布中有几个xml操作函数

XDSoft

csharp 发表于 2014-9-4 12:43
既然有xml可以根据xml读出目录、文件名，DBX或Api的readDatabase就可以修改图签了，函数发布中有几个xml操 ...

楼主要表达的意思好像和你正相反，设计过程中图经常变化，是根据图中图签的变化去生成图纸目录，是先有图纸，后有XML文件。

csharp

图纸变化在工程管理处理，处理后就更新了xml

csharp

lzh版主那个图库管理再扩展一点就可以了

hh13123

newer 发表于 2014-9-4 11:53
好大的项目

如果全做出来要考虑的很多了，不是一个小工具就能完成的。

劳版主费心了！这是目录贴图及目录和图框的DWG文件

hh13123

XDSoft 发表于 2014-9-4 14:00
楼主要表达的意思好像和你正相反，设计过程中图经常变化，是根据图中图签的变化去生成图纸目录，是先有图 ...

老大说得对，XML文件是的结果！

hh13123

昨晚看了看CAD的图集功能，ＣＡＤ自带一种类似宏的代码，叫Ｄiesel，好像和图集功能联系比较紧密，这种ＤＤiesel看介绍能动态更新属性块。但查了下diesel的函数，好像没几个！如果这个页码功能能建立在Cad自带图集的基础上，一方面可以减轻代码量，更为重要的是，就具有通用性了！

csharp

是 filed 吧，字段

hh13123

嗯，是的，以前没注意，不知道这个东东是什么版本开始出现的，好像有用，但它函数又没有几个，还不知道怎么应用呢

hh13123

这是我之前做一个工程过程中，用VBA代码凑的一个页码程序，边做边用，出错就修改下源代码，所以，代码不优化，没有容错能力，只是为了暂时完成功能！

Sub P_Num()
    'Const B_Name = "中铁A3图框"
    Const DrawingName = "图名"
    Dim Collection_Block_old As Collection
    Dim Collection_Block_srt As Collection
    '--------------------------------------------------------------------------------------------------
    '写页码
        Set Collection_Block_old = SertchBlockRef()                            '查找指定块，返回指定块的所有属性块集合（Collection）
        Set Collection_Block_srt = Sort_Collection(Collection_Block_old)       '把返回的属性块数组按升序排序再返回
        
       ' On Error GoTo A
        For i = Collection_Block_srt.Count To 1 Step -1                        '在排序后的集合里面查找当前图形的最大页码（Curent_Pags）
            If Collection_Block_srt.Item(i)(4) = "页码" Then
                Curent_Pags = Collection_Block_srt.Item(i)(5)
                Exit For
            End If
        Next i
        '-------------------------------------------------------------------
        '代入当前最大页码，取回到当前图形的累计页码总数，并将结果写入Text文件
        Prev_Pags = Get_PrevPags(Curent_Pags)
        '-------------------------------------------------------------------
        
        Call Set_Block_Str(Collection_Block_srt, Prev_Pags)                     '上一个的图纸数量+1即为此图开始的页码
        MsgBox ("页码已更新")
        Exit Sub
'A:      MsgBox ("不是本工程，无法工作！")
End Sub


'按块名查找，直到找完，带回所有属性块属性的数组
Function SertchBlockRef()

    Const BlockName = "中铁A3图框"
    Dim EntObj As AcadEntity
    Dim ins_Point()
    Dim attVars As Variant
    Dim arr_Pags(0 To 5)
    Dim Num_Page As Integer
    Dim blkRefObj As AcadBlockReference
    Dim rtnCol As New Collection
   
    On Error GoTo ErrTrap
    Num_Page = 0
    For Each EntObj In ThisDrawing.PaperSpace
       If StrComp(EntObj.ObjectName, "AcDbBlockReference", vbTextCompare) = 0 Then
          If StrComp(EntObj.Name, BlockName, vbTextCompare) = 0 Then
             Set blkRefObj = EntObj
             attVars = blkRefObj.GetAttributes
            
             For k = 0 To UBound(attVars)
             '--------------------------------------
             '定义数组
             '  0,Handle,1:x，2;y，3:z，4：块属性值，5：完整路径文件名
             'ReDim Preserve arr_Pags(0 To 5, Num_Page)
            
             '--------------------------------------
             '取属性块的坐标属性循环赋给数组(1 to 3)
             '把取得的坐标x，y，x赋值给数组


                tmp = attVars(k).InsertionPoint          '块插入点，ins_Point是数组，0：x，1：y，2：z
                For j = 1 To UBound(tmp) + 1
                    arr_Pags(j) = tmp(j - 1)
                Next j
             '坐标赋值结束
             '---------------------------------------
            
             '--------------------------------------
             '下面赋值 (句柄)，（块属性值）,（完整文件名）
                arr_Pags(0) = blkRefObj.Handle                 '句柄
                'arr_Pags(j) = attVars(k).TextString            '块属性值
                arr_Pags(j) = attVars(k).TagString            '块属性值
             '取属性结束
             '--------------------------------------
                If arr_Pags(j) = "页码" Then
                    Num_Page = Num_Page + 1
                    arr_Pags(j + 1) = Num_Page
                Else
                    arr_Pags(j + 1) = ""
                End If
             rtnCol.Add arr_Pags             'Num_Page = Num_Page + 1
             Next k

          End If
       End If
    Next
    Set SertchBlockRef = rtnCol
    Set EntObj = Nothing
    Set rtnCol = Nothing
    Exit Function
ErrTrap:
    If Not (EntObj Is Nothing) Then Set EntObj = Nothing
    On Error GoTo 0
End Function

Function Sort_Collection(Collection_Block)
    Dim Collection_temp As Collection
   
    For i = 1 To Collection_Block.Count
        For j = i + 1 To Collection_Block.Count
            If Collection_Block.Item(j)(1) < Collection_Block.Item(i)(1) Then
                Temp = Collection_Block.Item(j)
                Collection_Block.Remove (j)
                Collection_Block.Add Item:=Collection_Block.Item(i), after:=i
                Collection_Block.Remove (i)
                Collection_Block.Add Item:=Temp, before:=i
            End If
        Next j
    Next i
    Set Sort_Collection = Collection_Block
   
End Function

Function Set_Block_Str(Collection_Block_srt, Prev_Pags)

    Dim RetVal As AcadBlockReference
    On Error GoTo ErrTrap
    For i = 1 To Collection_Block_srt.Count                                                     '修改图纸中属性块的值
   
        Set RetVal = ActiveDocument.HandleToObject(Collection_Block_srt.Item(i)(0))              '(0,i)为arr_Block数组的句柄位置
        attVars = RetVal.GetAttributes
        For j = LBound(attVars) To UBound(attVars)
            Select Case attVars(j).TagString
                Case "页码"
                    attVars(j).TextString = Collection_Block_srt.Item(i)(5) + Prev_Pags          '页码从1开始，数组从0开始，所有+1，再加上部分的页数(Last_Pags)
                    i = i + 1
                Case "图名"
                    attVars(j).TextString = Split((Split(ThisDrawing.Name, " ")(1)), ".")(0)
                    i = i + 1
            End Select

        Next j
            Set RetVal = Nothing
        i = i - 1
    Next i
ErrTrap:
    If Not (RetVal Is Nothing) Then Set RetVal = Nothing
    On Error GoTo 0
End Function

Function ReadSource(Curent_Pags)
  
'声明Excel相关
    Const WorkRang = "目录"
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
   
    RoadName = Right(ThisDrawing.Path, Len(ThisDrawing.Path) - InStrRev(ThisDrawing.Path, "\"))
    FileName = Left(ThisDrawing.Name, InStrRev(ThisDrawing.Name, ".") - 1)
    ExcelPath = Left((Left(ThisDrawing.Path, InStrRev(ThisDrawing.Path, "\") - 1)), InStrRev((Left(ThisDrawing.Path, InStrRev(ThisDrawing.Path, "\") - 1)), "\")) & "Z 数据文件（不打印）\" & "目录-数据.xlsx"
      
    Set xlApp = New Excel.Application
'获取指定excel文件
    Set xlBook = xlApp.Workbooks.Open(ExcelPath)
  
    Dim sheet As Excel.Worksheet
'获取指定sheet
    Set sheet = xlBook.Worksheets(1)
      
    For j = 1 To sheet.UsedRange.Rows.Count
        For i = 1 To sheet.UsedRange.Columns.Count
            If sheet.Cells(j, i).Value = RoadName Then
                If sheet.Cells(j, i).MergeCells Then
                    myCow = sheet.Cells(j, i).MergeArea.Rows.Count
                    i = i + 1
                    For k = 0 To myCow
                        If sheet.Cells(j + k, i).Value = FileName Then
                            lastPags = sheet.Cells(j + k - 1, i + 2).Value
                            If lastPags = "页数" Then
                                lastPags = sheet.Cells(j + k - 3, i + 2).Value
                                If lastPags = "" Then lastPags = 0
                                sheet.Cells(j + k, i + 2).Value = Curent_Pags
                            End If
                            Exit For
                        End If
                    Next k
                End If
            End If
            If lastPags <> "" Then Exit For
        Next i
        If lastPags <> "" Then Exit For
    Next j
    ReadSource = lastPags
    xlBook.Close Savechanges:=True
End Function

'该函数代入参数为一维数组(arr(0))，即'章，节，图名，页码组成的整串字符串的数组，注意是整串，数组的上标同时为0
'传入本图页数，填写Text文件页数项
'程序获取图纸相关信息后生成参数数组，代入本函数，完成排序，剔除重复，在写入文本文件
'返回上一个图纸的页码
Function Get_PrevPags(Curent_Pags)

    Dim arr()
    Dim arr_text(0)
   
    图名 = Left(ThisDrawing.Name, (InStr(ThisDrawing.Name, ".") - 1))
    '图名 = (Split(Split(mypath, "\")(UBound(Split(mypath, "\"))), ".")(0))
    章 = Split(ThisDrawing.Path, "\")((UBound(Split(ThisDrawing.Path, "\")) - 1))
    节 = Split(ThisDrawing.Path, "\")((UBound(Split(ThisDrawing.Path, "\"))))
    arr_text(0) = 章 & "," & 节 & "," & 图名 & "," & Curent_Pags & ","
    textFilePath = Left(ThisDrawing.Path, (InStrRev(Left(ThisDrawing.Path, (InStrRev(ThisDrawing.Path, "\") - 1)), "\"))) & "Z 数据文件（不打印）\文件页码.csv"
    '---------------------------------------------------------------
    '只读方式打开（文件页码）Text文件，读入数组，关闭文件

    Open textFilePath For Input As #1
    i = 0
    Do While Not EOF(1)             ' 循环至文件尾。
        Line Input #1, TextLine     ' 读入一行数据并将其赋予某变量。
        ReDim Preserve arr(i)
        arr(i) = Trim(TextLine)
        i = i + 1
    Loop
    Close #1

    '追加函数代入的参数数组,查找是否存在，有就替换旧的，没有就追加，比较条件不含页码，页数
    '--------------------------------------------------------------------------------------------------
    '空文件处理
    '-------------------------------------------------------------------
    If i = 0 Then  'i=0 为只读方式打开文件时读取的行数，0表示空文件
        Get_PrevPags = 0
        arr1 = Split(arr_text(0), ",")
        arr1(UBound(arr1)) = Get_PrevPags + Curent_Pags
        arr1(UBound(arr1) - 1) = Curent_Pags
        For j = LBound(arr1) To UBound(arr1)
            arrStr = arrStr & "," & arr1(j)
        Next j
        ReDim Preserve arr(0)
        arr(i) = Right(arrStr, Len(arrStr) - 1)
        GoTo CreatTextFile
    End If
    '空文件处理结束
    '--------------------------------------------------------------------
    'a = Left(arr_text(0), (InStrRev((Left(arr_text(0), InStrRev(arr_text(0), ",") - 1)), ",") - 1))
    A = Split(Split(arr_text(0), ",")(0), " ")(1) & "," & Split(arr_text(0), ",")(1) & "," & Split(Split(arr_text(0), ",")(2), " ")(1)
        For i = 0 To UBound(arr)
           ' b = Left(arr(i), (InStrRev((Left(arr(i), InStrRev(arr(i), ",") - 1)), ",") - 1))
            b = Split(Split(arr(i), ",")(0), " ")(1) & "," & Split(arr(i), ",")(1) & "," & Split(Split(arr(i), ",")(2), " ")(1)
            If A = b Then
                arr(i) = arr_text(0)
                Temp = True
                Exit For
            End If
        Next i
    'End If
        If Not Temp Then
            ReDim Preserve arr(UBound(arr) + 1)
            arr(UBound(arr)) = arr_text(0)
        End If
    '---------------------------------------------------------------------------------------------------
    '读入文件内容结束
    '-----------------------------------------------------------------
    '下面是删除数组里面重复的数据(New)

    For i = 0 To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i) <> "" Then
                aa = Split(Split(arr(i), ",")(0), " ")(1) & "," & Split(arr(i), ",")(1) & "," & Split(Split(arr(i), ",")(2), " ")(1)
            Else
                aa = ""
            End If
            If arr(j) <> "" Then
                bb = Split(Split(arr(j), ",")(0), " ")(1) & "," & Split(arr(j), ",")(1) & "," & Split(Split(arr(j), ",")(2), " ")(1)
            Else
                bb = ""
            End If
            If aa = bb Then arr(j) = ""
        Next
    Next
    Dim tmp_arr()
    j = 0
    For i = 0 To UBound(arr)
        If arr(i) <> "" Then
            ReDim Preserve tmp_arr(j)
            tmp_arr(j) = arr(i)
            j = j + 1
        End If
    Next
    arr = tmp_arr()
   
    '删除结束
    '-----------------------------------------------------------------
    '下面是第一次排序，按“篇”
    For i = 0 To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
        '----------------------------------------
            If Asc(arr(i)) > Asc(arr(j)) Then
                Temp = arr(j)
                arr(j) = arr(i)
                arr(i) = Temp
            End If
        '-----------------------------------------
        Next j
    Next i
    '第一次排序结束
    '-----------------------------------------------------------------
    '下面是按“章”排序，保持章的排序不乱
    i = 0
    Do While i < UBound(arr)
        Do While Split(arr(i), ",")(0) = Split(arr(i + 1), ",")(0)
            j = i + 1
            Do While Split(arr(j), ",")(0) = Split(arr(j - 1), ",")(0)
                If CInt(Split(Split(arr(i), ",")(1), " ")(0)) > CInt(Split(Split(arr(j), ",")(1), " ")(0)) Then
                'If CInt(Split(Split(arr(i), ",")(1), "-")(1)) > CInt(Split(Split(arr(j), ",")(1), "-")(1)) Then
                'If CInt(Split((Split(arr(i), ",")(2)), " ")(0)) > CInt(Split((Split(arr(j), ",")(2)), " ")(0)) Then
                    Temp = arr(j)
                    arr(j) = arr(i)
                    arr(i) = Temp
                End If
                j = j + 1
                If j > UBound(arr) Then Exit Do
            Loop
            i = i + 1
            If i = UBound(arr) Then Exit Do
        Loop
        i = i + 1
    Loop
    '章的排序结束
    '----------------------------------------------------------------------
    '下面是按“节”排序，保持章的排序不乱
    i = 0
    Do While i < UBound(arr)
        Do While Split(arr(i), ",")(1) = Split(arr(i + 1), ",")(1)
            j = i + 1
            Do While Split(arr(j), ",")(1) = Split(arr(j - 1), ",")(1)
                If CInt(Split((Split(arr(i), ",")(2)), " ")(0)) > CInt(Split((Split(arr(j), ",")(2)), " ")(0)) Then
                    Temp = arr(j)
                    arr(j) = arr(i)
                    arr(i) = Temp
                End If
                j = j + 1
                If j > UBound(arr) Then Exit Do
            Loop
            i = i + 1
            If i = UBound(arr) Then Exit Do
        Loop
        i = i + 1
    Loop
    '节的排序结束
    '-----------------------------------------------------------------
    '---------------------------------------------------------------------
   
    '查找本图前一图纸的页数，填写本图代入的页数(Curent_Pags)
    arrStr = ""
    For i = 0 To UBound(arr)
        'a = Left(arr_text(0), (InStrRev((Left(arr_text(0), InStrRev(arr_text(0), ",") - 1)), ",") - 1))
        'b = Left(arr(i), (InStrRev((Left(arr(i), InStrRev(arr(i), ",") - 1)), ",") - 1))
        
        A = Split(Split(arr_text(0), ",")(0), " ")(1) & "," & Split(arr_text(0), ",")(1) & "," & Split(Split(arr_text(0), ",")(2), " ")(1)
        b = Split(Split(arr(i), ",")(0), " ")(1) & "," & Split(arr(i), ",")(1) & "," & Split(Split(arr(i), ",")(2), " ")(1)
        If b = A Then
            If i <> 0 Then
                Get_PrevPags = Split(arr(i - 1), ",")(UBound(Split(arr(i - 1), ",")))
            Else
                Get_PrevPags = 0
            End If
            arr1 = Split(arr(i), ",")
            arr1(UBound(arr1)) = Get_PrevPags + Curent_Pags
            arr1(UBound(arr1) - 1) = Curent_Pags
            For j = LBound(arr1) To UBound(arr1)
                arrStr = arrStr & "," & arr1(j)
            Next j
            arr(i) = Right(arrStr, Len(arrStr) - 1)
            Exit For
        End If
    Next i
    '------------------------------------------------------------------------
    '下面把数组写入文件
    '---------------------------------------------------------------
    '写入方式打开（文件页码）Text文件，读入数组，关闭文件
CreatTextFile:
    Open textFilePath For Output As #1
        For i = LBound(arr) To UBound(arr)
            Print #1, arr(i)
        Next i
    Close #1
    '--------------------------------------------------------------------------------------------------
   
End Function

XDSoft

hh13123 发表于 2014-9-5 15:25
劳版主费心了！这是目录贴图及目录和图框的DWG文件

编号，图号在哪呢？