Access 自增函数及相关技巧

‘列表框中多选查询'******************** Code Start ************************Dim frm As Form, ctl As ControlDim varItem As VariantDim strSQL As StringSet frm = Form!frmMyFormSet ctl = frm!lbMultiSelectListboxstrSQL = "Select * from Employees where [EmpID]="'Assuming long [EmpID] is the bound field in lb'enumerate selected items and'concatenate to strSQLFor Each varItem In ctl.ItemsSelectedstrSQL = strSQL & ctl.ItemData(varItem) & " OR [EmpID]="Next varItem'Trim the end of strSQLstrSQL=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=AltSelect Case KeyCodeCase 33, 34, 9, 18KeyCode = 0Case Else'Debug.Print KeyCode, ShiftEnd Select'************ Code End **********‘‘窗体参数Docmd.OpenForm "SomeFormB", , , , , ,Docmd.Close acForm, me.OpenArgs‘更新保存提示.****************** Code Start ******************Private Sub Form_BeforeUpdate(Cancel As Integer)Dim strMsg As StringstrMsg = "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 nothingElseDoCmd.RunCommand acCmdUndo'For Access 95, use DoMenuItem instead'DoCmd.DoMenuItem acFormBar, acEditMenu, acUndo, , acMenuVer70 End IfEnd Sub‘子窗口无数据时,隐藏'*********** Code Start **********Private Sub Form_Current()With Me![SubformName].Form.Visible = (.RecordsetClone.RecordCount > 0)End WithEnd Sub'*********** Code End **********‘窗口增加时钟***************** Code Start ***************Private Sub Form_Timer()Me!lblClock.Caption = Format(Now, "dddd, mmm d yyyy, hh:mm:ss AMPM") End SubPrivate Sub cmdClockStart_Click()Me.TimerInterval = 1000End SubPrivate Sub cmdClockEnd_Click()Me.TimerInterval = 0'***************** Code End ***************‘引用外部数据库的窗体'************ Code Start *************'Private Declare Function apiSetForegroundWindow Lib "user32" _Alias "SetForegroundWindow" _(ByVal hwnd As Long) _As LongPrivate Declare Function apiShowWindow Lib "user32" _Alias "ShowWindow" _(ByVal hwnd As Long, _ByVal nCmdShow As Long) _As LongPrivate Const SW_MAXIMIZE = 3Private Const SW_NORMAL = 1Function fOpenRemoteForm(strMDB As String, _strForm As String, _Optional intView As Variant) _As BooleanDim objAccess As Access.ApplicationDim lngRet As LongOn Error GoTo fOpenRemoteForm_ErrIf IsMissing(intView) Then intView = acViewNormalIf Len(Dir(strMDB)) > 0 ThenSet objAccess = New Access.ApplicationWith objAccesslngRet = apiSetForegroundWindow(.hWndAccessApp)lngRet = apiShowWindow(.hWndAccessApp, SW_NORMAL)'the first call to ShowWindow doesn't seem to do anythinglngRet = apiShowWindow(.hWndAccessApp, SW_NORMAL).OpenCurrentDatabase strMDB.DoCmd.OpenForm strForm, intViewDo While Len() > 0DoEventsLoopEnd WithEnd IffOpenRemoteForm_Exit:On Error Resume NextobjAccess.QuitSet objAccess = NothingExit FunctionfOpenRemoteForm_Err:fOpenRemoteForm = FalseSelect Case Err.NumberCase 7866:'mdb is already exclusively openedMsgBox "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 existMsgBox "The Form '" & strForm & _"' doesn't exist in the Database " _& vbCrLf & strMDB, _vbExclamation + vbOKOnly, "Form not found"Case 7952:'user closed mdbfOpenRemoteForm = TrueCase Else:MsgBox "Error#: " & Err.Number & vbCrLf & Err.Description, _vbCritical + vbOKOnly, "Runtime error"End SelectResume fOpenRemoteForm_ExitEnd Function'************ Code End *************‘关闭所有窗体dim intx as integerdim intCount as integerintCount = Forms.count-1for intX= intCount to 0 step -1docmd.close acform,forms(intX).namenext‘*************OR**************for intX= intCount to 0 step -1if forms(intX).Name <> "MyFormToKeepOpen" thendocmd.close acform,forms(intX).nameend ifnext‘复制当前打开的数据库'********** Code Start *************Private Type SHFILEOPSTRUCThwnd As LongwFunc As LongpFrom As StringpTo As StringfFlags As IntegerfAnyOperationsAborted As BooleanhNameMappings As LonglpszProgressTitle As StringEnd TypePrivate Const FO_MOVE As Long = &H1Private Const FO_COPY As Long = &H2Private Const FO_DELETE As Long = &H3Private Const FO_RENAME As Long = &H4Private Const FOF_MULTIDESTFILES As Long = &H1Private Const FOF_CONFIRMMOUSE As Long = &H2Private Const FOF_SILENT As Long = &H4Private Const FOF_RENAMEONCOLLISION As Long = &H8Private Const FOF_NOCONFIRMATION As Long = &H10Private Const FOF_WANTMAPPINGHANDLE As Long = &H20Private Const FOF_CREATEPROGRESSDLG As Long = &H0Private Const FOF_ALLOWUNDO As Long = &H40Private Const FOF_FILESONLY As Long = &H80Private Const FOF_SIMPLEPROGRESS As Long = &H100Private Const FOF_NOCONFIRMMKDIR As Long = &H200Private Declare Function apiSHFileOperation Lib "Shell32.dll" _Alias "SHFileOperationA" _(lpFileOp As SHFILEOPSTRUCT) _As LongFunction fMakeBackup() As BooleanDim strMsg As StringDim tshFileOp As SHFILEOPSTRUCTDim lngRet As LongDim strSaveFile As StringDim lngFlags As LongConst cERR_USER_CANCEL = vbObjectError + 1Const cERR_DB_EXCLUSIVE = vbObjectError + 2On Local Error GoTo fMakeBackup_ErrIf fDBExclusive = True Then Err.Raise cERR_DB_EXCLUSIVEstrMsg = "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_CANCELlngFlags = FOF_SIMPLEPROGRESS Or _FOF_FILESONLY Or _FOF_RENAMEONCOLLISIONstrSaveFile = With tshFileOp.wFunc = FO_COPY.hwnd = hWndAccessApp.pFrom = & vbNullChar.pTo = strSaveFile & vbNullChar.fFlags = lngFlagsEnd WithlngRet = apiSHFileOperation(tshFileOp)fMakeBackup = (lngRet = 0)fMakeBackup_End:Exit FunctionfMakeBackup_Err:fMakeBackup = FalseSelect Case Err.NumberCase cERR_USER_CANCEL:'do nothingCase 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 & vbCrLfstrMsg = strMsg & "Function: fMakeBackup" & vbCrLfstrMsg = strMsg & "Description: " & Err.Description & vbCrLfstrMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLfMsgBox strMsg, vbInformation, "fMakeBackup"End SelectResume fMakeBackup_EndEnd FunctionPrivate Function fCurrentDBDir() As String'code courtesy of'Terry KreftDim strDBPath As StringDim strDBFile As StringstrDBPath = strDBFile = Dir(strDBPath)fCurrentDBDir = left(strDBPath, InStr(strDBPath, strDBFile) - 1)End FunctionFunction fDBExclusive() As IntegerDim db As DatabaseDim hFile As IntegerhFile = FreeFileSet db = CurrentDbOn Error Resume NextOpen For Binary Access Read Write Shared As hFile Select Case ErrCase 0fDBExclusive = FalseCase 70fDBExclusive = TrueCase ElsefDBExclusive = ErrEnd SelectClose hFileOn Error GoTo 0End 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 IntegerDim iCount As IntegeriCount = Len(sInString)For iCtr = 1 To iCountiSpot = InStr(1, sInString, sFindString)If iSpot > 0 ThensInString = Left(sInString, iSpot - 1) & _sReplaceString & _Mid(sInString, iSpot + Len(sFindString)) ElseExit ForEnd IfNextfstrTran = sInStringEnd Function'************* Code End ***************。