frm

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

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frm管孔布置器 
   Caption         =   "SIFANG - 管孔布置器 2.01"
   ClientHeight    =   6600
   ClientLeft      =   3900
   ClientTop       =   2565
   ClientWidth     =   7785
   Icon            =   "frm管孔布置.dsx":0000
   MaxButton       =   0   'False
   OleObjectBlob   =   "frm管孔布置.dsx":030A
End
Attribute VB_Name = "frm管孔布置器"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public s当前目录 As String
Dim s库表人井名称(10000), s人井名称 As String
Dim i库表人井定位序号(10000), i人井定位序号 As Long

'''晋20040816
''' EMAIL : [e-mail]

Private Sub cbb对象类别信息_Change()
Select Case Me.cbb对象类别信息.Value
    Case "主干"
    Me.lbl对象名称.Caption = "主干名称"
    Case "配区"
    Me.lbl对象名称.Caption = "配区名称"
    Case "配线"
    Me.lbl对象名称.Caption = "配区名称"
    Case "光缆"
    Me.lbl对象名称.Caption = "光缆名称"
    Case "管道"
    Me.lbl对象名称.Caption = "管道名称"
    Case Else
    Me.lbl对象名称.Caption = "其它名称"
End Select
End Sub



Private Sub cbb人井名称_Change()
If Me.cbb人井名称.ListIndex >= 0 Then
    Me.txt人井定位序号.Value = i库表人井定位序号(Me.cbb人井名称.ListIndex)
End If
End Sub

Private Sub cbb占孔类别_Change()
Me.lbl占孔类别标志.Caption = Mid(Me.cbb占孔类别.Text, 5, 1)
If Left(Me.cbb占孔类别.Text, 4) = "线号标注" Then Me.lbl占孔类别标志.Caption = "线号标注"
End Sub

Private Sub cbb占孔类别_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    XZ = MsgBox("是否清空本操作面板的各个栏目的信息?", vbYesNo)
    If Left(Me.cbb占孔类别.Text, 4) = "未有占用" Then XZ = vbYes
    If XZ = vbYes Then
        Me.cbb站点信息.Value = ""
        Me.cbb对象类别信息.Value = ""
        Me.cbb对象名称.Value = ""
        Me.txt线缆程式.Value = ""
        Me.txt线序信息.Value = ""
    End If
End Sub

Private Sub cmb定位_Click()
If Me.Mpage管孔布置.SelectedItem.Name = "Page占孔情况" Then Call m占孔情况.p占孔情况("人井定位")
If Me.Mpage管孔布置.SelectedItem.Name = "Page管孔布放" Then Call m管孔布放.p管孔布放("人井定位")
'ZoomCenter center, Magnify
End Sub

Private Sub cmb井壁A_Click()
Me.txt井壁面.Value = "A"
End Sub
Private Sub cmb井壁B_Click()
Me.txt井壁面.Value = "B"
End Sub
Private Sub cmb井壁C_Click()
Me.txt井壁面.Value = "C"
End Sub
Private Sub cmb井壁D_Click()
Me.txt井壁面.Value = "D"
End Sub

Private Sub cmb新增人井_Click()
s人井名称 = Me.cbb人井名称.Value
If s人井名称 <> "" Then
Open s当前目录 & "\Data\人井名称.txt" For Input As #1    ' 打开输入文件。
i = 0
Do While Not EOF(1)    ' 循环至文件尾。
    Input #1, s库表人井名称(i), i库表人井定位序号(i)    ' 将数据读入两个变量。
    If s人井名称 = s库表人井名称(i) Then
        Close #1
        MsgBox "人井名称已经存在."
        Exit Sub
    End If
    i = i + 1
Loop
Close #1    ' 关闭文件。
i人井定位序号 = Me.cbb人井名称.ListCount + 1
i人井定位序号 = InputBox("请输入新的人井定位序号.", , i人井定位序号)
Open s当前目录 & "\Data\人井名称.txt" For Append As #1     ' 打开输入文件。
    Write #1, s人井名称, i人井定位序号    ' 将数据读入两个变量。
        cbb人井名称.AddItem s人井名称    ' 在立即窗口中显示数据。
    cbb人井名称.List(i, 1) = i人井定位序号
