局方联系人.frm

部门在用的用户申告系统

Private Sub Cmddel_Click()
On Error GoTo err
If MsgBox("删除联系人将一并删除该联系人的申告记录，确认要删除吗？ ", vbQuestion + vbYesNo) = vbYes Then
   Dim str1 As String
   str1 = TVw.SelectedItem.Text
   TVw.Nodes.Remove TVw.SelectedItem.Index
   db.Execute "delete from jflx where id=" & CInt(Lab.Caption)
   db.Execute "delete from jfsg where jflxid=" & CInt(Lab.Caption)
   Call xianshino
   Cmddel.Enabled = False
   Cmdupdate.Enabled = False
   Cmdadd.Enabled = False
End If
Exit Sub

err:
   MsgBox err.Description, vbExclamation, "错误提示"
End Sub

Private Sub Cmdexit_Click()
Unload Me
End Sub

Private Sub Cmdqk_Click()
Txtdha.Text = ""
Txtdhb.Text = ""
Txtyb.Text = ""
Txtdz.Text = ""
Txtlxr.Text = ""
End Sub

Private Sub Cmdupdate_Click()
On Error GoTo err

Dim dha, dhb, yb, dz, lxr As String
If MsgBox("确认要修改吗？ ", vbQuestion + vbYesNo) = vbYes Then
           
           If Len(Trim(Txtdha.Text)) > 20 Then
               MsgBox "电话A内容超过20位", vbExclamation, "错误提示"
               Exit Sub
            End If
            If Len(Trim(Txtdhb.Text)) > 20 Then
               MsgBox "电话B内容超过20位", vbExclamation, "错误提示"
               Exit Sub
            End If
            If Len(Trim(Txtyb.Text)) > 10 Then
               MsgBox "邮政编码内容超过10位", vbExclamation, "错误提示"
               Exit Sub
            End If
           
           MousePointer = vbHourglass
           If Txtdha.Text = "" Then
              dha = ""
            Else
              dha = Trim(Txtdha.Text)
           End If
           If Txtdhb.Text = "" Then
              dhb = ""
            Else
              dhb = Trim(Txtdhb.Text)
           End If
           If Txtyb.Text = "" Then
              yb = ""
            Else
              yb = Trim(Txtyb.Text)
           End If
           If Txtdz.Text = "" Then
              dz = ""
            Else
              dz = Trim(Txtdz.Text)
           End If
           If Txtlxr.Text = "" Then
              lxr = ""
            Else
              lxr = Trim(Txtlxr.Text)
           End If
           
        Dim rsch As Recordset
        Set rsch = db.OpenRecordset("select * from jflx where dha='" & dha & "' and dhb='" & dhb _
                                   & "' and yb='" & yb & "' and address='" & dz & "' and lxr='" & lxr & "'")
        'Set rsch = db.OpenRecordset("select * from jflx where lxr='" & lxr & "'")
        
        If rsch.RecordCount > 0 Then
           MousePointer = vbDefault
           MsgBox "记录重复!", vbExclamation, "信息"
           Exit Sub
        End If
        rsch.Close
        Dim rs As Recordset
        Set rs = db.OpenRecordset("select * from jflx where id=" & CInt(Lab.Caption))
        rs.Edit
        rs.Fields!lxr = lxr
        rs.Fields!dha = dha
        rs.Fields!dhb = dhb
        rs.Fields!yb = yb
        rs.Fields!address = dz
        rs.Update
        MousePointer = vbDefault
        rs.Close
        TVw.SelectedItem.Text = lxr & "@" & Lab.Caption
        MsgBox "修改记录成功", vbQuestion, "信息"
End If
Exit Sub

err:
   MousePointer = vbDefault
   MsgBox err.Description, vbExclamation, "错误提示"
End Sub

Private Sub Form_Load()
Pic1.MousePointer = 9
top_ding = 5
currSplitPosX = &H7FFFFFFF

TVw.Width = 4200

MDIFrm.numlxr.Enabled = True
MDIFrm.Caption = MDIFrm.Caption & "---[局方联系人]"
Me.Top = 400
Me.Left = 1800
Me.Height = 4275
Me.Width = 8760
'Cmdadd.Visible = False
Cmdadd.Enabled = False
Cmddel.Enabled = False
Cmdupdate.Enabled = False
Lab.Visible = False
Lab2.Visible = False

'写入树型目录
Dim i As Integer
'Dim xnod As Nodes
Dim rs1 As Recordset
Dim rs2 As Recordset
Dim rs3 As Recordset
Dim str As String
i = 1
Dim Xnod1 As Node
Dim Xnod2 As Node
Dim Xnod3 As Node
Dim xnod4 As Node
Set Xnod1 = TVw.Nodes.Add(, tvwLast, "q", "全国", 1)
Set rs1 = db.OpenRecordset("select distinct sm from jfxx")
Do While Not rs1.EOF
   str = "w" & CStr(i)
   Set Xnod2 = TVw.Nodes.Add(Xnod1, tvwChild, str, rs1.Fields!sm, 2)
   Set rs2 = db.OpenRecordset("select distinct jm,id from jfxx where sm='" & rs1.Fields!sm & "'")
   Do While Not rs2.EOF
      str = "s" & CStr(i)
      Set Xnod3 = TVw.Nodes.Add(Xnod2, tvwChild, str, rs2.Fields!jm, 3)
      Set rs3 = db.OpenRecordset("select distinct lxr,id from jflx where jfxxid=" & rs2.Fields!id)
      Do While Not rs3.EOF
         str = "l" & CStr(i)
         Set xnod4 = TVw.Nodes.Add(Xnod3, tvwChild, str, rs3.Fields!lxr & "@" & rs3.Fields!id, 4)
         i = i + 1
         rs3.MoveNext
      Loop
      rs3.Close
      i = i + 1
      rs2.MoveNext
   Loop
   rs2.Close
   i = i + 1
   rs1.MoveNext
