m

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

Attribute VB_Name = "m管孔布放"


Sub p管孔布放(s布放参数 As String)


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 b字符式管孔 As Boolean


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)
    
b字符式管孔 = frm管孔布置器.ckb字符式管孔.Value

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
'''''''''''''''''''''''''''''''''''''
    
''CHENLIJIN20040810
'sethole
    ' Create Circle
    Dim myTitle As String
    myTitle = "SIFANG - Cue"
    'Dim circleObj As AcadCircle
    Dim center(0 To 2) As Double
    Dim radius As Double
    Dim layerObj As Object
    
    Set layerObj = objAcadDoc.Layers("管孔层") 'Add("LayerOn")
    'MsgBox layerObj.Name & layerObj.LayerOn & objAcadDoc.ActiveLayer.Name
    If layerObj.LayerOn = False Then
        layerObj.LayerOn = True
        ' Set the layer of new circle to "ABC"
        'circleObj.Layer = "管孔层"
        MsgBox layerObj.Name & " On"
    End If
    If objAcadDoc.ActiveLayer.mane <> "管孔层" Then
        objAcadDoc.ActiveLayer = objAcadDoc.Layers.Item("管孔层")
        'MsgBox "当前图层=" & objAcadDoc.ActiveLayer.Name
    End If
    
  '  center(0) = 200: center(1) = 205: center(2) = 0
   ' radius = 10
   ' Set circleObj = objAcadDoc.ModelSpace.AddCircle(center, radius)

        
     ' This example creates a block containing a circle.
    ' It then inserts the block.

    ' Select the block
    Dim blockObj管孔面 As Object 'AcadBlock
    Dim insertionPnt(0 To 2) As Double

    'Set blockObj管孔面 = objAcadDoc.Blocks.Item("_管孔面")
   
    ' Insert the block
    Dim blockRefObj As Object 'AcadBlockReference
    Dim inpointX0, inpointY0, inpointZ0, inpointXi, inpointYi, inpointZi, iRotation, iXscale, iYscale As Double
    

    
    
