frmcard.frm

一个好的通讯录程序 用VB所编 赶快下载

    MSFlex.SetFocus
    MSFlex_RowColChange
    CmdSave.Enabled = False
    Me.MousePointer = flexDefault
    
Exit Sub
ErrorHandle:
    Me.MousePointer = flexDefault
    MsgBox "错误 # " & Str(Err.Number) & " 生成于 " & Err.Source & Chr(13) & Err.Description, vbCritical, "错误" & "FIND_CLICK", Err.HelpFile, Err.HelpContext
End Sub

Private Sub CmdSave_Click()
    Dim I, j As Integer
    Dim Index As Integer
    Dim TT As String
    Dim TT2 As String
Select Case CmdSave.Caption
Case "存盘"
    If Len(Trim(Text1(0))) = 0 Then
        MsgBox "姓名不能为空！请输入！！！  ", vbOKOnly + vbExclamation, "信息帮助"
        Text1(0).SetFocus
        Exit Sub
    End If
    If Len(Trim(Text1(1))) = 0 Then
        MsgBox "单位不能为空！请输入！！！  ", vbOKOnly + vbExclamation, "信息帮助"
        Text1(1).SetFocus
        Exit Sub
    End If
    Select Case intActionType
        Case conActionNew
            StrSql = "INSERT INTO c002(f001,f002,f003,f004,f005,f006,f007,f008,f009,f010,f011,f012,f013,f014,f015)" _
                    & " VALUES('" & Trim(Text1(0)) & "','" & Trim(Text1(1)) & "','" & Trim(Text1(2)) & "','" & Trim(Text1(3)) & "','" _
                    & Trim(Text1(4)) & "','" & Trim(Text1(5)) & "','" & Trim(Text1(6)) & "','" & Trim(Text1(7)) & "','" _
                    & Trim(Text1(8)) & "','" & Trim(Text1(9)) & "','" & Trim(Text1(10)) & "','" & Trim(Text1(11)) & "','" _
                    & Trim(Text1(12)) & "','" & Trim(Text1(13)) & "','" _
                    & IIf(Len(Lov_list("c003", "f002", "f001", Trim(Cbo1))) = 0, "", Lov_list("c003", "f002", "f001", Trim(Cbo1))) & "')"
            On Error GoTo ErrorHandle
            'MsgBox StrSql
            adoCon.Execute StrSql
            On Error GoTo 0
            
            With MSFlex
                .Enabled = True
                .Tag = True
                If Not (.Rows = 2 And .TextMatrix(1, 1) = "" And .TextMatrix(1, 2) = "") Then
                    .AddItem ("")
                End If
                For I = 1 To 15
                    .ColAlignment(I) = flexAlignLeftCenter
                    If I = 15 Then
                        .TextMatrix(.Rows - 1, I - 1) = Cbo1
                    ElseIf I = 14 Then
                        .TextMatrix(.Rows - 1, I + 1) = IIf(IsNull(Trim(Text1(I - 1))), "", Trim(Text1(I - 1)))
                    Else
                        .TextMatrix(.Rows - 1, I) = IIf(IsNull(Trim(Text1(I - 1))), "", Trim(Text1(I - 1)))
                    End If
                Next I
                intCurrentRow = .Rows - 1
                intCurrentCol = 0
                .ColSel = .Cols - 1
                .Row = .Rows - 1
                .ColSel = .Cols - 1
                .TopRow = .Rows - 1
                .SetFocus
            End With
            MSFlex.Row = MSFlex.Rows - 1
            MSFlex_RowColChange
            intActionType = conActionNormal
        Case conActionEdit
            StrSql = "UPDATE c002 SET " _
                        & "f001= '" & Trim(Text1(0)) & "'," _
                        & "f002= '" & Trim(Text1(1)) & "'," _
                        & "f003= '" & Trim(Text1(2)) & "'," _
                        & "f004= '" & Trim(Text1(3)) & "'," _
                        & "f005= '" & Trim(Text1(4)) & "'," _
                        & "f006= '" & Trim(Text1(5)) & "'," _
                        & "f007= '" & Trim(Text1(6)) & "'," _
                        & "f008= '" & Trim(Text1(7)) & "'," _
                        & "f009= '" & Trim(Text1(8)) & "'," _
                        & "f010= '" & Trim(Text1(9)) & "'," _
                        & "f011= '" & Trim(Text1(10)) & "'," _
                        & "f012= '" & Trim(Text1(11)) & "'," _
                        & "f013= '" & Trim(Text1(12)) & "'," _
                        & "f014= '" & Trim(Text1(13)) & "'," _
                        & "f015= '" & IIf(Len(Lov_list("c003", "f002", "f001", "" & Trim(Cbo1) & "")) = 0, "", Lov_list("c003", "f002", "f001", "" & Trim(Cbo1) & "")) & "'" _
                        & " where f001='" & strEdit(0) & "' and f002='" & strEdit(1) & "'"
            'MsgBox StrSql
            On Error GoTo ErrorHandle
            adoCon.Execute StrSql
            On Error GoTo 0
            With MSFlex
                For I = 1 To 15
                    .ColAlignment(I) = flexAlignLeftCenter
                    If I = 15 Then
                        .TextMatrix(.Rows - 1, I - 1) = Cbo1
                    ElseIf I = 14 Then
                        .TextMatrix(.Row, I + 1) = IIf(IsNull(Trim(Text1(I - 1))), "", Trim(Text1(I - 1)))
                    Else
                        .TextMatrix(.Row, I) = IIf(IsNull(Trim(Text1(I - 1))), "", Trim(Text1(I - 1)))
                    End If
                    
                Next I
            End With
            intActionType = conActionNormal
    End Select
    
    strEdit(0) = ""
    strEdit(1) = ""
    Text1(1).SetFocus
    MSFlex.Enabled = True
    CmdSave.Enabled = False
    
    Cancel_Click
