- '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 =
- Private Const FO_COPY As Long =
- Private Const FO_DELETE As Long =
- Private Const FO_RENAME As Long =
- Private Const FOF_MULTIDESTFILES As Long =
- Private Const FOF_CONFIRMMOUSE As Long =
- Private Const FOF_SILENT As Long =
- Private Const FOF_RENAMEONCOLLISION As Long =
- Private Const FOF_NOCONFIRMATION As Long =
- Private Const FOF_WANTMAPPINGHANDLE As Long =
- Private Const FOF_CREATEPROGRESSDLG As Long =
- Private Const FOF_ALLOWUNDO As Long =
- Private Const FOF_FILESONLY As Long =
- Private Const FOF_SIMPLEPROGRESS As Long =
- Private Const FOF_NOCONFIRMMKDIR As Long =
- 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 ***************
Access 自增函数及相关技巧
最新推荐文章于 2020-12-22 09:14:48 发布