Access数据库：常见的VBA问题，FQA四。

最新推荐文章于 2022-09-16 21:30:56 发布

沐NeMo

最新推荐文章于 2022-09-16 21:30:56 发布

阅读量1.7k

点赞数

分类专栏： 5.MS VBA 文章标签： vba access 数据库 function database string

本文链接：https://blog.csdn.net/linjimu/article/details/2678608

版权

5.MS VBA 专栏收录该内容

12 篇文章 0 订阅

订阅专栏

'檢查資料庫的連結；如果連結是正確的，則傳回 [真]。
Public Function CheckLinks(Table As TableDef) As Boolean
    Dim rst As Recordset
    On Error Resume Next
    Set rst = CurrentDb.OpenRecordset(Table.Name)
    If Err = 0 Then
        CheckLinks = True
    Else
        CheckLinks = False
    End If
End Function

'更新提供資料庫之連結。如果成功則傳回 [真]。
Private Function RefreshLinks(strFileName As String) As Boolean
    Dim dbs As Database
    Dim tdf As TableDef

    'Const conMaxTables = 8
    'Const conNonExistentTable = 3011
    'Const conNotNorthwind = 3078
    'Const conNwindNotFound = 3024
    'Const conAccessDenied = 3051
    'Const conReadOnlyDatabase = 3027

    Set dbs = CurrentDb
    For Each tdf In dbs.TableDefs
        If Len(tdf.Connect) > 0 Then
            tdf.Connect = ";DATABASE=" & strFileName
            Err = 0
            On Error Resume Next
            tdf.RefreshLink         ' 重新連結資料表。
            'If Err = 3078 Then
             '   RefreshLinks = False
                'Exit Function
            'End If
        End If
    Next tdf
    RefreshLinks = True             ' 重新連結完成。
End Function

'例1:檢測連接是否有效﹐且自動更新
Private Function RefreshLinks(strFileName As String) As Boolean
Dim Tdf As TableDef
Dim Rst As Recordset
On Error Resume Next
For Each Tdf In CurrentDb.TableDefs
      If Len(Tdf.Connect) > 0 Then
         Set Rst = CurrentDb.OpenRecordset(Tdf.Name)
         If Err <> 0 Then
            Tdf.Connect = ";DataBase=" & strFileName
            Tdf.RefreshLink
            If Err <> 0 Then MsgBox Error()
            Err = 0
         End If
      End If
Next Tdf
Set Rst = Nothing
End Function

設置窗體圖標
Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, _
       ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, _
       ByVal un2 As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
       ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const WM_SETICON = &H80
Const IMAGE_ICON = 1
Const LR_LOADFROMFILE = &H10

'hwnd為窗口句柄    iconpath為ico文件路徑
Function SetFormIcon(hwnd As Long, IconPath As String) As Boolean
On Error GoTo Exit_Err
Dim hIcon As Long
If Dir(IconPath) = "" Then Exit Function
hIcon = LoadImage(0&, IconPath, IMAGE_ICON, 16, 16, LR_LOADFROMFILE) '窗口圖標句柄
If hIcon <> 0 Then
     Call SendMessage(hwnd, WM_SETICON, 0, ByVal hIcon)
     SetFormIcon = True
Else
     End
End If
Exit_Err:
Exit Function
End Function

'==列舉系統中預設的參照==
Sub ReferenceBuiltInOnly()
    Dim ref As Reference
    For Each ref In References
        If ref.BuiltIn = True Then
            Debug.Print ref.Name
        End If
    Next ref
End Sub

獲取當前資料庫引用的插件==
Sub ReferenceProperties()
    Dim ref As Reference
    For Each ref In References
        If ref.IsBroken = False Then
            Debug.Print "名稱: ", ref.Name
            Debug.Print "完整路徑: ", ref.FullPath
            Debug.Print "版本: ", ref.Major & "." & ref.Minor
        Else
            Debug.Print "損壞參照的 GUIDs:"
            Debug.Print ref.Guid
        End If
    Next ref
End Sub

'判斷當前用戶是否是管理員
Public Function Administer() As Boolean
Dim Dab As Database, Ojb As Variant
Set Dab = CurrentDb
With Dab.Containers("Databases").Documents("MSysDb")
       If (.Permissions And 1048569) = 1048569 Then
          Administer = True
       Else
          Administer = False
       End If
End With
Set Dab = Nothing
End Function

