frmeditjl.frm

电子通迅寻的制作,请大家下载这个哦,一个现成的

Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mrc As ADODB.Recordset
Dim NameIsChange As String
Dim Path_Picture As String
Dim ChangePicture As Boolean
Dim PushCancel As Boolean

Dim m_intOp As Long  '记录状态，4为查询窗体调用并进行删除操作

'----------------------------------
'       设置控件的可编辑状态
'----------------------------------
Private Sub Locked_Value(Result As Boolean)
    Text(0).Locked = Result
    Text(1).Locked = Result
    Text(2).Locked = Result
    Text(3).Locked = Result
    Text(4).Locked = Result
    cmbSex.Locked = Result
    txtMemo.Locked = Result
    txtQQ.Locked = Result
    txtMemo.Locked = Result
    txtEMail.Locked = Result
End Sub

Private Sub cmdCancel_Click()
    Call ShowAdoResult
    Call Locked_Value(True)
    PushCancel = True
    cmdOpenPicture.Enabled = False
    cmdEdit.Enabled = True
    cmdDelete.Enabled = True
    cmdCancel.Enabled = False
    cmdSave.Enabled = False
    Frame2.Enabled = True
End Sub

Private Sub cmdDelete_Click()
    If MsgBox("确定删除该记录吗？", vbOKCancel + vbQuestion, "电子通讯录-提示") = vbOK Then
        mrc.Delete
        MsgBox "删除成功！", vbOKOnly + vbInformation, "电子通讯录-提示"
        If Len(ViewJLName) <> 0 Then  '若删除的数据来字查询窗体，那么删除后则返回到查询窗体
            m_intOp = 1
            Unload Me
        End If
            mrc.MoveNext
            Call ShowAdoResult
    End If
End Sub

Private Sub cmdEdit_Click()
    cmdCancel.Enabled = True
    cmdSave.Enabled = True
    cmdDelete.Enabled = False
    cmdEdit.Enabled = False
    cmdOpenPicture.Enabled = True
    Frame2.Enabled = False
    Call Locked_Value(False)
End Sub

'移到首记录
Private Sub cmdFirst_Click()
    mrc.MoveFirst
    Call ShowAdoResult
    If mrc.BOF = True Then
        cmdFirst.Enabled = False
        cmdPrevious.Enabled = False
    End If
    lblNow.Caption = "当前记录：" & mrc.AbsolutePosition
    NameIsChange = Trim(Text(0).Text)
    cmdNext.Enabled = True
    cmdLast.Enabled = True
End Sub

'移到尾记录
Private Sub cmdLast_Click()
    mrc.MoveLast
    Call ShowAdoResult
    If mrc.EOF = True Then
        cmdLast.Enabled = False
        cmdNext.Enabled = False
    End If
    lblNow.Caption = "当前记录：" & mrc.AbsolutePosition
    NameIsChange = Trim(Text(0).Text)
    cmdFirst.Enabled = True
    cmdPrevious.Enabled = True
End Sub

'移动下一记录
Private Sub cmdNext_Click()
    mrc.MoveNext
    Call ShowAdoResult
    If mrc.EOF = True Then
        mrc.MovePrevious  '到表尾时向前移动一步
        cmdLast.Enabled = False
        cmdNext.Enabled = False
    End If
    lblNow.Caption = "当前记录：" & mrc.AbsolutePosition
    NameIsChange = Trim(Text(0).Text)
    cmdFirst.Enabled = True
    cmdPrevious.Enabled = True
End Sub

Private Sub cmdOpenPicture_Click()
On Error Resume Next
    cdlTest.CancelError = True
    cdlTest.DialogTitle = "打开照片"
    cdlTest.FileName = App.Path
    cdlTest.DefaultExt = "bmp图像(.bmp)|*.bmp"
    cdlTest.Filter = "bmp图像(.bmp)|*.bmp|JPEG图像(.JPG)|*.JPG|GIF图像(.GIF)|*.GIF|所有文件|*.*"
    cdlTest.ShowOpen
    If Err = cdlCancel Then Exit Sub
    Path_Picture = cdlTest.FileName
    imgUserPicture.Picture = LoadPicture(Path_Picture)
    ChangePicture = True
