'判斷程序是否在MDE還是在ADE中運行

Public Function atIsitMDE() As Byte
     On Error Resume Next
     Dim dbs    As Object
     Dim strMDE As String
     If Application.CurrentProject.ProjectType = acADP Then
        Set dbs = Application.CurrentProject
     Else
        Set dbs = CurrentDb()
     End If
 
     strMDE = dbs.Properties("MDE")
     If Err = 0 And strMDE = "T" Then
        atIsitMDE = 1
     Else
        atIsitMDE = 0
     End If
     Set dbs = Nothing
   End Function

'列出全部工作表

Private Sub ListTable()
     Dim tmpTable As Object
     Dim strTables As String
     'For Each tmpTable In currentdata.AllTables
     For Each tmpTable In CurrentDb.TableDefs
         If Not tmpTable.Name Like "MSys*" Then
            strTables = strTables & tmpTable.Name & ";"
         End If
     Next tmpTable
     MsgBox strTables
     'selTable.RowSource = strTables
   End Sub

'判斷是否安裝了程式(例:Excel)

Function existenceCheck() As Boolean
     Dim objApp As Object
     existenceCheck = True
     On Error Resume Next
     Set bjApp = CreateObject("Excel.Application")
     If Err = 429 Then
        existenceCheck = False
        Exit Function
     End If
     Set bjApp = Nothing
   End Function

'列出自動編號字段

Private Sub ListAutoNumber_Field()
     Dim daoRs    As DAO.Recordset
     Dim daoField As DAO.Field
     Dim Seed1    As Long
     Dim Seed2    As Long
     Set daoRs = CurrentDb.OpenRecordset("SELECT TOP 1 * FROM " & "Na", dbOpenDynaset)
     For Each daoField In daoRs.Fields
         If daoField.Attributes And dbAutoIncrField Then
            MsgBox daoField.Name
         End If
     Next daoField
     daoRs.Close
     Set daoRs = Nothing
    
  End Sub

'檢測檔案如果損壞就修復

Function CheckData(FileName As String)
     On Error Resume Next
     Set JB = CreateObject("DAO.DBEngine.35")
     On Error GoTo Error1
     Set DB = OJB.OpenDatabase(FileName)
     On Error GoTo 0
     MsgBox "可以正常打開數據庫", 32, "提示"
     Exit Function
Error1:
     If Err = 3343 Then
        '修復文件
        OJB.RepairDatabase FileName
      
        '壓縮文件
        NFileName = FileName & "T"
        OJB.CompactDatabase FileName, NFileName ', , , ";pwd=密碼"
        Kill FileName
        Name NFileName As FileName
        Resume
     Else
        MsgBox Error(Err), vbMsgBoxSetForeground + vbOKOnly + 32, "提示"
     End If
   End Function
  
   '使用ADO來壓縮或修复Microsoft Access文件
   Sub Test()
       'Microsoft Jet and Replication Objects X.X library(須安裝微軟MDAC 2.1 后的版本)
       'Dim Jro As Jro.JetEngine
       'Set Jro = New Jro.JetEngine
 
       Set JET = CreateObject("JRO.JetEngine")
       s = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
           "Jet OLEDB:System Database=D:\dll\WorkRoom\system.mdw;" & _
           "User ID=lirong;" & _
           "Password=13535;" & _
           "Data Source=c:\windows\desktop\db2.mdb"
 
       b = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
           "Data Source=d:\c2.mdb;" & _
           "Jet OLEDB:Engine Type=4"
       If Dir("D:\C2.mdb") <> vbNullString Then Kill "D:\C2.mdb"
          JET.CompactDatabase s, b
   End Sub
'注意引用　microsoft　office 10.0 （或以上）　object library
'在文件对话框对中返回选择一个文件夹的路径.
Public Function ChooseFolder() As String
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
    If .Show = -1 Then
        ChooseFolder = .SelectedItems(1)
    End If
End With
Set dlgOpen = Nothing
End Function

'--------------------------------------------------------
'在文件对话框对中，选择一个文件。
Public Function ChooseOneFile(Optional TitleStr As String = "选择你要的文件", Optional TypesDec As String = "所有文件", Optional Exten As String = "*.*") As String
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogFilePicker)
With dlgOpen
    .TITLE = TitleStr
    .Filters.Clear  '清除所有的文件类型.
    .Filters.Add TypesDec, Exten
    .AllowMultiSelect = False '不能多选.
    If .Show = -1 Then
'        .AllowMultiSelect = True       '多个文件
'        For Each vrtSelectedItem In .SelectedItems
'            MsgBox "Path name: " & vrtSelectedItem
'        Next vrtSelectedItem
    ChooseOneFile = .SelectedItems(1)    '第一个文件
    End If
End With
Set dlgOpen = Nothing
End Function
'取当前日期和星期如: 2005.2.8　星期三
Public Function GetDateWeekday() As String
GetDateWeekday = Replace(Date, "-", ".") & " " & WeekdayName(Weekday(Date))
End Function
'打开文件夹d:\mc'双击打开目录"
Public Function OpenDir(DirString)
Dim Dr As String
Dim TmpStr As String
If Not IsNull(DirString) Then
    If Right(DirString, 1) = "\" Then
        TmpStr = DirString
    ElseIf Right(DirString, 1) = ":" Then
        TmpStr = DirString & "\"
    Else
        TmpStr = Mid(DirString, 1, Len(DirString) - Len(Dir(DirString)))
    End If
    If FIsFileDIR(TmpStr, vbDirectory) Then
        Dr = "explorer " & TmpStr
        Shell Dr, vbNormalFocus
    End If
End If
End Function

 

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

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

 
'從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

 
'獲取每個用戶所屬群組
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

 
'刪除指定文件的記錄
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

'檢查一個表單是否打開

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

 
 '取消表單還原視窗按鈕
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
'獲取登錄數據庫的用戶名稱
'需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 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

'獲取當前資料庫引用的插件==
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

'==列舉系統中預設的參照==
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
'設置窗體圖標
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

 
'例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

 
'更新提供資料庫之連結。如果成功則傳回 [真]。
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

 
'檢查資料庫的連結；如果連結是正確的，則傳回 [真]。
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