module1.bas

在Visual Basic环境下实现的名片管理系统

Attribute VB_Name = "Module1"
Option Explicit
Public adoCon As New ADODB.Connection
Public Cmd As New ADODB.Command
Public UserCode As String
Public UserName As String
Public OldSort As Integer '存贮栅格排序方式

Sub Main()
    If App.PrevInstance = True Then
        MsgBox " 系统巳在运行中 !!!   ", vbQuestion
        End
    End If
    If Not ServerConnect Then
        MsgBox "数据库联接错误，请查看联机帮助文件 !!!  ", vbCritical
        End
    End If
    
    frmLogin.Show
        
End Sub

Public Function ServerConnect() As Boolean
    Dim strConnectString As String
    ServerConnect = False
    Dim A, B, C As Variant
    Dim database As String
    Dim SQLstatus As String
    
On Error GoTo ErrHandle
    SQLstatus = "ACCESS"
    Select Case UCase(SQLstatus)
    Case "ACCESS"
        strConnectString = "Provider=Microsoft.Jet.OLEDB.4.0;Password='';Data Source=" & App.Path & "\card.mdb"
    Case "SQL"
        'strConnectString = "driver={SQL SERVER};SERVER=" & ServerName & "; UID=sa;PWD=;DATABASE=" & DatabaseName & ""
        'strConnectString = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=" & DatabaseName & ";Data Source=" & ServerName
    Case "ORACLE"
        'strConnectString = "driver={ORACLE ODBC DRIVER};CONNECTSTRING=ORA;UID=wsfy;PWD=wsfy;"
        'strConnectString = "Provider=MSDAORA.1;Password=wsfy;User ID=wsfy;Data Source=" & ServerName & ";Persist Security Info=True"
    End Select
    adoCon.ConnectionString = strConnectString
    adoCon.ConnectionTimeout = 100
    adoCon.Open strConnectString
    Set Cmd.ActiveConnection = adoCon
    ServerConnect = True
    Exit Function
ErrHandle:
    Dim adoErr As ADODB.Error
    If adoCon.Errors.Count > 0 Then
        For Each adoErr In adoCon.Errors
            MsgBox "[Error Code] " & adoErr.Number & Chr(13) & adoErr.Description, vbCritical + vbOKOnly, "Error"
        Next adoErr
    End If
End Function

Public Sub MyOpen(rs As ADODB.Recordset, sql As String)
    With rs
        If .State = 1 Then .Close
        .CursorLocation = adUseClient
        '.CursorLocation = adUseServer
        .Open sql, adoCon, adOpenKeyset, adLockOptimistic
    End With
End Sub

'tables is table name
'f1 is where fields name
'f2 is return fields name
'tt is where result values

Function Lov_list(Tables As String, f1 As String, f2 As String, TT As String)
On Error GoTo ErrorHandle:
    Dim res_list As New ADODB.Recordset
    Set res_list = adoCon.Execute("select * from " & Tables & " where " & f1 & " = '" & Trim(TT) & "'")
    If res_list.EOF Then Exit Function
    Lov_list = IIf(IsNull(res_list.Fields(f2)), "", res_list.Fields(f2))
Exit Function
ErrorHandle:
    Dim Er As ADODB.Error
    For Each Er In adoCon.Errors
        MsgBox Er.Description & "   " & Er.SQLState, vbOKOnly + vbCritical, "Error"
    Next Er
End Function