Close #1    ' 关闭文件。
If Me.cbb人井名称.ListIndex >= 0 Then
    Me.txt人井定位序号.Value = i人井定位序号
End If
End If
End Sub

Private Sub cmb新增人井_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
    XZ = MsgBox("清除人井名称积存记录?", vbYesNo)
    If XZ = vbYes Then
       Open s当前目录 & "\Data\人井名称.txt" For Output As #1    ' 打开输入文件。
        i = 0
        Do While Not EOF(1)    ' 循环至文件尾。
            Write #1, ,    ' 将数据读入两个变量。
            i = i + 1
        Loop
        Close #1    ' 关闭文件。
    End If
    
End If

End Sub

Private Sub cmb应用_Click()
If Me.Mpage管孔布置.SelectedItem.Name = "Page管孔布放" Then Call m管孔布放.p管孔布放("管孔布放")
If Me.Mpage管孔布置.SelectedItem.Name = "Page占孔情况" Then MsgBox "请正确操作.", vbInformation, myTitle
Me.txt起始序号.Value = "1"
End Sub


Private Sub cmb取消_Click()
Unload Me
End
End Sub

Private Sub cmd导出占用_Click()
Call m占孔情况.p占孔情况("导出占用")
MsgBox " 完成导出占用 >>>>"
End Sub

Private Sub cmd导入占用_Click()
Call m占孔情况.p占孔情况("导入占用")
MsgBox ">>>> 完成导入占用"
End Sub

Private Sub cmd填名_Click()
If Me.cbb人井名称.Text <> "" Then
Call m占孔情况.p占孔情况("人井填名")
    MsgBox " □ 新人井名称赋图完毕,放置于展开图中央."
End If
End Sub




Private Sub lbl程式尺_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Select Case X
    Case 0 To 7
                Me.txt线缆程式.Value = "HYA5-0.4"
    Case 7 To 20
                Me.txt线缆程式.Value = "HYA10-0.4"
    Case 20 To 33
                Me.txt线缆程式.Value = "HYA20-0.4"
    Case 33 To 46
                Me.txt线缆程式.Value = "HYA30-0.4"
    Case 46 To 59
                Me.txt线缆程式.Value = "HYA50-0.4"
    Case 59 To 77
                Me.txt线缆程式.Value = "HYA100-0.4"
    Case 77 To 93
                Me.txt线缆程式.Value = "HYA200-0.4"
    Case 93 To 109
                Me.txt线缆程式.Value = "HYA300-0.4"
    Case 109 To 125
                Me.txt线缆程式.Value = "HYA400-0.4"
    Case 125 To 141
                Me.txt线缆程式.Value = "HYA500-0.4"
    Case 141 To 157
                Me.txt线缆程式.Value = "HYA600-0.4"
    Case 157 To 173
                Me.txt线缆程式.Value = "HYA800-0.4"
    Case 173 To 189
                Me.txt线缆程式.Value = "HYA1000-0.4"
    Case 189 To 205
                Me.txt线缆程式.Value = "HYA1200-0.4"
    Case 205 To 220
                Me.txt线缆程式.Value = "HYA1600-0.4"
    Case 220 To 235
                Me.txt线缆程式.Value = "HYA2000-0.4"
    Case 235 To 250
                Me.txt线缆程式.Value = "HYA2400-0.4"
    Case 250 To 265
                Me.txt线缆程式.Value = "HYA3000-0.4"
    Case 265 To 280
                Me.txt线缆程式.Value = "HYA3200-0.4"

        
End Select
Me.Caption = X
End Sub