End Sub

'移到上一记录
Private Sub cmdPrevious_Click()
    mrc.MovePrevious
    Call ShowAdoResult
    If mrc.BOF = True Then
        mrc.MoveNext  '到表头时向后移动一步
        cmdFirst.Enabled = False
        cmdPrevious.Enabled = False
    End If
    lblNow.Caption = "当前记录：" & mrc.AbsolutePosition
    NameIsChange = Trim(Text(0).Text)
    cmdNext.Enabled = True
    cmdLast.Enabled = True
End Sub

Private Sub cmdQuit_Click()
    ViewJLName = ""
    PictureForfrmFind = False
    mrc.Close
    Unload Me
End Sub

Private Sub cmdSave_Click()
    Dim i As Integer
    Dim IsNull As Boolean
    Dim txtSQL As String
    Dim mrcc As ADODB.Recordset
    
    '检验输入数据
    For i = 0 To 4
        IsNull = TxtIsNull(Trim(Text(i).Text))
        If IsNull Then
            Select Case i
               Case 0
                    MsgBox "请输入姓名！", vbOKOnly + vbExclamation, "电子通讯录-提示"
                    Text(i).SetFocus
                    Exit Sub
               Case 1
                    MsgBox "请输入电话！", vbOKOnly + vbExclamation, "电子通讯录-提示"
                    Text(i).SetFocus
                    Exit Sub
               Case 2
                    MsgBox "请输入生日！", vbOKOnly + vbExclamation, "电子通讯录-提示"
                    Text(i).SetFocus
                    Exit Sub
               Case 3
                    MsgBox "请输入邮编！", vbOKOnly + vbExclamation, "电子通讯录-提示"
                    Text(i).SetFocus
                    Exit Sub
               Case 4
                    MsgBox "请输入联系地址！", vbOKOnly + vbExclamation, "电子通讯录-提示"
                    Text(i).SetFocus
                    Exit Sub
            End Select
        End If
    Next
    If Len(cmbSex.Text) = 0 Then
        MsgBox "请选择性别！", vbOKOnly + vbExclamation, "电子通讯录-提示"
        cmbSex.SetFocus
        Exit Sub
    End If
  
    '查询该记录是否存在
    If Trim(Text(0).Text) <> Trim(NameIsChange) Then
        txtSQL = "select * from Tbl_Txb where 姓名 = '" & Trim(Text(0).Text) & "'"
        Set mrcc = ExecuteSQL(txtSQL)
        If mrcc.EOF = False Then
            MsgBox "该姓名已存在！", vbOKOnly + vbExclamation, "电子通讯录-提示"
            Text(0).SetFocus
            Text(0).Text = ""
            Exit Sub
        End If
    End If
    
    '验证日期格式是否正确
    If Trim(Text(2).Text) Like "??-??" Then    '判断是否按指定格式填写
        Dim strDate As String
    
        strDate = Left(Trim(Text(2).Text), 2) & Right(Trim(Text(2).Text), 2)
     
        If Not IsNumeric(strDate) Then
            MsgBox "日期请输入数字！", vbOKOnly + vbExclamation, "电子通讯录-提示"
            Text(2).SetFocus
            Exit Sub
        End If
        
        If Left(Trim(Text(2).Text), 2) > 12 Then   '判断月份输入是否正确
            MsgBox "月份不能超过12！", vbOKOnly + vbExclamation, "电子通讯录-提示"
            Text(2).SetFocus
            Exit Sub
        End If
        
        If (Right(Trim(Text(2).Text), 2) > 31) Or _
            ((Left(Trim(Text(2).Text), 2) = 2) And (Right(Trim(Text(2).Text), 2)) > 29) Then
            '判断日期是否输入正确
            MsgBox "日期不能大于31天，如果是2月份则不能大于29天！", vbOKOnly + vbExclamation, "电子通讯录-提示"
            Text(2).SetFocus
            Exit Sub
        End If
    Else
        MsgBox "日期请按 mm-dd 格式填写", vbOKOnly + vbExclamation, "电子通讯录-提示"
        Text(2).SetFocus
        Exit Sub
    End If
  
    '判断邮编是否输入正确
    If (Not IsNumeric(Text(3).Text)) Then
        MsgBox "请输入6位数字的邮编！", vbOKOnly + vbExclamation, "电子通讯录-提示"
        Text(3).SetFocus
        Text(3).Text = ""
        Exit Sub
    ElseIf (Len(Trim(Text(3).Text)) <> 6) Then
        MsgBox "请输入6位数字的邮编！", vbOKOnly + vbExclamation, "电子通讯录-提示"
        Text(3).SetFocus
        Text(3).Text = ""
        Exit Sub
    End If
  
    '若输入正确则保存记录
    mrc.Fields(0) = Trim(Text(0).Text)
    mrc.Fields(1) = Trim(cmbSex.Text)
   
