mռ

这是一个管线采集资料时管孔占用情况整理记录的工具,它可以通过操作AUTOCAD图纸进行图纸信息的操作.

Attribute VB_Name = "m占孔情况"


Sub p占孔情况(s导数形式 As String)  ''' 在本表上生产数据 partsdata checkout
Dim d使用期限 As Date: d使用期限 = #6/1/2005#
If d使用期限 <= Date Then End   'MsgBox " ", , "SIFANG ART":
'On Error Resume Next
'On Error GoTo HandleErr
    Dim shapes As Object
    Dim objEntity As Object
Dim sCurrName As String
Dim aInsertionPoint(0 To 2), i占孔标签列表点(0 To 2), i人井定位点(0 To 2) As Double
Dim vCurrInsertionPoint As Variant
Dim vCurrRotation As Variant
    Dim textObj圈定提示 As Object
    Dim s圈定提示 As String
    
    Dim Max As Long
    Dim Min As Long
    Dim NoOfIndices As Long
    Dim Header As Boolean
    Dim iRowNum, i记录指针, i部件数目指针 As Long
    Dim aryTableData As Variant
    Dim iCount As Long
    Dim ary部件ID(1 To 10000) As String
    
    Dim s占孔类别标志 As String

Dim s部件ID, s代号, s编号, s类别, s名称 As String
Dim s程式, s单位, s数量, s状态, s形式9 As String
Dim s局所10, s机楼11, s测量室12, s交接区13, s线类14 As String
Dim s线号15, s线序16, s地址17, s坐标, s文档编号19 As String
Dim s竣工日期, s归档日期, s修改日期22, s产权人23, s建造人24, s扩展栏 As String
Dim i人井定位序号 As Long
    i人井定位序号 = Val(frm管孔布置器.txt人井定位序号.Value)


s占孔类别标志 = frm管孔布置器.lbl占孔类别标志.Caption
If frm管孔布置器.lbl占孔类别标志.Caption = "" Then s占孔类别标志 = " "

d修改日期 = Date

'''''''''''''''''''''''''''''''''''''
    Set objAcad = Nothing
    Set objAcad = GetObject(, "AutoCAD.Application")
    If Err <> 0 Then
        'Set objAcad = CreateObject("AutoCAD.Application") '新建文件
        MsgBox "Open the drawing file first and then rexecute!(请首先打开图纸文件,然后进行数据提取.)"
        Exit Sub
    End If
    
    Set objAcadPrf = objAcad.preferences
   ' If objAcadPrf.DisplayScreenMenu = False Then objAcadPrf.DisplayScreenMenu = True
    'objAcad.Visible = False ' True
    Set objAcadDoc = objAcad.ActiveDocument
    Set Mspace = objAcadDoc.ModelSpace
    Set textObj圈定提示 = objAcadDoc.ModelSpace
    Dim circleObj As Object
'''''''''''''''''''''''''''''''''''''

    iRowNum = 1
    i记录指针 = 1
    i部件数目指针 = 1
    Header = False
            s产权人23地片信息 = frm管孔布置器.cbb地片信息.Text
            s机楼11机楼信息 = frm管孔布置器.cbb机楼信息.Text
            s文档编号19人井名称 = frm管孔布置器.cbb人井名称.Text
            s形式9占孔号码 = frm管孔布置器.txt占孔号码.Text
            s测量室12站点信 = frm管孔布置器.cbb站点信息.Text '测量室
            s交接区13对象名称 = frm管孔布置器.cbb对象名称.Text
            s线序16线序信息 = frm管孔布置器.txt线序信息.Text
            s地址17线缆程式 = frm管孔布置器.txt线缆程式.Text


Select Case s导数形式
    Case "人井定位"
        i人井定位点(0) = 150# + i人井定位序号 * i图纸距离: i人井定位点(1) = 190#: i人井定位点(2) = 0
        objAcad.ZoomCenter i人井定位点, 250 'XX
    Case "人井填名"
    i占孔标签列表点(0) = 150# + i人井定位序号 * i图纸距离: i占孔标签列表点(1) = 160#: i占孔标签列表点(2) = 0
    Set circleObj = objAcad.ModelSpace.AddCircle(i占孔标签列表点, 20)
    Set textObj圈定提示 = Mspace.AddText(s文档编号19人井名称, i占孔标签列表点, 5)
    textObj圈定提示.Alignment = acAlignmentMiddle 'acAlignmentCenter
    Case Else
'MsgBox "kk"
    i占孔标签列表点(0) = 5# + i人井定位序号 * i图纸距离: i占孔标签列表点(1) = -100#: i占孔标签列表点(2) = 0
    
                            i占孔标签列表点(0) = 11# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText("人井名称", i占孔标签列表点, 5)
                            i占孔标签列表点(0) = 51# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText("占孔情况", i占孔标签列表点, 5)
                            textObj圈定提示.Layer = "管孔层"
                            i占孔标签列表点(0) = 81# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText("局站名称", i占孔标签列表点, 5)
                            i占孔标签列表点(0) = 121# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText("配区名称", i占孔标签列表点, 5)
                            i占孔标签列表点(0) = 161# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText("起止线序", i占孔标签列表点, 5)
                            i占孔标签列表点(0) = 231# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText("缆线程式", i占孔标签列表点, 5)
                            i占孔标签列表点(0) = 281# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText("机楼", i占孔标签列表点, 5)
                            i占孔标签列表点(0) = 331# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText("地片", i占孔标签列表点, 5)
                            
                            i记录指针 = i记录指针 + 1
                            i占孔标签列表点(0) = 5# + i人井定位序号 * i图纸距离: i占孔标签列表点(1) = -100 + i记录指针 * (-7): i占孔标签列表点(2) = 0
                          
    For Each objEntity In Mspace
        i部件数目指针 = i部件数目指针 + 1
        With objEntity
            If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
                If .HasAttributes Then
                    ''' Cells(iRowNum, 1).Value = objEntity.insertionPoint ''' 列出属性块的插入点
                    ''' Cells(iRowNum, 1).Value = objEntity.Name ''' 列出属性块的名称,可以按照名称筛选
                    sCurrName = .Name
                    sCurrID = .Handle
                    vCurrInsertionPoint = .insertionPoint
                    vCurrRotation = .Rotation
                    aryTableData = .GetAttributes ' import
                
            s部件ID = aryTableData(0).textString
            s代号 = aryTableData(1).textString
            s编号 = aryTableData(2).textString
            s类别 = aryTableData(3).textString
            s名称 = aryTableData(4).textString
            s程式 = aryTableData(5).textString
            s单位 = aryTableData(6).textString
            s数量 = aryTableData(7).textString
            s状态 = aryTableData(8).textString
            s形式9 = aryTableData(9).textString
            s局所10 = aryTableData(10).textString
            s机楼11 = aryTableData(11).textString
            s测量室12 = aryTableData(12).textString
            s交接区13 = aryTableData(13).textString
            s线类14 = aryTableData(14).textString
            s线号15 = aryTableData(15).textString
            s线序16 = aryTableData(16).textString
            s地址17 = aryTableData(17).textString
            s坐标 = aryTableData(18).textString
            s文档编号19 = aryTableData(19).textString
            s竣工日期 = aryTableData(20).textString
            s归档日期 = aryTableData(21).textString
            s修改日期22 = aryTableData(22).textString
            s产权人23 = aryTableData(23).textString
            s建造人24 = aryTableData(24).textString
            s扩展栏 = aryTableData(25).textString
            
                            'Debug.Print i部件数目指针 & objEntity.EntityName & s线号15

                    '''''''''''''''''
                    '''导入占用
                    Select Case s导数形式
                    Case "导入占用"

                    If s机楼11机楼信息 = s机楼11 And s文档编号19人井名称 = s文档编号19 _
                         And s形式9占孔号码 = s形式9 Then
                         MsgBox "导入占用>> " & s文档编号19人井名称 & s形式9占孔号码 & "对应" & s形式9

                        If s测量室12站点信 <> "" Then aryTableData(12).textString = s测量室12站点信
                        If s交接区13对象名称 <> "" Then aryTableData(13).textString = s交接区13对象名称
                        aryTableData(15).textString = s占孔类别标志 ''●＃
                        If s线序16线序信息 <> "" Then aryTableData(16).textString = s线序16线序信息
                        If s地址17线缆程式 <> "" Then aryTableData(17).textString = s地址17线缆程式
                    Else
                       ' MsgBox "请确定: 机楼, 人井名, 占孔号码"
                        'Exit Sub
                    End If
                    Case "导出占用"
                     '''''''''''''''''
                        '''无效部件的圈定
                        If Left(s线号15, 1) = "●" And s机楼11机楼信息 = s机楼11 And s文档编号19人井名称 = s文档编号19 Then
                            ''' 用圆圈圈定
                            'Set circleObj = ThisDrawing.ModelSpace.AddCircle(vCurrInsertionPoint, 5)
                            'circleObj.Layer = "Layer1"
                            'circleObj.color = 30
                            ''' 用圆圈圈定
                           ' Set circleObj = ThisDrawing.ModelSpace.AddLine(vCurrInsertionPoint, 5)
                            'circleObj.Layer = "Layer1"                            'circleObj.Lineweight = acLnWt100
                            
                            ''' 用文字圈定
                            s圈定提示 = s形式9 & s测量室12 & s交接区13 & s线序16 & s地址17
                            i占孔标签列表点(0) = 11# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText(s文档编号19, i占孔标签列表点, 5)
                            i占孔标签列表点(0) = 61# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText(s形式9, i占孔标签列表点, 5)
                            textObj圈定提示.Layer = "管孔层"
                            i占孔标签列表点(0) = 81# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText(s测量室12, i占孔标签列表点, 5)
                            i占孔标签列表点(0) = 121# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText(s交接区13, i占孔标签列表点, 5)
                            i占孔标签列表点(0) = 161# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText(s线序16, i占孔标签列表点, 5)
                            i占孔标签列表点(0) = 231# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText(s地址17, i占孔标签列表点, 5)
                            i占孔标签列表点(0) = 281# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText(s机楼11, i占孔标签列表点, 5)
                            i占孔标签列表点(0) = 331# + i人井定位序号 * i图纸距离
                            Set textObj圈定提示 = Mspace.AddText(s产权人23, i占孔标签列表点, 5)
                            i记录指针 = i记录指针 + 1
                            i占孔标签列表点(0) = 5# + i人井定位序号 * i图纸距离: i占孔标签列表点(1) = -100 + i记录指针 * (-7): i占孔标签列表点(2) = 0
                        MsgBox "ll'" & i记录指针
                        End If
                        
                    End Select
                    Header = True
                End If
            End If
        End With
        '''减轻负载
      '  i记录指针 = i记录指针 + 1
      '  If i记录指针 = 10000 Then i记录指针 = 1: Set objAcad = Nothing: Set objExcel = Nothing
        
    Next objEntity
    
    i记录指针 = i记录指针 - 2
    If i记录指针 > 0 Then
        MsgBox "当前图纸的新管孔占用数量为: " & i记录指针 & " 个. ", vbInformation, myTitle
    Else
       ' MsgBox "No attributes found in the current drawing(当前图纸没有发现有效数据)" & i记录指针 & " 个. ", vbInformation, myTitle
    End If
    


End Select
'''''

    Set objAcad = Nothing
    
HandleErr:
    'MsgBox "出现错误" & Err.Number & " (" & Err.Description & ") from " & _
            Err.Source, vbCritical, conDemoName
End Sub


Private Sub Auto_Close()
    Set objExcelsheet = Nothing
End Sub