tjlxr.frm

功能强大的个人工作通讯录

For Each txt In Controls
   If TypeName(txt) = "TextBox" Then
      txt.Text = ""
   End If
Next txt
Call OpenConn
sql = "select max(编号) as 编号 from 联系人档案"
rs.Open sql, cn, 1, 1
If rs.RecordCount > 0 Then
    rs.MoveLast
txtBH.Caption = rs.Fields("编号") + 1
cmdSave.Caption = "保存"
Me.Caption = "添加联系人  " & "编号:" & txtBH
End If
Call CloseConn
Picture1.Picture = LoadPicture("")
End Sub

Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub cmdClear_Click()
Dim txt As Control
For Each txt In Controls
   If TypeName(txt) = "TextBox" Then
      txt.Text = ""
   End If
Next txt
End Sub

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

Private Sub cmdSave_Click()
On Error GoTo err

If txtXM = "" Then
    MsgBox "姓名不能为空", 0 + 64, "提示"
    Exit Sub
End If

Select Case cmdSave.Caption

Case "保存"

Call OpenConn
sql = "select * from 联系人档案 where 编号=" & txtBH
rs.Open sql, cn, 1, 1
If rs.RecordCount > 0 Then
   MsgBox "该编号已经存在!", vbOKOnly, "提示"
   Call CloseConn
   Exit Sub

Else
   Call CloseConn
End If
        
        
        Call OpenConn
        sql = "select * from 联系人档案"
        rs.Open sql, cn, 3, 3
        rs.AddNew
            rs!编号 = txtBH
            rs!姓名 = 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
        Me.Caption = "添加联系人  " & "编号:" & txtBH
        Call CloseConn
        tipsTXT = cmdSave.Caption
        Timer2.Enabled = True
        ZJM.RefreshList.Value = True
        cmdSave.Caption = "修改"
        
        
Case "修改"
        Call OpenConn
        sql = "select * from 联系人档案 where 编号=" & txtBH
        rs.Open sql, cn, 3, 3
            
        If rs.RecordCount > 0 Then
            rs!姓名 = 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
        Me.Caption = "添加联系人  " & "编号:" & txtBH
        
        tipsTXT = cmdSave.Caption
        Timer2.Enabled = True
        
        Call CloseConn
        ZJM.RefreshList.Value = True
        
        Else
           MsgBox "操作失败，修改的联系人可能已经被删除", vbOKOnly, "错误"
        End If
        
End Select

err:
If err.Description <> "" Then
 MsgBox "操作失败,可能当前联系人已经存在或其他不可预料的错误", vbOKOnly, "错误"
End If

End Sub

Private Sub cmdSaveP_Click()
Call SavePictrueNow
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 Form_Load()
Me.Height = 8745
Me.Width = 12450
Me.Top = Screen.Height / 2 - Me.Height / 2 - 800
Me.Left = Screen.Width / 2 - Me.Width / 2
Call OpenConn
sql = "select max(编号) as 编号 from 联系人档案"
rs.Open sql, cn, 1, 1
If rs.RecordCount > 0 Then
    rs.MoveLast
txtBH.Caption = rs.Fields("编号") + 1
Else
txtBH.Caption = 1
End If
Me.Caption = "添加联系人  " & "编号:" & txtBH
Call CloseConn

SubClasss Me.Picture1.hWnd
End Sub
Private Sub form_activate()
Call comboAdd2
Set frmTest = Me
End Sub


Private Sub List1_Click()
txtFL = List1.Text
List1.Visible = False
End Sub

Private Sub List2_Click()
txtXB = List2
List1.Visible = False
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 labAdd_Click()
Call OpenConn
sql = "select 编号 from 联系人档案 where 编号=" & txtBH
rs.Open sql, cn, 3, 3
If rs.RecordCount > 0 Then
   
getWay.Visible = True
getWay.Top = labAdd.Top
getWay.Left = labAdd.Left + labAdd.Width

Else
   MsgBox "记录中找不到对应编号，请先保存再添加其相片！", vbOKOnly, "提示"
End If

End Sub

Private Sub LabDEL_Click()
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 OpenConn
sql = "select 编号 from 联系人档案 where 编号=" & txtBH
rs.Open sql, cn, 3, 3
If rs.RecordCount > 0 Then
   
getWay.Visible = True
getWay.Top = LabEdit.Top
getWay.Left = LabEdit.Left + LabEdit.Width

Else
   MsgBox "记录中找不到对应编号，请先保存再修改其相片！", vbOKOnly, "提示"
End If

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 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 SaveImage_Click()
Call SavePictrueNow
End Sub

Private Sub Timer1_Timer()
Labtime = Now
End Sub

Private Sub Timer2_Timer()
Static tim
tim = tim + 1
If tim < 3 Then
Tips.Visible = True
Tips.Caption = tipsTXT & "成功"
Else
Tips.Visible = False
tim = 0
Timer2.Enabled = False
End If

End Sub

Sub comboAdd2()
txtXB.clear
txtXB.AddItem "男"
txtXB.AddItem "女"
txtFL.clear
txtFL.AddItem "经销商"
txtFL.AddItem "印花厂"
txtFL.AddItem "朋友"
txtFL.AddItem "其他"
Call OpenConn
sql = "select distinct 分类 from 联系人档案"
rs.Open sql, cn, 3, 3
If rs.RecordCount > 0 Then
    Do While Not rs.EOF
        If rs!分类 <> "经销商" And rs!分类 <> "印花厂" And rs!分类 <> "朋友" And rs!分类 <> "其他" Then
            If rs!分类 <> "" Then
                txtFL.AddItem rs!分类
            End If
        End If
        rs.MoveNext
    Loop

End If

Call CloseConn

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

End Sub
Sub goMiddle()
Picture1.Left = (Picture2.Width - Picture1.Width) / 2 - 32.5
Picture1.Top = (Picture2.Height - Picture1.Height) / 2
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Picture1.SetFocus
If Not Button = vbLeftButton Then Exit Sub
Dim dx As Long, dy As Long, ll As Long, tt As Long
With Picture1
dy = Y - gy
dx = X - gx
ll = .Left
tt = .Top

.Move ll + dx, tt + dy
End With
End Sub

Private Sub picture1_mousedown(Button As Integer, Shift As Integer, X As Single, Y As Single)
gx = X
gy = Y

Call OpenConn
sql = "select 编号 from 联系人档案 where 编号=" & txtBH
rs.Open sql, cn, 3, 3
If rs.RecordCount > 0 Then

 If Button = 2 Then
    PopupMenu ImageMenu
End If

Else
   MsgBox "记录中找不到对应编号！", vbOKOnly, "提示"
End If

End Sub