Loop
rs1.Close
Set rsls = db.OpenRecordset("jflx")
Call xianshino
End Sub

Private Sub Form_Resize()
Dim x1 As Integer
Dim x2 As Integer
Dim height1 As Integer
Dim width1 As Integer
Dim width2 As Integer
On Error Resume Next
height1 = ScaleHeight - (top_ding * 2)
x1 = top_ding
width1 = TVw.Width

x2 = x1 + TVw.Width + pic1width - 1
width2 = ScaleWidth - x2 - top_ding

TVw.Move x1 - 1, top_ding, width1, height1

Pic2.Move x2, top_ding, width2 + 1, height1

Pic1.Move x1 + TVw.Width - 1, top_ding, pic1width, height1

End Sub

Private Sub Form_Unload(Cancel As Integer)
rsls.Close
MDIFrm.Caption = App.Title
End Sub

Private Sub Pic1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        '左键按下
        Pic1.BackColor = SPLT_COLOUR
        currSplitPosX = CLng(X)
        
    Else
        'not the left button, so... if the current position <> default, cause a mouseup
        If currSplitPosX <> &H7FFFFFFF Then Pic1_MouseUp Button, Shift, X, Y
        
        'set the current position to the default value
        currSplitPosX = &H7FFFFFFF
    End If

End Sub

Private Sub Pic1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If currSplitPosX& <> &H7FFFFFFF Then

        'if the current position <> default, reposition the splitter and set this as the current value
        If CLng(X) <> currSplitPosX Then
                Pic1.Move Pic1.Left + X, top_ding, pic1width, ScaleHeight - (top_ding * 2)
                currSplitPosX = CLng(X)
        End If
End If
End Sub

Private Sub Pic1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'if the splitter has been moved...
If currSplitPosX <> &H7FFFFFFF Then
    'if the current postition <> the last position do a final move of the splitter
    If CLng(X) <> currSplitPosX Then
        Pic1.Move Pic1.Left + X, top_ding, pic1width, ScaleHeight - (top_ding * 2)
    End If
    
    'call this the default position
    currSplitPosX = &H7FFFFFFF
    
    'restore the normal splitter colour
    Pic1.BackColor = &H8000000F
    
    'and check for valid sizings.
    'Either enforce the default minimum & maximum widths for the left list, or, if within range, set the width
    
    If Pic1.Left > 3000 And Pic1.Left < (ScaleWidth - 4500) Then
        TVw.Width = Pic1.Left - TVw.Left 'the pane is within range
                    
'        Txtlxr.Width = Txtlxr.Width - currSplitPosX2
'        Txtdha.Width = Txtdha.Width - currSplitPosX2
'        Txtdhb.Width = Txtdhb.Width - currSplitPosX2
'        Txtyb.Width = Txtyb.Width - currSplitPosX2
'        Txtdz.Width = Txtdz.Width - currSplitPosX2
'        Cmdadd.Left = Cmdadd.Left - currSplitPosX2
'        Cmddel.Left = Cmddel.Left - currSplitPosX2
'        Cmdupdate.Left = Cmdupdate.Left - currSplitPosX2
'        Cmdexit.Left = Cmdexit.Left - currSplitPosX2
'        Frame1.Width = Frame1.Width - currSplitPosX2
                    
    ElseIf Pic1.Left < 3000 Then 'the pane is too small
        TVw.Width = 3000
    Else
        TVw.Width = ScaleWidth - 4500 'the pane is too wide
    End If
        'reposition both lists, and the splitter bar
        Form_Resize
End If

End Sub

Private Sub TVw_Click()
On Error GoTo err
Dim str1 As String
str1 = TVw.SelectedItem.Text
Dim str2 As String
str2 = TVw.Nodes(TVw.SelectedItem.Index).Key
str2 = Left(str2, 1)
If str2 = "l" Then
   Dim zuostr As String '联系人
   Dim youstr As String '联系人ID
   Dim bianliang As String
   bianliang = str1
   youstr = cxlxrid(str1)
   zuostr = cxlxrid2(bianliang)
   str1 = zuostr
   Static Idbj As Integer
   Set rsls = db.OpenRecordset("select * from jflx where lxr='" & str1 & _
               "' and id=" & youstr)
   Lab.Caption = CStr(rsls.Fields!id)
   Lab2.Caption = CStr(rsls.Fields!jfxxid)
   Call xianshiyes
   Txtlxr.Text = rsls.Fields!lxr
   Txtdha.Text = rsls.Fields!dha
   Txtdhb.Text = rsls.Fields!dhb
   Txtyb.Text = rsls.Fields!yb
   Txtdz.Text = rsls.Fields!address
   Cmddel.Enabled = True
   Cmdupdate.Enabled = True
   Cmdadd.Enabled = True
Else
   Call xianshino
   Cmddel.Enabled = False
   Cmdadd.Enabled = False
   Cmdupdate.Enabled = False
End If
Exit Sub

err:
   MsgBox err.Description, vbExclamation, "错误信息"
End Sub

Private Sub xianshiyes()
Txtdha.Enabled = True
Txtdhb.Enabled = True
Txtyb.Enabled = True
Txtdz.Enabled = True
End Sub

Private Sub xianshino()
Txtdha.Enabled = False
Txtdhb.Enabled = False
Txtyb.Enabled = False
Txtdz.Enabled = False

Txtdha.Text = ""
Txtdhb.Text = ""
Txtyb.Text = ""
Txtdz.Text = ""
Txtlxr.Text = ""
End Sub