infoma.frm

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

End Sub

Private Sub labAdd_Click()
Call bk
getWay.Visible = True
getWay.Top = labAdd.Top + labAdd.Height + 10
getWay.Left = labAdd.Left + labAdd.Width
End Sub

Private Sub LabDEL_Click()
Call bk

If Dir(App.Path & "\picture\" & txtBH & ".jpg", vbDirectory) = "" Then
  MsgBox "照片不存在！", 0 + 64, "提示"
  Exit Sub
Else
    If MsgBox("是否确定要删除该联系人的照片？", vbYesNo + 64, "确认") = vbYes Then
         Kill App.Path & "\picture\" & txtBH & ".jpg"
         Me.Picture1.Picture = LoadPicture("")
    End If
End If
End Sub

Private Sub LabEdit_Click()
Call bk
getWay.Visible = True
getWay.Top = LabEdit.Top + LabEdit.Height + 10
getWay.Left = LabEdit.Left + LabEdit.Width
End Sub

Private Sub list1_lostfocus()
List1.Visible = False
End Sub
Private Sub List1_Click()
txtFL.BackStyle = 1
txtFL.BorderStyle = 1
txtFL = List1.Text
End Sub
Private Sub List1_dblClick()
txtFL = List1.Text
List1.Visible = False
txtFL.BackStyle = 0
txtFL.BorderStyle = 0
End Sub
Private Sub list2_lostfocus()
List2.Visible = False
End Sub
Private Sub List2_Click()
txtXB.BackStyle = 1
txtXB.BorderStyle = 1
txtXB.Text = List2.Text

End Sub
Private Sub List2_dblClick()
txtXB = List2.Text
List2.Visible = False
txtXB.BackStyle = 0
txtXB.BorderStyle = 0
End Sub

Private Sub List3_dblClick()
cmdGO_Click
End Sub

Private Sub loadP_Click()
' 设置“CancelError”为 True
comd1.CancelError = True
On Error GoTo ErrHandler
' 设置标志
comd1.Flags = cdlOFNHideReadOnly
' 设置过滤器
comd1.Filter = "JPEG Files|*.jpg"
' 指定缺省的过滤器

' 显示“打开”对话框
comd1.ShowSave
' 显示选定文件的名字
getPath = comd1.FileName

If Dir(App.Path & "\picture\" & txtBH & ".jpg", vbDirectory) <> "" Then
    If MsgBox("该联系人的相片已经存在，是否要替换原来的相片？", vbYesNo + 64, "提示") = vbYes Then
        Kill App.Path & "\picture\" & txtBH & ".jpg"
        Picture1.AutoRedraw = True
        CopyFile getPath, App.Path & "\picture\" & txtBH & ".jpg", 1
        MsgBox "保存成功！", vbOKOnly, "操作成功"
        Picture1.Picture = LoadPicture(App.Path & "\picture\" & txtBH & ".jpg")
        Call goMiddle
    End If
Else
    CopyFile getPath, App.Path & "\picture\" & txtBH & ".jpg", 1
    Picture1.Picture = LoadPicture(App.Path & "\picture\" & txtBH & ".jpg")
     Call goMiddle
    MsgBox "保存成功！", vbOKOnly, "操作成功"
End If


ErrHandler:
' 用户按了“取消”按钮
Exit Sub

End Sub

Private Sub lookPath_Click()
If Dir(App.Path & "\picture\" & txtBH & ".jpg", vbDirectory) <> "" Then
    Shell "Explorer /select," & App.Path & "\picture\" & txtBH & ".jpg", vbNormalFocus
End If
End Sub

Private Sub lv_dblclick()
On Error GoTo err
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 lv_mousedown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call bk

If Button = 2 Then
    PopupMenu menuH
End If
End Sub

Private Sub picClear_Click()
Picture1.Picture = LoadPicture("")
End Sub

Private Sub picFresh_Click()
Poper_Click
End Sub

Private Sub picOldSize_Click()
If Dir(App.Path & "\picture\" & txtBH & ".jpg", vbDirectory) <> "" Then
        Picture1.Picture = LoadPicture(App.Path & "\picture\" & txtBH & ".jpg")
        Call goMiddle

Else
        Picture1.Picture = LoadPicture("")
        Picture1.Width = 2268
        Picture1.Height = 3176
        Call goMiddle

End If

End Sub

Private Sub Poper_Click()
If Dir(App.Path & "\picture\" & txtBH & ".jpg", vbDirectory) <> "" Then

        Picture1.Picture = LoadPicture(App.Path & "\picture\" & txtBH & ".jpg")
        r = Picture1.Height / Picture1.Width
        If Picture1.Width > 2268 Or Picture1.Height > 3176 Then
            
            Picture1.Width = Picture2.Width - 200
            Picture1.Height = Picture2.Width * r
             StretchPic Picture1
            Call goMiddle

        End If
        Call goMiddle

Else
        Picture1.Picture = LoadPicture("")
        Picture1.Width = 2268
        Picture1.Height = 3176
        Call goMiddle

End If

End Sub

Private Sub RefreshH_Click()
Call History
End Sub

Private Sub SaveImage_Click()
Call SavePictrueNow
End Sub

Private Sub selectAllH_Click()
Dim nitem As ListItem
 For n = 1 To lv.ListItems.Count
    With lv
        .ListItems.Item(n).Checked = True
        .ListItems.Item(n).Selected = True
    End With
 Next n
End Sub

'------------------------------------------------------ 文本框获得焦点失去焦点事件组start

Private Sub txtXM_gotfocus()
Call bk
End Sub
Private Sub txtXb_gotfocus()
Call bk
List2.clear
List2.AddItem "男"
List2.AddItem "女"

End Sub
Private Sub txtSR_gotfocus()
Call bk
End Sub
Private Sub txtJG_gotfocus()
Call bk
End Sub
Private Sub txtFL_gotfocus()
Call bk
List1.clear
strsql = "select distinct 分类 from 联系人档案"
Call OpenConn
rs.Open strsql, cn, 3, 3
If rs.RecordCount > 0 Then
    
    Do While Not rs.EOF
    
        List1.AddItem IIf(IsNull(rs!分类), "", rs!分类)
 
    rs.MoveNext
    Loop
    List1.AddItem "其他"
End If
End Sub

Private Sub txtSS_gotfocus()
Call bk

End Sub

Private Sub txtGS_gotfocus()
Call bk
End Sub

Private Sub txtZW_gotfocus()
Call bk
End Sub

Private Sub txtDZ_gotfocus()
Call bk
End Sub

Private Sub txtDH_gotfocus()
Call bk
End Sub
Private Sub txtemail_gotfocus()
Call bk
End Sub
Private Sub txtCZ_gotfocus()
Call bk

End Sub

Private Sub txtXG_gotfocus()
Call bk
End Sub
'------------------------------------------------------ 文本框获得焦点失去焦点事件组end

Private Sub ViewAll_Click()
Call History
End Sub

Sub History()

On Error GoTo err

 lv.ColumnHeaders.clear '清除列头
 
Call OpenConn
sql = "select * from 来往记录 where 编号='" & txtBH & "'"
rs.Open sql, cn, 1, 1

   lv.ListItems.clear '清除列表项目
    
 For i = 0 To rs.Fields.Count - 1
    
   Me.lv.ColumnHeaders.add = rs.Fields(i).Name
        
Next i
    
    lv.ColumnHeaders(1).Width = 800
    
    
If rs.RecordCount > 0 Then
    
    Do While Not rs.EOF
    
        Set addlist = lv.ListItems.add(, , IIf(IsNull(rs.Fields(rs.Fields(0).Name)), "", rs.Fields(rs.Fields(0).Name)), , 0)
        
       
            For k = 1 To rs.Fields.Count - 1
         
            addlist.SubItems(k) = IIf(IsNull(rs.Fields(rs.Fields(k).Name)), "", rs.Fields(rs.Fields(k).Name))
          
        Next k
        
        rs.MoveNext
    Loop

 End If

Call CloseConn
'----------------------设置前六列列宽
lv.ColumnHeaders(1).Width = 300
lv.ColumnHeaders(2).Width = 800
lv.ColumnHeaders(3).Width = 1000
'----------------------加载可选查询条件

Combo1.clear
Combo1.AddItem "所有项目"
Combo1.Text = "所有项目"
sql = "select * from 来往记录 where 编号='" & txtBH & "'"
Call OpenConn
rs.Open sql, cn, 3, 3

 For i = 0 To rs.Fields.Count - 1
   Combo1.AddItem rs.Fields(i).Name
 Next i
Call CloseConn
err:
If err.Description <> "" Then
    MsgBox "", 0 + 64, "Error"
End If
End Sub
Sub LxrInfo()
On Error GoTo err:

Call OpenConn
sql = "select * from 联系人档案 where 编号=" & txtBH
rs.Open sql, cn, 1, 1
txtXM = IIf(IsNull(rs.Fields("姓名")), "", rs.Fields("姓名"))
Me.Caption = txtXM & "个人资料" & "      编号:" & txtBH
txtXB = IIf(IsNull(rs.Fields("性别")), "", rs.Fields("性别"))
txtSR = IIf(IsNull(rs.Fields("生日")), "", rs.Fields("生日"))
txtJG = IIf(IsNull(rs.Fields("籍贯")), "", rs.Fields("籍贯"))
txtFL = IIf(IsNull(rs.Fields("分类")), "", rs.Fields("分类"))

txtSS = IIf(IsNull(rs.Fields("所在省市")), "", rs.Fields("所在省市"))
txtGS = IIf(IsNull(rs.Fields("公司名称")), "", rs.Fields("公司名称"))
txtZW = IIf(IsNull(rs.Fields("职务")), "", rs.Fields("职务"))
txtDZ = IIf(IsNull(rs.Fields("公司地址")), "", rs.Fields("公司地址"))
txtDH = IIf(IsNull(rs.Fields("电话")), "", rs.Fields("电话"))

txtCZ = IIf(IsNull(rs.Fields("传真")), "", rs.Fields("传真"))
txtXG = IIf(IsNull(rs.Fields("性格爱好")), "", rs.Fields("性格爱好"))
LabCD = "存档日期：" & IIf(IsNull(rs.Fields("存档时间")), "", rs.Fields("存档时间"))
txtEmail = IIf(IsNull(rs.Fields("电子邮箱")), "", rs.Fields("电子邮箱"))
LxrPicture = IIf(IsNull(rs.Fields("相片")), "", rs.Fields("相片"))

If Dir(App.Path & "\picture\" & txtBH & ".jpg", vbDirectory) <> "" Then

        Picture1.Picture = LoadPicture(App.Path & "\picture\" & txtBH & ".jpg")
        r = Picture1.Height / Picture1.Width
        If Picture1.Width > 2268 Or Picture1.Height > 3176 Then
            Picture1.Width = Picture2.Width - 200
            Picture1.Height = Picture2.Width * r
            StretchPic Picture1
            Call goMiddle

        End If
        Call goMiddle

Else
        Picture1.Picture = LoadPicture("")
        Picture1.Width = 2268
        Picture1.Height = 3176
        Call goMiddle

End If

Call CloseConn

err:
If err.Description <> "" Then
    MsgBox "没有相应的记录", vbOKOnly + 64, "提示"
    
End If

End Sub

Sub delHxx() '删除选中项目过程模块
On Error GoTo err

 Dim nCount     As Integer
          Dim nIndex     As Integer
          Dim oitem     As ListItem
    If lv.ListItems.Count = 0 Then
        MsgBox "列表中没有可操作的项目！", vbOKOnly, "提示"
        Exit Sub
    End If
    
    If MsgBox("此操作将删除所有选中项目的联系人信息以及来往记录，是否继续操作？", vbYesNo, "确认删除") = vbNo Then Exit Sub
    
          With lv
                  nCount = .ListItems.Count
                  For nIndex = nCount To 1 Step -1
                          If .ListItems.Item(nIndex).Selected = True Or .ListItems.Item(nIndex).Checked = True Then
                        

                         '------------------------------------------------------删除对应编号联系人的来往记录
                                 Call OpenConn
                                sql = "select * from 来往记录 where 记录序号=" & .ListItems.Item(nIndex).Text
                                rs.Open sql, cn, 3, 3
                                Do While Not rs.EOF
                                   rs.delete
                                   rs.Update
                                   rs.MoveNext
                                Loop
                                Call CloseConn
                        '------------------------------------------------------列表中删除选中项
                                .ListItems.Remove nIndex '
                          End If
                  Next
          End With
  
err:
  If err.Description <> "" Then
    MsgBox "没有选中的项目或操作错误"
  End If
  
End Sub

Sub bk()
Dim t As Control
For Each t In Controls
    If TypeName(t) = "TextBox" Then
        If t.Name = ActiveControl.Name And t.Name <> "keyword" Then