Attribute VB_Name = "m占孔情況"


Sub p占孔情況(s導(dǎo)數(shù)形式 As String)  ''' 在本表上生產(chǎn)數(shù)據(jù) 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占孔標(biāo)簽列表點(diǎn)(0 To 2), i人井定位點(diǎn)(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部件數(shù)目指針 As Long
    Dim aryTableData As Variant
    Dim iCount As Long
    Dim ary部件ID(1 To 10000) As String
    
    Dim s占孔類別標(biāo)志 As String

Dim s部件ID, s代號(hào), s編號(hào), s類別, s名稱 As String
Dim s程式, s單位, s數(shù)量, s狀態(tài), s形式9 As String
Dim s局所10, s機(jī)樓11, s測(cè)量室12, s交接區(qū)13, s線類14 As String
Dim s線號(hào)15, s線序16, s地址17, s坐標(biāo), s文檔編號(hào)19 As String
Dim s竣工日期, s歸檔日期, s修改日期22, s產(chǎn)權(quán)人23, s建造人24, s擴(kuò)展欄 As String
Dim i人井定位序號(hào) As Long
    i人井定位序號(hào) = Val(frm管孔布置器.txt人井定位序號(hào).Value)


s占孔類別標(biāo)志 = frm管孔布置器.lbl占孔類別標(biāo)志.Caption
If frm管孔布置器.lbl占孔類別標(biāo)志.Caption = "" Then s占孔類別標(biāo)志 = " "

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!(請(qǐng)首先打開圖紙文件,然后進(jìn)行數(shù)據(jù)提取.)"
        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部件數(shù)目指針 = 1
    Header = False
            s產(chǎn)權(quán)人23地片信息 = frm管孔布置器.cbb地片信息.Text
            s機(jī)樓11機(jī)樓信息 = frm管孔布置器.cbb機(jī)樓信息.Text
            s文檔編號(hào)19人井名稱 = frm管孔布置器.cbb人井名稱.Text
            s形式9占孔號(hào)碼 = frm管孔布置器.txt占孔號(hào)碼.Text
            s測(cè)量室12站點(diǎn)信 = frm管孔布置器.cbb站點(diǎn)信息.Text '測(cè)量室
            s交接區(qū)13對(duì)象名稱 = frm管孔布置器.cbb對(duì)象名稱.Text
            s線序16線序信息 = frm管孔布置器.txt線序信息.Text
            s地址17線纜程式 = frm管孔布置器.txt線纜程式.Text


Select Case s導(dǎo)數(shù)形式
    Case "人井定位"
        i人井定位點(diǎn)(0) = 150# + i人井定位序號(hào) * i圖紙距離: i人井定位點(diǎn)(1) = 190#: i人井定位點(diǎn)(2) = 0
        objAcad.ZoomCenter i人井定位點(diǎn), 250 'XX
    Case "人井填名"
    i占孔標(biāo)簽列表點(diǎn)(0) = 150# + i人井定位序號(hào) * i圖紙距離: i占孔標(biāo)簽列表點(diǎn)(1) = 160#: i占孔標(biāo)簽列表點(diǎn)(2) = 0
    Set circleObj = objAcad.ModelSpace.AddCircle(i占孔標(biāo)簽列表點(diǎn), 20)
    Set textObj圈定提示 = Mspace.AddText(s文檔編號(hào)19人井名稱, i占孔標(biāo)簽列表點(diǎn), 5)
    textObj圈定提示.Alignment = acAlignmentMiddle 'acAlignmentCenter
    Case Else
'MsgBox "kk"
    i占孔標(biāo)簽列表點(diǎn)(0) = 5# + i人井定位序號(hào) * i圖紙距離: i占孔標(biāo)簽列表點(diǎn)(1) = -100#: i占孔標(biāo)簽列表點(diǎn)(2) = 0
    
                            i占孔標(biāo)簽列表點(diǎn)(0) = 11# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText("人井名稱", i占孔標(biāo)簽列表點(diǎn), 5)
                            i占孔標(biāo)簽列表點(diǎn)(0) = 51# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText("占孔情況", i占孔標(biāo)簽列表點(diǎn), 5)
                            textObj圈定提示.Layer = "管孔層"
                            i占孔標(biāo)簽列表點(diǎn)(0) = 81# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText("局站名稱", i占孔標(biāo)簽列表點(diǎn), 5)
                            i占孔標(biāo)簽列表點(diǎn)(0) = 121# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText("配區(qū)名稱", i占孔標(biāo)簽列表點(diǎn), 5)
                            i占孔標(biāo)簽列表點(diǎn)(0) = 161# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText("起止線序", i占孔標(biāo)簽列表點(diǎn), 5)
                            i占孔標(biāo)簽列表點(diǎn)(0) = 231# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText("纜線程式", i占孔標(biāo)簽列表點(diǎn), 5)
                            i占孔標(biāo)簽列表點(diǎn)(0) = 281# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText("機(jī)樓", i占孔標(biāo)簽列表點(diǎn), 5)
                            i占孔標(biāo)簽列表點(diǎn)(0) = 331# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText("地片", i占孔標(biāo)簽列表點(diǎn), 5)
                            
                            i記錄指針 = i記錄指針 + 1
                            i占孔標(biāo)簽列表點(diǎn)(0) = 5# + i人井定位序號(hào) * i圖紙距離: i占孔標(biāo)簽列表點(diǎn)(1) = -100 + i記錄指針 * (-7): i占孔標(biāo)簽列表點(diǎn)(2) = 0
                          
    For Each objEntity In Mspace
        i部件數(shù)目指針 = i部件數(shù)目指針 + 1
        With objEntity
            If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
                If .HasAttributes Then
                    ''' Cells(iRowNum, 1).Value = objEntity.insertionPoint ''' 列出屬性塊的插入點(diǎn)
                    ''' Cells(iRowNum, 1).Value = objEntity.Name ''' 列出屬性塊的名稱,可以按照名稱篩選
                    sCurrName = .Name
                    sCurrID = .Handle
                    vCurrInsertionPoint = .insertionPoint
                    vCurrRotation = .Rotation
                    aryTableData = .GetAttributes ' import
                
            s部件ID = aryTableData(0).textString
            s代號(hào) = aryTableData(1).textString
            s編號(hào) = aryTableData(2).textString
            s類別 = aryTableData(3).textString
            s名稱 = aryTableData(4).textString
            s程式 = aryTableData(5).textString
            s單位 = aryTableData(6).textString
            s數(shù)量 = aryTableData(7).textString
            s狀態(tài) = aryTableData(8).textString
            s形式9 = aryTableData(9).textString
            s局所10 = aryTableData(10).textString
            s機(jī)樓11 = aryTableData(11).textString
            s測(cè)量室12 = aryTableData(12).textString
            s交接區(qū)13 = aryTableData(13).textString
            s線類14 = aryTableData(14).textString
            s線號(hào)15 = aryTableData(15).textString
            s線序16 = aryTableData(16).textString
            s地址17 = aryTableData(17).textString
            s坐標(biāo) = aryTableData(18).textString
            s文檔編號(hào)19 = aryTableData(19).textString
            s竣工日期 = aryTableData(20).textString
            s歸檔日期 = aryTableData(21).textString
            s修改日期22 = aryTableData(22).textString
            s產(chǎn)權(quán)人23 = aryTableData(23).textString
            s建造人24 = aryTableData(24).textString
            s擴(kuò)展欄 = aryTableData(25).textString
            
                            'Debug.Print i部件數(shù)目指針 & objEntity.EntityName & s線號(hào)15

                    '''''''''''''''''
                    '''導(dǎo)入占用
                    Select Case s導(dǎo)數(shù)形式
                    Case "導(dǎo)入占用"

                    If s機(jī)樓11機(jī)樓信息 = s機(jī)樓11 And s文檔編號(hào)19人井名稱 = s文檔編號(hào)19 _
                         And s形式9占孔號(hào)碼 = s形式9 Then
                         MsgBox "導(dǎo)入占用>> " & s文檔編號(hào)19人井名稱 & s形式9占孔號(hào)碼 & "對(duì)應(yīng)" & s形式9

                        If s測(cè)量室12站點(diǎn)信 <> "" Then aryTableData(12).textString = s測(cè)量室12站點(diǎn)信
                        If s交接區(qū)13對(duì)象名稱 <> "" Then aryTableData(13).textString = s交接區(qū)13對(duì)象名稱
                        aryTableData(15).textString = s占孔類別標(biāo)志 ''●＃
                        If s線序16線序信息 <> "" Then aryTableData(16).textString = s線序16線序信息
                        If s地址17線纜程式 <> "" Then aryTableData(17).textString = s地址17線纜程式
                    Else
                       ' MsgBox "請(qǐng)確定: 機(jī)樓, 人井名, 占孔號(hào)碼"
                        'Exit Sub
                    End If
                    Case "導(dǎo)出占用"
                     '''''''''''''''''
                        '''無(wú)效部件的圈定
                        If Left(s線號(hào)15, 1) = "●" And s機(jī)樓11機(jī)樓信息 = s機(jī)樓11 And s文檔編號(hào)19人井名稱 = s文檔編號(hào)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測(cè)量室12 & s交接區(qū)13 & s線序16 & s地址17
                            i占孔標(biāo)簽列表點(diǎn)(0) = 11# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText(s文檔編號(hào)19, i占孔標(biāo)簽列表點(diǎn), 5)
                            i占孔標(biāo)簽列表點(diǎn)(0) = 61# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText(s形式9, i占孔標(biāo)簽列表點(diǎn), 5)
                            textObj圈定提示.Layer = "管孔層"
                            i占孔標(biāo)簽列表點(diǎn)(0) = 81# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText(s測(cè)量室12, i占孔標(biāo)簽列表點(diǎn), 5)
                            i占孔標(biāo)簽列表點(diǎn)(0) = 121# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText(s交接區(qū)13, i占孔標(biāo)簽列表點(diǎn), 5)
                            i占孔標(biāo)簽列表點(diǎn)(0) = 161# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText(s線序16, i占孔標(biāo)簽列表點(diǎn), 5)
                            i占孔標(biāo)簽列表點(diǎn)(0) = 231# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText(s地址17, i占孔標(biāo)簽列表點(diǎn), 5)
                            i占孔標(biāo)簽列表點(diǎn)(0) = 281# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText(s機(jī)樓11, i占孔標(biāo)簽列表點(diǎn), 5)
                            i占孔標(biāo)簽列表點(diǎn)(0) = 331# + i人井定位序號(hào) * i圖紙距離
                            Set textObj圈定提示 = Mspace.AddText(s產(chǎn)權(quán)人23, i占孔標(biāo)簽列表點(diǎn), 5)
                            i記錄指針 = i記錄指針 + 1
                            i占孔標(biāo)簽列表點(diǎn)(0) = 5# + i人井定位序號(hào) * i圖紙距離: i占孔標(biāo)簽列表點(diǎn)(1) = -100 + i記錄指針 * (-7): i占孔標(biāo)簽列表點(diǎn)(2) = 0
                        MsgBox "ll'" & i記錄指針
                        End If
                        
                    End Select
                    Header = True
                End If
            End If
        End With
        '''減輕負(fù)載
      '  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 "當(dāng)前圖紙的新管孔占用數(shù)量為: " & i記錄指針 & " 個(gè). ", vbInformation, myTitle
    Else
       ' MsgBox "No attributes found in the current drawing(當(dāng)前圖紙沒(méi)有發(fā)現(xiàn)有效數(shù)據(jù))" & i記錄指針 & " 個(gè). ", vbInformation, myTitle
    End If
    


End Select
'''''

    Set objAcad = Nothing
    
HandleErr:
    'MsgBox "出現(xiàn)錯(cuò)誤" & Err.Number & " (" & Err.Description & ") from " & _
            Err.Source, vbCritical, conDemoName
End Sub


Private Sub Auto_Close()
    Set objExcelsheet = Nothing
End Sub