Private Sub lbl井壁放大_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.lbl井壁放大.Caption = ""
Me.lbl井壁放大.Height = 90: Me.lbl井壁放大.Width = 100
For iRow = 1 To Val(Me.txt孔行数.Text)
    For iColumn = 1 To Val(Me.txt孔列数.Text)
        Me.lbl井壁放大.Caption = Me.lbl井壁放大.Caption & "○"
    Next iColumn
    Me.lbl井壁放大.Caption = Me.lbl井壁放大.Caption & vbCrLf
Next iRow
'Me.lbl井壁放大.AutoSize = True
End Sub

Private Sub lbl井壁放大_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.lbl井壁放大.Caption = "^◎^"
Me.lbl井壁放大.Height = 20: Me.lbl井壁放大.Width = 20
End Sub


Private Sub txt孔列数_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Me.txt孔列数.Value = Str(Val(Me.txt孔列数.Text) + 1)
Me.txt孔行数.Value = Me.txt孔列数.Text
End Sub

Private Sub txt孔行数_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Me.txt孔行数.Value = Str(Val(Me.txt孔行数.Text) + 1)
End Sub






Private Sub txt线缆程式_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
s电缆暗码 = ""
s电缆暗码 = UCase(Me.txt线缆程式.Value)
s电缆暗码 = Left(s电缆暗码, 1) & Right(s电缆暗码, 2) 'A.
Select Case s电缆暗码
    Case "A.."
        Me.txt线缆程式.Value = "HYA" & Mid(Me.txt线缆程式.Value, 2, (Len(Me.txt线缆程式.Value) - 3)) & "-0.5"
    Case "A.4"
        Me.txt线缆程式.Value = "HYA" & Mid(Me.txt线缆程式.Value, 2, (Len(Me.txt线缆程式.Value) - 3)) & "-0.4"
    Case "A.5"
        Me.txt线缆程式.Value = "HYA" & Mid(Me.txt线缆程式.Value, 2, (Len(Me.txt线缆程式.Value) - 3)) & "-0.5"
    Case "A.6"
        Me.txt线缆程式.Value = "HYA" & Mid(Me.txt线缆程式.Value, 2, (Len(Me.txt线缆程式.Value) - 3)) & "-0.6"
End Select
End Sub

Private Sub txt占孔号码_Change()
Me.txt占孔号码.Value = UCase(Me.txt占孔号码.Text)
End Sub


Private Sub txt占孔开始_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If Left(Me.cbb占孔类别.Text, 4) = "已有占用" And Right(Me.txt占孔号码, 1) = "." Then
    Me.txt占孔开始.Enabled = True: Me.txt占孔结束.Enabled = True
Else
    Me.txt占孔开始.Enabled = False: Me.txt占孔结束.Enabled = False
End If
End Sub

Private Sub txt总孔数_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Me.txt总孔数.Value = Str(Val(Me.txt孔列数.Text) * Val(Me.txt孔行数.Text))
End Sub

Private Sub txt线序信息_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim s对象名称 As String
s对象名称 = "xxxx"
If Me.cbb对象名称.Value <> "" Then s对象名称 = Me.cbb对象名称.Value
Select Case Me.cbb对象类别信息.Value
    Case "主干"
    Me.txt线序信息.Value = "ZG" & txt线号 & "="
    Case "配区"
    Me.txt线序信息.Value = "PX" & txt线号 & "="
    Case "配线"
    Me.txt线序信息.Value = "PX" & txt线号 & "="
    Case "光缆"
    Me.txt线序信息.Value = "GL" & txt线号 & "="
    Case "管道"
    Me.txt线序信息.Value = "GD" & txt线号 & "="
    Case Else
    Me.txt线序信息.Value = "QT" & txt线号 & "="
End Select
If Me.cbb占孔类别.Value = "线号标注" Then Me.lbl占孔类别标志.Caption = txt线号
End Sub


Private Sub UserForm_Activate()
'Me.txt孔外径.Value= "90"
'Me.txt孔距.Value= "10"
End Sub

Private Sub UserForm_Initialize()
    
On Error Resume Next


''''''''''''''''''''
Dim Getdata1, Getdata2  As String
s当前目录 = Trim(CurDir)
'MsgBox s当前目录