Case "执行"
   ' Find_click
End Select
    Exit Sub
ErrorHandle:
    Dim Er As ADODB.Error
    For Each Er In adoCon.Errors
        If Er.SQLState = 3022 Then
            MsgBox "此名片记录已存在，请输入一条新记录！  ", vbCritical, "错误信息"
            Exit Sub
        End If
        intresult = MsgBox(Er.Description & "  " & Er.SQLState, vbCritical, "错误信息")
    Next Er
End Sub

Private Sub Command1_Click()
Dim adoRes As New ADODB.Recordset
On Error GoTo ErrorHandle
    StrSql = "select * from c002 where "
        
    If Len(Trim(Text1(14))) Then
        StrSql = StrSql & " f001  Like " & " '" & "%" & Trim(Text1(14)) & "%" & "'" & " and"
    End If
    If Len(Trim(Text1(15))) Then
        StrSql = StrSql & " f002  Like " & " '" & "%" & Trim(Text1(15)) & "%" & "'" & " and"
    End If
    If Len(Trim(Text1(16))) Then
        StrSql = StrSql & " f014  Like " & " '" & "%" & Trim(Text1(16)) & "%" & "'" & " and"
    End If
            
    If Len(Trim(Cbo2)) > 0 Then
        StrSql = StrSql & " f015 like " & "'" & "%" & Lov_list("c003", "f002", "f001", Cbo2) & "%" & "'" & " and"
    End If
    
    StrSql = Mid(StrSql, 1, Len(Trim(StrSql)) - 3) & " order by f001"
    
    Me.MousePointer = vbHourglass
    Set adoRes = adoCon.Execute(StrSql)
    If adoRes.EOF Then
        MsgBox "没有查询到记录，请重新输入条件！  ", vbOKOnly + vbInformation, "信息帮助"
        Text1(14).SetFocus
        MSFlex1.Enabled = False
        Me.MousePointer = flexDefault
        Exit Sub
    End If
    FillGrid MSFlex1, adoRes
    Me.MousePointer = flexDefault
    
Exit Sub
ErrorHandle:
    Me.MousePointer = flexDefault
    MsgBox "错误 # " & Str(Err.Number) & " 生成于 " & Err.Source & Chr(13) & Err.Description, vbCritical, "错误" & "Command1_CLICK", Err.HelpFile, Err.HelpContext
End Sub

Private Sub Form_Activate()
    SSTab1.Tab = 0
    Text1(14).SetFocus
End Sub