'獲得外部資料表連接路徑/密碼
Public Function ListLink()
Dim Connect As String, Pwd As String
With CurrentDb.OpenRecordset("SELECT Database,Database,Connect FROM MSysObjects WHERE Type=6;")
     Do Until .EOF
        Connect = Trim(!Connect)
        Pwd = InStr(Connect, "PWD=")
        If Pwd > 0 Then
           Pwd = Mid(Connect, Pwd + 4)
           Pwd = Left(Pwd, Len(Pwd) - 1)
        Else
           Pwd = vbNullString
        End If
        Debug.Print !Database, !Database, Pwd
        .MoveNext
     Loop
End With
End Function

'獲取登錄數據庫的用戶名稱
'需Microsoft ActiveX Data Objects 2.x Library 插件支持
Sub ShowUserRosterMultipleUsers()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=//server/Program.mdb"
    Set rs = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
    Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, "", rs.Fields(2).Name, rs.Fields(3).Name
    While Not rs.EOF
          Debug.Print rs.Fields(0), rs.Fields(1), rs.Fields(2), rs.Fields(3)
          rs.MoveNext
    Wend
End Sub

取消表單還原視窗按鈕
Public Sub Test(Fm As Form)
    Application.Echo False
    DoCmd.RunCommand acCmdAppMaximize
    DoCmd.Maximize
    WD = Fm.InsideWidth
    HD = Fm.InsideHeight
    DoCmd.Restore
    DoCmd.MoveSize 0, 0, WD, HD
    Application.Echo True
End Sub

檢查一個表單是否打開

Function IsLoaded(strName As String, Optional intObjectType As Integer = acForm)
IsLoaded = (SysCmd(acSysCmdGetObjectState, intObjectType, strName) <> 0)
End Function

刪除指定文件的記錄
Function DeleteAllRecod(ByVal dbPath As String)
Dim DB As Database
Dim X As Integer
Dim Tdb As TableDef
Set DB = OpenDatabase(dbPath)
For X = 0 To DB.TableDefs.Count - 1
Set tdf = DB.TableDefs(X)
If (tdf.Attributes And dbSystemObject) = 0 Then
     DB.Execute "DELETE * FROM [" & DB.TableDefs(X).Name & "]"
End If
Next X
End Function

'獲取每個用戶所屬群組
Sub UserGroup()
    Dim wsp As Workspace
    Dim usr As User
    Dim grp As Group
    '傳回預設工作區的參照位址。
    Set wsp = DBEngine.Workspaces(0)
    For Each grp In wsp.Groups
        For Each usr In grp.Users
            MsgBox usr.Name
        Next
    Next
    Set wsp = Nothing
End Sub

從Excel匯入記錄

Function ExportExcelSheetToAccess(sSheetName As String, sExcelPath As String, sAccessTable As String, sAccessDBPath As String)
Dim Db As Database
Dim Rs As Recordset
Set Db = OpenDatabase(sExcelPath, True, False, "Excel 5.0")
Call Db.Execute("SELECT * INTO [;DataBase=" & sAccessDBPath & "]." & sAccessTable & " FROM [" & sSheetName & "$]")
MsgBox "Table Exported SuccesFully", vbInformation, "Yams"
Set Db = Nothing
End Function

Sub test()
ExportExcelSheetToAccess "GDISPO", "d:/report/GDISPO.XLS", "usysorder", CurrentDb.Name
End Sub

移動表單的指針至被找到的記錄

Private Sub cmdFindContactName_Click()
   Dim rst As Recordset, strCriteria As String
   strCriteria = "[ContactName] Like '*" & InputBox("請輸入名稱的前幾個字元以便尋找") & "*'"
    Set rst = Me.RecordsetClone
    rst.FindFirst strCriteria
    If rst.NoMatch Then
       MsgBox "找不到項目"
    Else
       Me.Bookmark = rst.Bookmark
    End If
End Sub

資料表加鎖

Dim Dummy As Integer

Function HardLockTable(ByVal whichAction As String, ByVal aTable As String) As Integer
On Error GoTo HardLockTableError
HardLockTable = True
Select Case whichAction
Case "Lock"
CurrentDb.TableDefs(aTable).ValidationRule = "True=False"
CurrentDb.TableDefs(aTable).ValidationText = "資料表已被鎖"
Case "UnLock"
CurrentDb.TableDefs(aTable).ValidationRule = ""
CurrentDb.TableDefs(aTable).ValidationText = ""
End Select
HardLockTableErrorExit:
Exit Function
HardLockTableError:
HardLockTable = False
MsgBox " error " & "in HardLockTable trying " & "to " & whichAction & " " & aTable
Resume HardLockTableErrorExit
End Function