Access几则自定义函数实现一些常用的功能

以下为Access VBA写的自定义函数，解决一些常用的功能实现。使用方法：在Access程序里插入一个模块，再将对应的自定义函数代码拷贝进去，即可直接调用使用。

检查指定文件是否存在

'***************** Code Start *******************
Function fIsFileDIR(stPath As String, _
                    Optional lngType As Long) _
                    As Integer
'Fully qualify stPath
'To check for a file
'   ?fIsFileDIR("c:\winnt\win.ini")
'To check for a Dir
'   ?fIsFileDir("c:\msoffice",vbdirectory)
'
    On Error Resume Next
    fIsFileDIR = Len(Dir(stPath, lngType)) > 0
End Function
'***************** Code End *********************

列表框中多选查询

'******************** Code Start ************************
Dim frm As Form, ctl As Control
Dim varItem As Variant
Dim strSQL As String
    Set frm = Form!frmMyForm
    Set ctl = frm!lbMultiSelectListbox
    strSQL = "Select * from Employees where [EmpID]="
    'Assuming long [EmpID] is the bound field in lb
    'enumerate selected items and
    'concatenate to strSQL
    For Each varItem In ctl.ItemsSelected
        strSQL = strSQL & ctl.ItemData(varItem) & " OR [EmpID]="
    Next varItem
    'Trim the end of strSQL
    strSQL=left$(strSQL,len(strSQL)-12))
'******************** Code end ************************

屏蔽PageUP,PageDown

'************ Code Start **********
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'33 - PgUp; 34 - PgDown; 9 - Tab; 18=Alt
    Select Case KeyCode
        Case 33, 34, 9, 18
            KeyCode = 0
        Case Else
            'Debug.Print KeyCode, Shift
    End Select
End Sub
'************ Code End   **********

窗体参数

Docmd.OpenForm "SomeFormB", , , , , ,me.Name  
Docmd.Close acForm, me.OpenArgs

更新保存提示

****************** Code Start ******************
Private Sub Form_BeforeUpdate(Cancel As Integer)
Dim strMsg As String
    strMsg = "Data has changed."
    strMsg = strMsg & "@Do you wish to save the changes?"
    strMsg = strMsg & "@Click Yes to Save or No to Discard changes."
    If MsgBox(strMsg, vbQuestion + vbYesNo, "Save Record?") = vbYes Then
        'do nothing
    Else
        DoCmd.RunCommand acCmdUndo
        
        'For Access 95, use DoMenuItem instead
        'DoCmd.DoMenuItem acFormBar, acEditMenu, acUndo, , acMenuVer70
    End If
End Sub

子窗口无数据时,隐藏 

'*********** Code Start **********
Private Sub Form_Current()
    With Me![SubformName].Form
        .Visible = (.RecordsetClone.RecordCount > 0)
    End With
End Sub
'*********** Code End **********

窗口增加时钟

***************** Code Start ***************
Private Sub Form_Timer()
    Me!lblClock.Caption = Format(Now, "dddd, mmm d yyyy, hh:mm:ss AMPM")
End Sub
Private Sub cmdClockStart_Click()
    Me.TimerInterval = 1000
End Sub
Private Sub cmdClockEnd_Click()
    Me.TimerInterval = 0
End Sub
'***************** Code End ***************

引用外部数据库的窗体

'************ Code Start *************
'Private Declare Function apiSetForegroundWindow Lib "user32" _
            Alias "SetForegroundWindow" _
            (ByVal hwnd As Long) _
            As Long
Private Declare Function apiShowWindow Lib "user32" _
            Alias "ShowWindow" _
            (ByVal hwnd As Long, _
            ByVal nCmdShow As Long) _
            As Long
Private Const SW_MAXIMIZE = 3
Private Const SW_NORMAL = 1
Function fOpenRemoteForm(strMDB As String, _
                                        strForm As String, _
                                        Optional intView As Variant) _
                                        As Boolean
Dim objAccess As Access.Application
Dim lngRet As Long
    On Error GoTo fOpenRemoteForm_Err
    If IsMissing(intView) Then intView = acViewNormal
    If Len(Dir(strMDB)) > 0 Then
        Set objAccess = New Access.Application
        With objAccess
            lngRet = apiSetForegroundWindow(.hWndAccessApp)
            lngRet = apiShowWindow(.hWndAccessApp, SW_NORMAL)
            'the first call to ShowWindow doesn't seem to do anything
            lngRet = apiShowWindow(.hWndAccessApp, SW_NORMAL)
            .OpenCurrentDatabase strMDB
            .DoCmd.OpenForm strForm, intView
            Do While Len(.CurrentDb.Name) > 0
                DoEvents
            Loop
        End With
    End If
fOpenRemoteForm_Exit:
    On Error Resume Next
    objAccess.Quit
    Set objAccess = Nothing
    Exit Function
fOpenRemoteForm_Err:
    fOpenRemoteForm = False
    Select Case Err.Number
        Case 7866:
            'mdb is already exclusively opened
            MsgBox "The database you specified " & vbCrLf & strMDB & _
                vbCrLf & "is currently open in exclusive mode.  " & vbCrLf _
                & vbCrLf & "Please reopen in shared mode and try again", _
                vbExclamation + vbOKOnly, "Could not open database."
        Case 2102:
            'form doesn't exist
            MsgBox "The Form '" & strForm & _
                        "' doesn't exist in the Database " _
                        & vbCrLf & strMDB, _
                        vbExclamation + vbOKOnly, "Form not found"
        Case 7952:
            'user closed mdb
            fOpenRemoteForm = True
        Case Else:
            MsgBox "Error#: " & Err.Number & vbCrLf & Err.Description, _
                    vbCritical + vbOKOnly, "Runtime error"
    End Select
    Resume fOpenRemoteForm_Exit