Private Sub Form_Load()
    Dim ResSet As New ADODB.Recordset
    Dim I As Integer
    
    Me.Top = 0
    Me.Left = 0
    
    intActionType = 2
    MyOpen ResSet, "select * from c003 "
    If ResSet.EOF Then
        MsgBox "名片分类无记录，请先设定 ！！！", vbCritical, "错误"
        Exit Sub
    End If
    Cbo1.Clear
    Do While Not ResSet.EOF
        Cbo1.AddItem Trim(ResSet("f002"))
        ResSet.MoveNext
        I = I + 1
    Loop
    Cbo1.ListIndex = 0
    Cbo2.Clear
    ResSet.MoveFirst
    Do While Not ResSet.EOF
        Cbo2.AddItem Trim(ResSet("f002"))
        ResSet.MoveNext
        I = I + 1
    Loop
    Cbo1.ListIndex = 1
    InitializeMSFlex MSFlex
    InitializeMSFlex MSFlex1
    
    MyOpen ResSet, "select * from c002 order by f001"
    If Not (ResSet.EOF Or ResSet.BOF) Then
        FillGrid MSFlex1, ResSet
        MSFlex_RowColChange
    End If
    
End Sub

Private Sub InitializeMSFlex(Flex As MSFlexGrid)
    Dim I As Integer
    With Flex
        .Rows = 2
        .Cols = 16
        .ColWidth(0) = 150
        .ColWidth(1) = 900
        .ColWidth(2) = 1800
        .ColWidth(3) = 2100
        .ColWidth(4) = 1000
        .ColWidth(5) = 1600
                
        .TextMatrix(0, 0) = ""
        .TextMatrix(0, 1) = "姓名"
        .TextMatrix(0, 2) = "单位"
        .TextMatrix(0, 3) = "办公电话"
        .TextMatrix(0, 4) = "家庭电话"
        .TextMatrix(0, 5) = "手机"
        .TextMatrix(0, 6) = "传真"
        .TextMatrix(0, 7) = "Email"
        .TextMatrix(0, 8) = "网址"
        .TextMatrix(0, 9) = "公司地址"
        .TextMatrix(0, 10) = "邮编"
        .TextMatrix(0, 11) = "家庭地址"
        .TextMatrix(0, 12) = "邮编"
        .TextMatrix(0, 13) = "职位"
        .TextMatrix(0, 14) = "分类"
        .TextMatrix(0, 15) = "说明"
                        
        For I = 0 To .Cols - 1
            .ColAlignment(I) = flexAlignLeftCenter
        Next
    End With
   
    intCurrentRow = 0
    intCurrentCol = 0
    
End Sub

Public Sub FillGrid(objFXG As MSFlexGrid, objadoRes As ADODB.Recordset)
    Dim I, j As Integer
    objFXG.Tag = True
    Dim TT As String
On Error GoTo ErrorHandle
    I = 1
    objFXG.Redraw = False
    If objadoRes.EOF Then objFXG.Rows = 1
    objFXG.TextMatrix(0, 0) = ""
    Do Until objadoRes.EOF
        objFXG.Row = I
        For j = 1 To objFXG.Cols - 1
            objFXG.CellAlignment = flexAlignLeftCenter
            If j = objFXG.Cols - 1 Then
                objFXG.TextMatrix(I, j) = IIf(IsNull(Trim(objadoRes.Fields(j - 2))), "", Trim(objadoRes.Fields(j - 2)))
            ElseIf j = objFXG.Cols - 2 Then
                objFXG.TextMatrix(I, j) = Lov_list("c003", "f001", "f002", IIf(IsNull(Trim(objadoRes.Fields(j))), "", Trim(objadoRes.Fields(j))))
            Else
                objFXG.TextMatrix(I, j) = IIf(IsNull(Trim(objadoRes.Fields(j - 1))), "", Trim(objadoRes.Fields(j - 1)))
            End If
        Next j
       objadoRes.MoveNext
       objFXG.Rows = I + 2
       I = I + 1
    Loop
    objFXG.Rows = objFXG.Rows - 1
    objFXG.Redraw = True
    objFXG.Col = 1
    objFXG.Tag = False
    objFXG.Row = 1
    objFXG.RowSel = 1
    objFXG.ColSel = objFXG.Cols - 1
    objFXG.SelectionMode = flexSelectionByRow
    objFXG.HighLight = flexHighlightAlways
    objFXG.FocusRect = flexFocusNone
Exit Sub
ErrorHandle:
    MsgBox "错误 # " & Str(Err.Number) & " 生成于 " & Err.Source & Chr(13) & Err.Description, vbCritical, "错误" & "FillGrid", Err.HelpFile, Err.HelpContext
End Sub

