多个 access 自定义函数《VBA》

时　间:2009-05-09 08:33:07
作　者:UMVSoft整理   ID：1445  城市：上海
摘　要:多个 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 ***************