infoma.frm

来自「功能强大的个人工作通讯录」· FRM 代码 · 共 2,184 行 · 第 1/5 页

On Error GoTo err

If QX <> "管理员" And TopRight <> "超级管理员" Then
    MsgBox "非管理员没有执行此操作的权限", 0 + 64, "提示"
    Exit Sub
End If

Call bk

 If MsgBox("此操作将删除当前联系人信息以及来往记录，是否继续操作？", vbYesNo, "确认删除") = vbNo Then Exit Sub
 
                           '------------------------------------------------------ 获得当前记录位置
                                Call OpenConn
                                sql = "select * from 联系人档案"
                                rs.Open sql, cn, 1, 1
                                rs.Find "编号=" & txtBH
                                aa = rs.Bookmark
                                Call CloseConn
 
                       
                           '------------------------------------------------------删除对应编号联系人
                                Call OpenConn
                                sql = "select * from 联系人档案 where 编号=" & txtBH
                                rs.Open sql, cn, 3, 3
                                rs.delete
                                rs.Update
                                Call CloseConn
                         '------------------------------------------------------删除对应编号联系人的来往记录
                                 Call OpenConn
                                sql = "select * from 来往记录 where 编号='" & txtBH & "'"
                                rs.Open sql, cn, 3, 3
                                Do While Not rs.EOF
                                   rs.delete
                                   rs.Update
                                   rs.MoveNext
                                Loop
                                Call CloseConn
                           '------------------------------------------------------删除对应编号联系人的相片
                                If Dir(App.Path & "\picture\" & txtBH & ".jpg", vbDirectory) <> "" Then

                                         Kill App.Path & "\picture\" & txtBH & ".jpg"
                                         Me.Picture1.Picture = LoadPicture("")
                                
                                End If
                            
                            '------------------------------------------------------ 跳到下一条记录
                                Call OpenConn
                                
                                sql = "select * from 联系人档案"
                                
                                rs.Open sql, cn, 1, 1
                                If rs.RecordCount > 0 Then
                                 Select Case aa
                                 Case Is < rs.RecordCount
                                    rs.Move aa - 1
                                    txtBH = rs.Fields("编号")
                               Case Is = rs.RecordCount
                                    rs.MoveLast
                                    txtBH = rs.Fields("编号")
                                Case Is > rs.RecordCount
                                    rs.MoveFirst
                                    txtBH = rs.Fields("编号")
                                End Select
                                
                                End If
                                Call CloseConn
                                
                                Call LxrInfo
                                ZJM.RefreshList.Value = True
err:
If err.Description <> "" Then
    MsgBox "数据库中没有记录！", 0 + 64, "error"
    Unload Me
End If

End Sub

Private Sub cmdEdit_Click()
Call bk
If txtXM = "" Then
  MsgBox "为了你的数据夫规范,姓名不能为空！", 0 + 64, "提示"
  Exit Sub
End If

If QX <> "管理员" And TopRight <> "超级管理员" Then
    MsgBox "非管理员没有执行此操作的权限", 0 + 64, "提示"
    Exit Sub
End If

Call OpenConn
        sql = "select * from 联系人档案 where 编号=" & txtBH
        
        rs.Open sql, cn, 3, 3
        
        If rs.RecordCount > 0 Then
            rs!姓名 = txtXM
            Me.Caption = txtXM & "个人资料"
            rs!性别 = txtXB
            rs!生日 = txtSR
            rs!籍贯 = txtJG
            rs!分类 = txtFL
            rs!所在省市 = txtSS
            rs!公司名称 = txtGS
            rs!职务 = txtZW
            rs!公司地址 = txtDZ
            rs!电话 = txtDH
            rs!传真 = txtCZ
            rs!性格爱好 = txtXG
            rs!电子邮箱 = txtEmail
            rs!存档时间 = Labtime
        rs.Update
        ZJM.RefreshList.Value = True
        
        MsgBox "修改成功", vbOKOnly, "操作成功"
      End If
      
Call OpenConn


End Sub

Private Sub cmdExitF_Click()
Me.Width = 14235
Me.Height = 10710
Me.Top = Screen.Height / 2 - Me.Height / 2 - 800
Me.Left = Screen.Width / 2 - Me.Width / 2

FrameDW.Visible = False
cmdDW.Enabled = True
End Sub

Private Sub cmdGO_Click()
On Error GoTo err

txtBH = Left(List3.Text, InStr(1, List3.Text, "、") - 1)
Call LxrInfo
Call History

err:
If err.Description <> "" Then
   MsgBox "请先在列表框先中项目再进行定位", 0 + 64, "错误操作"
End If
End Sub

Private Sub cmdHide_Click()
getWay.Visible = False
End Sub

Private Sub cmdNext_Click()
Call bk
On Error GoTo err
Call bk
Call OpenConn
sql = "select * from 联系人档案"
rs.Open sql, cn, 1, 1
rs.Find "编号=" & txtBH
aa = rs.Bookmark
Call CloseConn

Call OpenConn
sql = "select * from 联系人档案"
rs.Open sql, cn, 1, 1
rs.Move aa - 1
If Not rs.EOF Then
    rs.MoveNext
    txtBH.Text = rs!编号
    Call CloseConn
    Call LxrInfo
    Call History
Else
    Call CloseConn
    MsgBox "已经到达最后一条", 0 + 64, "提示"
End If

err:
If err.Description <> "" Then
    MsgBox "已到达最后一条记录！或当前记录已被删除，无法用于定位。", 0 + 64, "提示"
End If
End Sub

Private Sub cmdPre_Click()
On Error GoTo err

Call bk
Call OpenConn
sql = "select * from 联系人档案"
rs.Open sql, cn, 1, 1
rs.Find "编号=" & txtBH
aa = rs.Bookmark
Call CloseConn

Call OpenConn
sql = "select * from 联系人档案"
rs.Open sql, cn, 1, 1
rs.Move aa - 1
If Not rs.BOF Then
    rs.MovePrevious
    txtBH.Text = rs!编号
    Call CloseConn
    Call LxrInfo
    Call History
Else
    Call CloseConn
    MsgBox "已经到达第一条", 0 + 64, "提示"
End If

err:
If err.Description <> "" Then
    MsgBox "已到达第一条记录！或当前记录已被删除，无法用于定位。", 0 + 64, "提示"
End If
End Sub
Private Sub cmdSaveP_Click()
Call SavePictrueNow
End Sub

Private Sub cmdSearchBH_Click()
On Error GoTo err
Call OpenConn
sql = "select 编号 from 联系人档案 where 编号=" & ComboBH.Text
rs.Open sql, cn, 1, 1
If rs.RecordCount > 0 Then
    txtBH = ComboBH.Text
    Call LxrInfo
    Call History
Else
     MsgBox "不存在该编号", 0 + 64, "提示"
End If

err:
If err.Description <> "" Then
   MsgBox "不存在该编号", 0 + 64, "提示"
End If

End Sub

Private Sub cmdSearchXM_Click()
On Error GoTo err
List3.clear
Call OpenConn
sql = "select distinct 编号,姓名 from 联系人档案 where 姓名 like '%" & ComboXM.Text & "%'"
rs.Open sql, cn, 1, 1
If rs.RecordCount > 0 Then
    Do While Not rs.EOF
        List3.AddItem rs!编号 & "、" & IIf(IsNull(rs!姓名), "未命名的联系人", rs!姓名)
        rs.MoveNext
    Loop
End If

Call CloseConn

err:
If err.Description <> "" Then
   MsgBox err.Description
End If

End Sub


Private Sub Combo1_click()
Call bk
keyword.SetFocus
End Sub

Private Sub Command6_Click()

  If MsgBox("此操作将删除所有选中项目的联系人信息以及来往记录,并且会关闭当前窗口，是否继续操作？", vbYesNo, "确认删除") = vbNo Then Exit Sub
  
  Call OpenConn
  sql = "select * from 联系人档案 where 编号=" & txtBH
  rs.Open sql, cn, 3, 3
  rs.delete
  rs.Update
  MsgBox "删除成功", vbOKOnly, "操作提示"
  Call CloseConn
  ZJM.RefreshList.Value = True
  Unload Me
    
End Sub



Private Sub DelSelect_Click()
    Call delHxx
    Call History
End Sub

Private Sub cmdDW_Click()
FrameDW.Visible = True
Me.Width = Me.Width + FrameDW.Width - 300
Me.Top = Screen.Height / 2 - Me.Height / 2 - 800
Me.Left = Screen.Width / 2 - Me.Width / 2
cmdDW.Enabled = False

Call OpenConn
sql = "select distinct 编号,姓名 from 联系人档案"
rs.Open sql, cn, 1, 1

If rs.RecordCount > 0 Then
    Do While Not rs.EOF
        ComboBH.AddItem rs!编号
        ComboXM.AddItem rs!姓名
        rs.MoveNext
    Loop
End If
End Sub


Private Sub Command3_Click()
FrameDW.Visible = False
End Sub
Private Sub comboBH_click()
  cmdSearchBH_Click
End Sub
Private Sub comboBH_keypress(KeyAscii As Integer)
If KeyAscii = 13 Then
    cmdSearchBH_Click
End If
End Sub
Private Sub comboXM_keypress(KeyAscii As Integer)
If KeyAscii = 13 Then
    cmdSearchXM_Click
End If
End Sub
Private Sub comboxm_click()
cmdSearchXM_Click
End Sub
Private Sub Command1_Click()
On Error GoTo err

If MsgBox("成功从剪贴板获得数据，是否保存为联系人照片？", vbYesNo + 64, "选择操作") = vbYes Then
    Picture1 = Clipboard.GetData
    Call goMiddle
    Call SavePictrueNow
Else
  Exit Sub
End If

err:
If err.Description <> "" Then
    MsgBox "数据类型不正确", vbOKOnly + 64, "错误"
End If

End Sub
Private Sub delectAllSelect_Click()

If QX <> "管理员" And TopRight <> "超级管理员" Then
    MsgBox "非管理员没有执行此操作的权限", 0 + 64, "提示"
    Exit Sub
End If

Call delHxx
End Sub

Private Sub EditThis_Click()
On Error GoTo err

If QX <> "管理员" And TopRight <> "超级管理员" Then
    MsgBox "非管理员没有执行此操作的权限", 0 + 64, "提示"
    Exit Sub
End If

hNO = lv.SelectedItem
Call bk
Dim i As Long
ReDim infoarr(i)
Set infoarr(i) = New Class1
Set infoarr(i).newForm = New LWJLedit
Load infoarr(i).newForm

err:
If err.Description <> "" Then
    MsgBox "列表中没有项目或没有选中项目", 0 + 64, "Error"
End If

End Sub

Private Sub Form_click()

List1.Visible = False
List2.Visible = False

Dim t As Control
For Each t In Controls
    If TypeName(t) = "TextBox" Then
        If t.Name <> "keyword" Then
            t.BackStyle = 0
            t.BorderStyle = 0
        End If
    End If
Next t
End Sub
Private Sub form_activate()
Call History
Set frmTest = Me
End Sub
Private Sub Form_Load()
'------------------------------初始化窗体
Me.Width = 14235
Me.Height = 10710
Me.Top = Screen.Height / 2 - Me.Height / 2 - 800
Me.Left = Screen.Width / 2 - Me.Width / 2
txtBH = SelectNo
'-----------------------------加载来往记录
Call History
'-----------------------------加载联系人资料
List1.Visible = False
List2.Visible = False

SubClasss Me.Picture1.hWnd

Call LxrInfo
    
End Sub



Private Sub GetP_Click()
formNo = txtBH
If Check1.Value <> 1 Then
    MDI.Hide
End If
Sleep 500
GetPicture.Show
End Sub

Private Sub getWay_click()
getWay.Visible = False
End Sub

Private Sub keyword_gotfocus()
Call bk
 keyword.IMEMode = 1
End Sub
Private Sub keyword_keypress(KeyAscii As Integer)
If KeyAscii = 13 Then
    cmd_CZ_Click
End If