'若有照片，则保存照片的二进制码
'------------------------------------------------
'        把图片保存到数据库中
'------------------------------------------------

If ChangePicture = True Then
    If imgUserPicture.Picture <> 0 Then
        Dim Chunk() As Byte
        Const ChunkSize As Integer = 2384
        Dim DataFile As Integer, Chunks, Fragment As Integer
        Dim MediaTemp As String
        Dim lngOffset, lngTotalSize As Long
        Dim filelen As Long
        
        DataFile = 1
        Open Path_Picture For Binary Access Read As DataFile
        filelen = LOF(DataFile) ' 文件中数据长度
        Chunks = filelen \ ChunkSize
        Fragment = filelen Mod ChunkSize
        ReDim Chunk(Fragment)
        Get DataFile, , Chunk()
        mrc.Fields(2).AppendChunk Chunk()
        ReDim Chunk(ChunkSize)
        For i = 1 To Chunks
            Get DataFile, , Chunk()
            mrc.Fields(2).AppendChunk Chunk()
        Next
        Close DataFile
    End If
    ChangePicture = False
End If

    mrc.Fields(3) = Trim(Text(1).Text)
    If Len(txtQQ.Text) = 0 Then
        mrc.Fields(4) = "Nothing"
    Else
        mrc.Fields(4) = Trim(txtQQ.Text)
    End If
    mrc.Fields(5) = Trim(Text(2).Text)
    If Len(txtEMail.Text) = 0 Then
        mrc.Fields(6) = "Nothing"
    Else
        mrc.Fields(6) = Trim(txtEMail.Text)
    End If
    mrc.Fields(7) = Trim(Text(3).Text)
    mrc.Fields(8) = Trim(Text(4).Text)
    If Len(txtMemo.Text) = 0 Then
        mrc.Fields(9) = "Nothing"
    Else
        mrc.Fields(9) = Trim(txtMemo.Text)
    End If
    mrc.Update
    MsgBox "修改成功！", vbOKOnly + vbExclamation, "电子通讯录-提示"
    cmdOpenPicture.Enabled = False
    cmdSave.Enabled = False
    cmdCancel.Enabled = False
    cmdEdit.Enabled = True
    cmdDelete.Enabled = True
    Frame2.Enabled = True
    Call Locked_Value(True)
End Sub



Private Sub Form_Activate()
    NameIsChange = Trim(Text(0).Text)
End Sub