Open s当前目录 & "\Data\地片.txt" For Input As #1    ' 打开输入文件。
Do While Not EOF(1)    ' 循环至文件尾。
    Input #1, Getdata1    ' 将数据读入两个变量。
    cbb地片信息.AddItem Getdata1    ' 在立即窗口中显示数据。
Loop
Close #1    ' 关闭文件。

Open s当前目录 & "\Data\机楼.txt" For Input As #1    ' 打开输入文件。
Do While Not EOF(1)    ' 循环至文件尾。
    Input #1, Getdata1    ' 将数据读入两个变量。
    cbb机楼信息.AddItem Getdata1    ' 在立即窗口中显示数据。
Loop
Close #1    ' 关闭文件。

Open s当前目录 & "\Data\站点.txt" For Input As #1    ' 打开输入文件。
Do While Not EOF(1)    ' 循环至文件尾。
    Input #1, Getdata1    ' 将数据读入两个变量。
    cbb站点信息.AddItem Getdata1    ' 在立即窗口中显示数据。
Loop
Close #1    ' 关闭文件。

Open s当前目录 & "\Data\对象类别.txt" For Input As #1    ' 打开输入文件。
Do While Not EOF(1)    ' 循环至文件尾。
    Input #1, Getdata1    ' 将数据读入两个变量。
    cbb对象类别信息.AddItem Getdata1    ' 在立即窗口中显示数据。
Loop
Close #1    ' 关闭文件。

Open s当前目录 & "\Data\人井名称.txt" For Input As #1    ' 打开输入文件。
i = 0
Do While Not EOF(1)    ' 循环至文件尾。
    Input #1, s库表人井名称(i), i库表人井定位序号(i)    ' 将数据读入两个变量。
    cbb人井名称.AddItem s库表人井名称(i)    ' 在立即窗口中显示数据。
    cbb人井名称.List(i, 1) = i库表人井定位序号(i)
    i = i + 1
Loop
Close #1    ' 关闭文件。

Open s当前目录 & "\Data\管孔程式.whd" For Input As #1    ' 打开输入文件。
Do While Not EOF(1)    ' 循环至文件尾。
    Input #1, Getdata1    ' 将数据读入两个变量。
    Me.cbb管孔程式.AddItem Getdata1    ' 在立即窗口中显示数据。
Loop
Me.cbb管孔程式.Value = "大管孔"

Close #1    ' 关闭文件。
Open s当前目录 & "\Data\占孔类别.whd" For Input As #1    ' 打开输入文件。
Do While Not EOF(1)    ' 循环至文件尾。
    Input #1, Getdata1, Getdata2   ' 将数据读入两个变量。
    Me.cbb占孔类别.AddItem Getdata1 & Getdata2    ' 在立即窗口中显示数据。
Loop
'Me.cbb占孔类别.Text = "新增占用,●"
Close #1    ' 关闭文件。

Open s当前目录 & "\Data\配区.txt" For Input As #1    ' 打开输入文件。
Do While Not EOF(1)    ' 循环至文件尾。
    Input #1, Getdata1    ' 将数据读入两个变量。
    cbb对象名称.AddItem Getdata1    ' 在立即窗口中显示数据。
Loop
Close #1    ' 关闭文件。

Open s当前目录 & "\Data\建造人.txt" For Input As #1    ' 打开输入文件。
Do While Not EOF(1)    ' 循环至文件尾。
    Input #1, Getdata1    ' 将数据读入两个变量。
    cbb建造人信息.AddItem Getdata1    ' 在立即窗口中显示数据。
Loop
Close #1    ' 关闭文件。

Exit Sub
Errorhandler:
    Select Case Err
        Case 76
        msg = "设定数据不存在,或者'Data'子目录不存在!"
        Case Else
        msg = "请正确操作! 错误可能是=" & Err
    End Select
    MsgBox msg & ". 当前目录: " & s当前目录
    'Me.tlb提示栏.Caption = "-" & msg   '提示栏显示
    'Resume Next
'''''''''''''''''''''''''''''''''''''''''''''
End Sub