Select Case s布放参数

    Case "人井定位"
        i人井定位点(0) = 150# + i人井定位序号 * i图纸距离: i人井定位点(1) = 190#: i人井定位点(2) = 0
        objAcad.ZoomCenter i人井定位点, 200 'XX
    Case Else
    
    sWellwall = "a"
    iHolecolumns = 0
    iHoleRows = 0
    iStartRow = 1
    iHoleDia = 10 'Val(frm管孔布置器.txt孔外径.Text)
    iHoleSpace = 10
    iHolsAmount = 0
    sHoleSort = "1" '"大管孔"
    If b字符式管孔 = True Then
        iXscale = 0.01
        iYscale = 0.01
    Else
        iXscale = 1
        iYscale = 1
    End If
    
    
    sWellwall = frm管孔布置器.txt井壁面.Text ' InputBox("Please select which wall of WELL that want to set the HOLE. ( A, B, C, D ) ", myTitle, sWellwall)
    sWellwall = UCase(sWellwall)
    sHoleSort = frm管孔布置器.cbb管孔程式.Text  ' InputBox("Please select the sort of HOLE : 1)大管孔, 2)小管孔, 3)水泥管, 4)槽道, 5) 引上管 .", myTitle, "1")
    iHoleDia = Val(frm管孔布置器.txt孔外径.Text)
        Select Case sHoleSort
        Case "大管孔" '"1"
            s程式5 = "大管孔"
            If b字符式管孔 = True Then
                s线类14 = "○"
            Else
                s线类14 = ""
            End If
        Case "小管孔" '"2"
            s程式5 = "小管孔"
            s线类14 = ""
        Case "水泥管" '"3"
            s程式5 = "水泥管"
            s线类14 = "□"
        Case "槽道" '"4"
            s程式5 = "槽道"
            s线类14 = "回"
        Case "引上管" '"5"
            s程式5 = "引上管"
            If b字符式管孔 = True Then
                s线类14 = "◎"
            Else
                s线类14 = "○"
            End If
        Case Else
            s程式5 = "大管孔"
            s线类14 = ""
            Exit Sub
    End Select
    iHolecolumns = Val(frm管孔布置器.txt孔列数.Text)  ' InputBox("Please input Number of the column to Hole.  X|||  孔列数", myTitle, iHolecolumns)
    iHoleRows = Val(frm管孔布置器.txt孔行数.Text)  '  InputBox("Please input Number of the row to Hole.  Y==  孔行数", myTitle, iHolecolumns)
    '间距
    iHoleSpace = Val(frm管孔布置器.txt孔距.Text)  '  InputBox("Please input the space betweem the Hole.  ○< >○ 孔间距", myTitle, iHoleSpace)
    iHolsAmount = iHolecolumns * iHoleRows
    iHolsAmount = Val(frm管孔布置器.txt总孔数.Text)   ' InputBox("Please input the Amount of Hole.  孔数量", myTitle, iHolsAmount)
    iStartRow = Val(frm管孔布置器.txt起始层数.Text)
    iStartSN = Val(frm管孔布置器.txt起始序号.Text)
    Select Case sWellwall
        Case "A"
            inpointX0 = 120 + i人井定位序号 * i图纸距离: inpointY0 = 240 + (iStartRow - 1) * iHoleSpace: inpointZ0 = 0: iRotation = 0
            iFacefactX = 1: iFacefactY = 0: iFaceAimX = 0: iFaceAimY = 1
            If iHolecolumns <= 5 Then inpointX0 = inpointX0 + (5 - iHolecolumns) * iHoleSpace
        Case "B"
            inpointX0 = 200 + i人井定位序号 * i图纸距离 + (iStartRow - 1) * iHoleSpace: inpointY0 = 220: inpointZ0 = 0: iRotation = objAcadDoc.Utility.AngleToReal("270", acDegrees)
            iFacefactX = 0: iFacefactY = -1: iFaceAimX = 1: iFaceAimY = 0
            If iHolecolumns <= 5 Then inpointY0 = inpointY0 - (5 - iHolecolumns) * iHoleSpace
        Case "C"
            inpointX0 = 180 + i人井定位序号 * i图纸距离: inpointY0 = 140 - (iStartRow - 1) * iHoleSpace: inpointZ0 = 0: iRotation = objAcadDoc.Utility.AngleToReal("180", acDegrees)
            iFacefactX = -1: iFacefactY = 0: iFaceAimX = 0: iFaceAimY = -1
            If iHolecolumns <= 5 Then inpointX0 = inpointX0 - (5 - iHolecolumns) * iHoleSpace
        Case "D"
            inpointX0 = 100 + i人井定位序号 * i图纸距离 - (iStartRow - 1) * iHoleSpace: inpointY0 = 160: inpointZ0 = 0: iRotation = objAcadDoc.Utility.AngleToReal("90", acDegrees)
            iFacefactX = 0: iFacefactY = 1: iFaceAimX = -1: iFaceAimY = 0
            If iHolecolumns <= 5 Then inpointY0 = inpointY0 + (5 - iHolecolumns) * iHoleSpace
        Case Else
            MsgBox "请确定井壁面. Wrong input! exit now.", vbCritical, myTitle
            Exit Sub
    End Select
    inpointXi = inpointX0: inpointYi = inpointY0: inpointZi = inpointZ0
    'insertionPnt(0) = inpointX: insertionPnt(1) = inpointY: insertionPnt(2) = inpointZ
    
    iRotation = 0 ''''
    iiHolsAmount = iStartSN - 1
    Dim varAttributes As Variant
            s产权人23 = frm管孔布置器.cbb地片信息.Text
            s机楼11 = frm管孔布置器.cbb机楼信息.Text
            s文档编号19 = frm管孔布置器.cbb人井名称.Text
            s修改日期22 = Date
            s建造人24 = frm管孔布置器.cbb建造人信息.Text
            
    If s产权人23 = "" Or s机楼11 = "" Or s文档编号19 = "" Then MsgBox "错误. 地片,机楼,人井名称等必须填写.", vbCritical, myTitle: Exit Sub
    If iHolecolumns = 0 Or iHoleRows = 0 Or iHoleSpace = 0 Then MsgBox "错误. 管孔数据必须填写.", vbCritical, myTitle: Exit Sub
    For fiHoleRows = 1 To iHoleRows
        For fiHolecolumns = 1 To iHolecolumns
            iiHolsAmount = iiHolsAmount + 1
            If iiHolsAmount > iHolsAmount + iStartSN Then MsgBox "完成指定孔数." & iiHolsAmount, vbInformation, myTitle: Exit Sub
            
            insertionPnt(0) = inpointXi: insertionPnt(1) = inpointYi: insertionPnt(2) = inpointZi
            Set blockRefObj = objAcadDoc.ModelSpace.InsertBlock(insertionPnt, "_管孔面", iXscale, iYscale, 1#, iRotation)
            'RetVal = object.InsertBlock(InsertionPoint, Name, Xiscale, Yiscale, ZiScale, Rotation [, Password])
            ' 获取块参照的属性
            varAttributes = blockRefObj.GetAttributes
            varAttributes.Color = 0
            varAttributes(2).textString = Trim(Str(iiHolsAmount))
            If frm管孔布置器.ckb新增管孔.Value = True Then
                varAttributes(2).Color = 1
            End If
            varAttributes(5).textString = s程式5
            varAttributes(9).textString = sWellwall & Trim(Str(iiHolsAmount)) ' 编号
            varAttributes(23).textString = s产权人23
            varAttributes(11).textString = s机楼11
            varAttributes(14).textString = s线类14
            If b字符式管孔 = True Then
                varAttributes(14).Height = 1.7 * varAttributes(14).Height / iXscale
                varAttributes(14).scalefactor = 1.5
                varAttributes(15).Height = 1.2 * varAttributes(15).Height / iXscale
                varAttributes(15).scalefactor = 1.5
                varAttributes(2).Height = 1.7 * varAttributes(2).Height / iXscale
                If varAttributes(14).Invisible = True Then
                    varAttributes(14).Invisible = False
                End If
            Else
                varAttributes(14).Height = varAttributes(14).Height * iXscale
                varAttributes(2).Height = varAttributes(2).Height * iXscale
            End If
            If frm管孔布置器.ckb已占用管孔.Value = True Then varAttributes(15).textString = "X"
            varAttributes(19).textString = s文档编号19
            varAttributes(22).textString = s修改日期22
            varAttributes(24).textString = s建造人24
            'MsgBox "行:" & fiHoleRows & "  列:" & fiHolecolumns & "  孔:" & iiHolsAmount & "  X:" & insertionPnt(0) & "  Y:" & insertionPnt(1)
            inpointXi = inpointXi + iHoleSpace * iFacefactX: inpointYi = inpointYi + iHoleSpace * iFacefactY: inpointZi = 0
        Next fiHolecolumns
        inpointXi = inpointX0 + iHoleSpace * iFaceAimX * fiHoleRows: inpointYi = inpointY0 + iHoleSpace * iFaceAimY * fiHoleRows: inpointZi = 0
        
    Next fiHoleRows
    'ZoomAll
    'ZoomExtents

    ' Refresh view
   ' objAcadDoc.Regen (True)
    MsgBox "The 管孔面 is now on layer " & objAcadDoc.ActiveLayer.Name, , "Well done"
    
End Select

  '  Set objAcad = Nothing

End Sub