End Function
'************ Code End *************

关闭所有窗体

dim intx as integer   
   dim intCount as integer   
   intCount = Forms.count-1
   for intX= intCount to 0 step -1     
    docmd.close acform,forms(intX).name
   next
‘*************OR**************
   for intX= intCount to 0 step -1
        if forms(intX).Name <> "MyFormToKeepOpen" then
            docmd.close acform,forms(intX).name        
        end if    
   next

复制当前打开的数据库

'********** Code Start *************
Private Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Boolean
    hNameMappings As Long
    lpszProgressTitle As String
End Type
Private Const FO_MOVE As Long = &H1
Private Const FO_COPY As Long = &H2
Private Const FO_DELETE As Long = &H3
Private Const FO_RENAME As Long = &H4
Private Const FOF_MULTIDESTFILES As Long = &H1
Private Const FOF_CONFIRMMOUSE As Long = &H2
Private Const FOF_SILENT As Long = &H4
Private Const FOF_RENAMEONCOLLISION As Long = &H8
Private Const FOF_NOCONFIRMATION As Long = &H10
Private Const FOF_WANTMAPPINGHANDLE As Long = &H20
Private Const FOF_CREATEPROGRESSDLG As Long = &H0
Private Const FOF_ALLOWUNDO As Long = &H40
Private Const FOF_FILESONLY As Long = &H80
Private Const FOF_SIMPLEPROGRESS As Long = &H100
Private Const FOF_NOCONFIRMMKDIR As Long = &H200
Private Declare Function apiSHFileOperation Lib "Shell32.dll" _
            Alias "SHFileOperationA" _
            (lpFileOp As SHFILEOPSTRUCT) _
            As Long
Function fMakeBackup() As Boolean
Dim strMsg As String
Dim tshFileOp As SHFILEOPSTRUCT
Dim lngRet As Long
Dim strSaveFile As String
Dim lngFlags As Long
Const cERR_USER_CANCEL = vbObjectError + 1
Const cERR_DB_EXCLUSIVE = vbObjectError + 2
    On Local Error GoTo fMakeBackup_Err
    If fDBExclusive = True Then Err.Raise cERR_DB_EXCLUSIVE
    
    strMsg = "Are you sure that you want to make a copy of the database?"
    If MsgBox(strMsg, vbQuestion + vbYesNo, "Please confirm") = vbNo Then _
            Err.Raise cERR_USER_CANCEL
            
    lngFlags = FOF_SIMPLEPROGRESS Or _
                            FOF_FILESONLY Or _
                            FOF_RENAMEONCOLLISION
    strSaveFile = CurrentDb.Name
    With tshFileOp
        .wFunc = FO_COPY
        .hwnd = hWndAccessApp
        .pFrom = CurrentDb.Name & vbNullChar
        .pTo = strSaveFile & vbNullChar
        .fFlags = lngFlags
    End With
    lngRet = apiSHFileOperation(tshFileOp)
    fMakeBackup = (lngRet = 0)
    
fMakeBackup_End:
    Exit Function
fMakeBackup_Err:
    fMakeBackup = False
    Select Case Err.Number
        Case cERR_USER_CANCEL:
            'do nothing
        Case cERR_DB_EXCLUSIVE:
            MsgBox "The current database " & vbCrLf & CurrentDb.Name & vbCrLf & _
                    vbCrLf & "is opened exclusively.  Please reopen in shared mode" & _
                    " and try again.", vbCritical + vbOKOnly, "Database copy failed"
        Case Else:
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: fMakeBackup" & vbCrLf
            strMsg = strMsg & "Description: " & Err.Description & vbCrLf
            strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
            MsgBox strMsg, vbInformation, "fMakeBackup"
    End Select
    Resume fMakeBackup_End
End Function
Private Function fCurrentDBDir() As String
'code courtesy of
'Terry Kreft
Dim strDBPath As String
Dim strDBFile As String
    strDBPath = CurrentDb.Name
    strDBFile = Dir(strDBPath)
    fCurrentDBDir = left(strDBPath, InStr(strDBPath, strDBFile) - 1)
End Function
Function fDBExclusive() As Integer
Dim db As Database
Dim hFile As Integer
    hFile = FreeFile
    Set db = CurrentDb
    On Error Resume Next
    Open db.Name For Binary Access Read Write Shared As hFile
    Select Case Err
        Case 0
            fDBExclusive = False
        Case 70
            fDBExclusive = True
        Case Else
            fDBExclusive = Err
    End Select
    Close hFile
    On Error GoTo 0
End Function
'************* Code End ***************

代替replace函数

'************ Code Start **********
Function fstrTran(ByVal sInString As String, _
                           sFindString As String, _
                           sReplaceString As String) As String
  Dim iSpot As Integer, iCtr As Integer
  Dim iCount As Integer
  
  iCount = Len(sInString)
  For iCtr = 1 To iCount
    iSpot = InStr(1, sInString, sFindString)
    If iSpot > 0 Then
      sInString = Left(sInString, iSpot - 1) & _
                        sReplaceString & _
                        Mid(sInString, iSpot + Len(sFindString))
    Else
      Exit For
    End If
  Next
  fstrTran = sInString
  
End Function
'************* Code End ***************