Private Sub MSFlex_Click()
Dim I As Integer
    With MSFlex
        If .MouseRow = 0 And .MouseCol <> 0 Then
            If intCurrentCol <> .MouseCol Then
                intCurrentCol = .MouseCol
                .Col = .MouseCol
                OldSort = IIf(OldSort = 1, 2, 1)
                .Sort = OldSort
                intCurrentCol = 1
                .Col = intCurrentCol
                .ColSel = .Cols - 1
                intCurrentCol = 0
                intCurrentRow = 0
                .TopRow = 1
            End If
        End If
    End With
End Sub

Private Sub MSFlex_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = 13 Then
        SendKeys "{tab}"
    End If
    
    Select Case KeyCode
    Case 118, 119
        If intActionType = 2 Then CmdQry_Click
    Case 45
        If intActionType = 2 Then CmdIns_Click
    End Select
End Sub

Private Sub MSFlex_RowColChange()
    Dim I As Integer
On Error GoTo ErrorHandle
     If intCurrentRow = MSFlex.Row Then
        If intCurrentRow = 1 Then GoTo Lo
    Else
        intCurrentRow = MSFlex.Row
Lo:
        For I = 1 To 15
            If I = 15 Then
                Text1(I - 2) = MSFlex.TextMatrix(MSFlex.Row, I)
            Else
                Text1(I - 1) = MSFlex.TextMatrix(MSFlex.Row, I)
            End If
        Next
        Cbo1 = MSFlex.TextMatrix(MSFlex.Row, MSFlex.Cols - 2)
    End If
    
Exit Sub
ErrorHandle:
    MsgBox "错误 # " & Str(Err.Number) & " 生成于 " & Err.Source & Chr(13) & Err.Description, vbCritical, "错误" & "MSFlex_RowColChange", Err.HelpFile, Err.HelpContext
End Sub

Private Sub MSFlex1_Click()
    Dim I As Integer
    With MSFlex1
        If .MouseRow = 0 And .MouseCol <> 0 Then
            If intCurrentCol <> .MouseCol Then
                intCurrentCol = .MouseCol
                .Col = .MouseCol
                OldSort = IIf(OldSort = 1, 2, 1)
                .Sort = OldSort
                intCurrentCol = 1
                .Col = intCurrentCol
                .ColSel = .Cols - 1
                intCurrentCol = 0
                intCurrentRow = 0
                .TopRow = 1
            End If
        End If
    End With
End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
    If SSTab1.Tab = 0 Then Text1(14).SetFocus
    If SSTab1.Tab = 1 Then Text1(0).SetFocus
End Sub

Private Sub Text1_GotFocus(Index As Integer)
    Text1(Index).ForeColor = vbWhite
    Text1(Index).BackColor = vbBlue
End Sub

Private Sub Text1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)

    If KeyCode = 13 Then
        SendKeys "{tab}"
    End If
    
    Select Case KeyCode
    Case 27
        If intActionType <> 2 Then
            Cancel_Click
        Else
            Unload Me
        End If
    Case 113
        If intActionType <> 2 Then CmdSave_Click
    Case 118, 119
        If intActionType = 2 Then CmdQry_Click
    Case 45
        If intActionType = 2 Then CmdIns_Click
    End Select

End Sub

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
'      If KeyAscii = 32 Then
'        KeyAscii = 0
'        Text1_DblClick Index
'    End If
End Sub

Private Sub Text1_LostFocus(Index As Integer)
    Text1(Index).ForeColor = vbBlack
    Text1(Index).BackColor = vbWhite
End Sub

Private Sub Cancel_Click()
    With MSFlex
        If intActionType <> 2 Then
            For Each oText In Text1
                oText.Enabled = True
            Next
            For I = 1 To 15
                If I = 15 Then
                    Text1(I - 2) = MSFlex.TextMatrix(MSFlex.Row, I)
                Else
                    Text1(I - 1) = MSFlex.TextMatrix(MSFlex.Row, I)
                End If
            Next
            Cbo1 = MSFlex.TextMatrix(MSFlex.Row, MSFlex.Cols - 2)
        End If
        .Enabled = True
        intActionType = 2
    End With
    CmdIns.Enabled = True
    CmdModi.Enabled = True
    CmdSave.Enabled = False
    CmdDel.Enabled = True
    CmdQry.Enabled = True
    Text1(0).SetFocus
End Sub