start_module.bas

用vb编写的能管理自己日程计划的程序。后台用access数据库

Attribute VB_Name = "Start_Module"
Public strConnection As String
Public cnnConnection As ADODB.Connection
Public rstCustomers As Recordset
Public blnLoginFlag As Boolean  '登录标志
Public UserID As String '用户名
Public strQry As String
Public objfrmCalendar() As frmCalendar
Public IndexfrmCalendar As Integer
Public SelectedDate As Date
Public NowTime As Date

Public prevWndProc As Long
Public Const SYSTEMCAPTION = "GoldSeal 小秘书 1.0"
Public Const CBN_SELENDCANCEL = 10
Public Const CBN_SELENDOK = 9
Public Const WM_COMMAND = &H111
Public Const GWL_WNDPROC = (-4)

Public Const CB_SHOWDROPDOWN = &H14F

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

'启动过程
Sub Main()

    Dim strAppPath As String
    
    On Error GoTo VBError
    
    '保证路径字符串尾有斜扛号
    strAppPath = App.Path
    If Right(strAppPath, 1) <> "\" Then
        strAppPath = strAppPath & "\"
    End If
    
    strAppPath = strAppPath & "RCGL_DATA.mdb"
    strConnection = "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & strAppPath & ";"
    
    '打开连接
    Set cnnConnection = New Connection
    Set rstCustomers = New Recordset
    
    With cnnConnection
        .ConnectionString = strConnection
        .CursorLocation = adUseClient
        .CommandTimeout = 30
        .Open
    End With
    
    
    frmSplash.Show
    Exit Sub
VBError:
    DisplayVBError
    
End Sub

'获取指定的记录集
Public Function GetRecordSet(cnnConnection As ADODB.Connection, sQry As String) As ADODB.Recordset
    
    Dim fun_rstCustomers As ADODB.Recordset
    
    Set fun_rstCustomers = New Recordset
    '下面的记录锁类型，因为CursorLocation设为adUseClient
    '实际当打开记录集时，记录锁类型已设为adOpenStatic
    fun_rstCustomers.CursorType = adOpenDynamic
    fun_rstCustomers.LockType = adLockOptimistic
    '设置记录集的数据来源为一个SQL串
    fun_rstCustomers.Source = sQry
    '设置记录集的连接字符串
    Set fun_rstCustomers.ActiveConnection = cnnConnection
    fun_rstCustomers.Open
    
    Set GetRecordSet = fun_rstCustomers

End Function

Public Sub DisplayADOErrors(cnnConnection As ADODB.Connection)
 
    Dim errLoop As ADODB.Error
    Dim strHelp As String
    
    For Each errLoop In cnnConnection.Errors
        If errLoop.HelpFile = "" Then
            strHelp = "没有帮助信息可用"
        Else
            strHelp = "帮助文件： " & errLoop.HelpFile & "； 帮助内容： " & errLoop.HelpContext
        End If
        MsgBox "ADO 错误 #" & errLoop.Number & vbCrLf & "错误源： " & errLoop.Source & vbCrLf & "SQL 状态： " & errLoop.SQLState & "；本地错误： " & errLoop.NativeError & vbCrLf & vbCrLf & "错误目标： " & errLoop.Description & vbCrLf & vbCrLf & strHelp, vbCritical, "ADO 错误"
    Next
    
End Sub

Public Sub DisplayVBError()

    If CBool(Err) Then
        MsgBox "VB 错误 #" & Err.Number & vbCrLf & "错误源： " & Err.Source & vbCrLf & vbCrLf & "Description: " & Err.Description, vbCritical, "VB 运行时错误"
        Err.Clear
    End If
    
End Sub

Function WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = WM_COMMAND Then
        Select Case wParam \ 65536
            Case CBN_CLOSEUP
            Case CBN_SELENDOK
                If lParam = objfrmCalendar(IndexfrmCalendar).cboStartTime.hWnd Then
                    SendMessage objfrmCalendar(IndexfrmCalendar).cboEndTime.hWnd, CB_SHOWDROPDOWN, True, ByVal 0&
                End If
            Case CBN_SELENDCANCEL
        End Select
    End If
    
    WndProc1 = CallWindowProc(prevWndProc, hWnd, Msg, wParam, lParam)
End Function