frmnewjl.frm

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

         Left            =   3360
         TabIndex        =   13
         Top             =   480
         Width           =   630
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "姓 名："
         Height          =   180
         Left            =   240
         TabIndex        =   12
         Top             =   480
         Width           =   630
      End
   End
End
Attribute VB_Name = "frmNewJL"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim Path_Picture As String

Private Sub cmdOpenPicture_Click()
    cdlTest.DialogTitle = "打开照片"
On Error Resume Next
    cdlTest.CancelError = True
    cdlTest.FileName = Path_Picture
    cdlTest.Filter = "bmp图象(.bmp)|*.Bmp|JPEG图象(.JPEG)|*.JPG|GIF图象(.GIF)|*.GIF|所有文件|*.*"
    cdlTest.ShowOpen
    If Err = cdlCancel Then Exit Sub
    Path_Picture = cdlTest.FileName
    '在picture控件中添加一个Image控件，把照片加载到image控件中
    imgUserPicture.Picture = LoadPicture(Path_Picture)
End Sub

Private Sub ExBtn1_Click()
    Dim i As Integer
    Dim IsNull As Boolean
    Dim mrc As ADODB.Recordset
    Dim txtSQL As String
  
    '检验输入数据
    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
  
    '查询该记录是否存在
    txtSQL = "select * from Tbl_Txb where 姓名 = '" & Trim(Text(0).Text) & "'"
    Set mrc = ExecuteSQL(txtSQL)
    
    If mrc.EOF = False Then
        MsgBox "该姓名已存在！", vbOKOnly + vbExclamation, "电子通讯录-提示"
        Text(0).SetFocus
        Text(0).Text = ""
        Exit Sub
    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.AddNew
    mrc.Fields(0) = Trim(Text(0).Text)
    mrc.Fields(1) = Trim(cmbSex.Text)
  
  '若有照片，则保存照片的二进制码
  
'--------------------------------------------
'        把图片保存到数据库中
'--------------------------------------------
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

    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
    mrc.Close
    MsgBox "记录添加成功！", vbOKOnly + vbExclamation, "电子通讯录-提示"
    
    If imgUserPicture.Picture <> 0 Then
        imgUserPicture.Picture = LoadPicture("")
    End If
    Text(0).SetFocus
    Text(0).Text = ""
    Text(1).Text = ""
    Text(2).Text = ""
    Text(3).Text = ""
    Text(4).Text = ""
    cmbSex.Text = ""
    txtQQ.Text = ""
    txtEMail.Text = ""
    txtMemo.Text = ""
End Sub

Private Sub ExBtn2_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    cmbSex.Clear
    cmbSex.AddItem "男"
    cmbSex.AddItem "女"
    '设置Image控件的大小
    imgUserPicture.Height = pit.Height
    imgUserPicture.Width = pit.Width
    imgUserPicture.Left = 1
    imgUserPicture.Top = 1
End Sub

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

Private Sub txtQQ_KeyPress(KeyAscii As Integer)
    If KeyAscii >= 48 And KeyAscii <= 57 Then
    Else
        KeyAscii = 0
    End If
End Sub