'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", , , , , , 
  
   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(.) > 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 = 
     With tshFileOp
         .wFunc = FO_COPY
         .hwnd = hWndAccessApp
         .pFrom =  & 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 &  & 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 = 
     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  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 ***************