Private Sub Form_Load()
    Dim txtSQL As String
    
    cmdSave.Enabled = False
    cmdCancel.Enabled = False
    cmdOpenPicture.Enabled = False
    PushCancel = False
    Call Locked_Value(True)
    ChangePicture = False
    
    cmbSex.Clear
    cmbSex.AddItem "男"
    cmbSex.AddItem "女"
    
    If Len(Trim(ViewJLName)) = 0 Then   '若是主窗体调用
        lblNow.Visible = True
        lblSum.Visible = True
        txtSQL = "select * from tbl_txb"
    Else   '若是通过查询结果调用,则ViewJLName记录了要查看的姓名
        lblNow.Visible = False
        lblSum.Visible = False
        txtSQL = "select * from tbl_txb where 姓名 = '" & Trim(ViewJLName) & "'"
        Frame2.Visible = False  '屏蔽浏览功能
    End If
    
    Set mrc = ExecuteSQL(txtSQL)
    
    If mrc.EOF = True Then
        MsgBox "记录为空，请先添加记录后再对记录进行修改！", vbOKOnly + vbExclamation, "电子通讯录-提示"
        Exit Sub
    End If
    
    mrc.MoveFirst
    lblNow.Caption = "当前记录：" & mrc.AbsolutePosition
    Call ShowAdoResult
    
    imgUserPicture.Height = pit.Height
    imgUserPicture.Width = pit.Width
    imgUserPicture.Top = 0
    imgUserPicture.Left = 0
End Sub

Public Function ShowMe() As Long   '模态形式显示窗体
    Me.Show vbModal
    ShowMe = m_intOp
    m_intOp = -1
End Function

Private Function ShowAdoResult()
    If (mrc.EOF = True) Or (mrc.BOF = True) Then
        Exit Function  '如果到表头或表尾，则退出函数
    Else
        lblSum.Caption = "共有记录：" & mrc.RecordCount & "条"
        Text(0).Text = mrc.Fields(0)
        cmbSex.Text = mrc.Fields(1)
        
     '显示照片
        Dim Chunk() As Byte
        Const ChunkSize As Integer = 2384
        Dim Chunks, Fragment As Integer
        Dim MediaTemp As String
        Dim lngOffset, lngTotalSize As Long
        Dim filelen As Long
        Dim i As Integer
        
        lngTotalSize = mrc.Fields(2).ActualSize   '提取照片字段的实际长度
        
        If lngTotalSize = 0 Then  '如果数据库里没有图片，则不显示image控件
            imgUserPicture.Visible = False
        Else
            imgUserPicture.Visible = True
        End If

        If lngTotalSize = 0 Then
        '若字段为空，则执行下一步
        Else
            If PushCancel = True Then     '按了放弃,则不做任何处理
                PushCancel = False
            Else
               '从字段里把二进制数据提取出来保存到数组中
                Chunks = lngTotalSize \ ChunkSize
                Fragment = lngTotalSize Mod ChunkSize
                ReDim Chunk(Fragment)
                Chunk() = mrc.Fields(2).GetChunk(Fragment)
    
                Open "c:\UserPicture.JPG" For Binary As #1  '建立临时文件
                
                Put #1, , Chunk()      '把读取的二进制数组输出到临时文件里
                For i = 1 To Chunks
                    ReDim Chunk(ChunkSize)
                    Chunk() = mrc.Fields(2).GetChunk(ChunkSize)
                    Put #1, , Chunk()
                Next
                Close #1
                imgUserPicture.Picture = LoadPicture("c:\UserPicture.JPG")  '从临时文件加载图片
                
                Kill ("c:\userpicture.JPG")   '删除临时文件
                Erase Chunk()
            End If
        End If
        
        Text(1).Text = mrc.Fields(3)
        If Trim(mrc.Fields(4)) <> "Nothing" Then
            txtQQ.Text = mrc.Fields(4)
        End If
            Text(2).Text = mrc.Fields(5)
        If Trim(mrc.Fields(6)) <> "Nothing" Then
            txtEMail.Text = mrc.Fields(6)
        End If
            Text(3).Text = mrc.Fields(7)
            Text(4).Text = mrc.Fields(8)
        If Trim(mrc.Fields(9)) <> "Nothing" Then
            txtMemo.Text = mrc.Fields(9)
        End If
    End If
End Function

'-------------------------------------
'    功能：验证输入项是否为空
'    参数：txt 代检测的字符
'    输出：布尔值，True则为空
'-------------------------------------
Private Function TxtIsNull(txt As String) As Boolean
    If Len(txt) = 0 Then
        TxtIsNull = True
    Else
        TxtIsNull = False
    End If
End Function