发表于 2005-8-2 08:39  资料  个人空间  主页 短消息  加为好友     
[原创]請大家分享Access中自定義函數

請大家分享Access中自定義函數﹐請版主幫忙置頂。
 

 

<url>http://blog.3326.com/user1/10247/index.html</url>
 
[广告] 
 
lirong (冬日阳光)

版主

 

UID 35481
精华 1
积分 1995
帖子 1267
水晶 1840 枚
威望 12 点
阅读权限 100
注册 2005-6-13
来自 南非（开普敦)
状态 离线  #2  大 中 小
发表于 2005-8-2 13:18  资料  个人空间  主页 短消息  加为好友     
俺帶個頭先﹕大家跟著貼
'檢查資料庫的連結；如果連結是正確的，則傳回 [真]。
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
 

 

<url>http://blog.3326.com/user1/10247/index.html</url>
 
[广告] 
 
lirong (冬日阳光)

版主

 

UID 35481
精华 1
积分 1995
帖子 1267
水晶 1840 枚
威望 12 点
阅读权限 100
注册 2005-6-13
来自 南非（开普敦)
状态 离线  #3  大 中 小
发表于 2005-8-2 13:19  资料  个人空间  主页 短消息  加为好友     
'更新提供資料庫之連結。如果成功則傳回 [真]。
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
 

 

<url>http://blog.3326.com/user1/10247/index.html</url>
 
 
lirong (冬日阳光)

版主

 

UID 35481
精华 1
积分 1995
帖子 1267
水晶 1840 枚
威望 12 点
阅读权限 100
注册 2005-6-13
来自 南非（开普敦)
状态 离线  #4  大 中 小
发表于 2005-8-2 13:20  资料  个人空间  主页 短消息  加为好友     
'例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
 

 

<url>http://blog.3326.com/user1/10247/index.html</url>
 
 
lirong (冬日阳光)

版主

 

UID 35481
精华 1
积分 1995
帖子 1267
水晶 1840 枚
威望 12 点
阅读权限 100
注册 2005-6-13
来自 南非（开普敦)
状态 离线  #5  大 中 小
发表于 2005-8-2 13:24  资料  个人空间  主页 短消息  加为好友     
'設置窗體圖標
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
 

 

<url>http://blog.3326.com/user1/10247/index.html</url>
 
 
lirong (冬日阳光)

版主

 

UID 35481
精华 1
积分 1995
帖子 1267
水晶 1840 枚
威望 12 点
阅读权限 100
注册 2005-6-13
来自 南非（开普敦)
状态 离线  #6  大 中 小
发表于 2005-8-2 13:30  资料  个人空间  主页 短消息  加为好友     
'==列舉系統中預設的參照==
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
 

 

版主

 

UID 35481
精华 1
积分 1995
帖子 1267
水晶 1840 枚
威望 12 点
阅读权限 100
注册 2005-6-13
来自 南非（开普敦)
状态 离线  #18  大 中 小
发表于 2005-8-25 18:56  资料  个人空间  主页 短消息  加为好友     
移動表單的指針至被找到的記錄

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
 

 

 

 

发表于 2005-8-25 18:59  资料  个人空间  主页 短消息  加为好友     
資料表加鎖

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

Sub TEST()
    Dummy = HardLockTable("Lock", "入倉記錄") '加鎖
    Dummy = HardLockTable("UnLock", "入倉記錄")'解鎖
End Sub
 

 

<url>http://blog.3326.com/user1/10247/index.html</url>
 
'取当前日期和星期如: 2005.2.8　星期三
Public Function GetDateWeekday() As String
GetDateWeekday = Replace(Date, "-", ".") & " " & WeekdayName(Weekday(Date))
End Function
 
 
[广告] 
 
evenlin

略知一二

 

UID 11556
精华 0
积分 59
帖子 13
水晶 55 枚
威望 0 点
阅读权限 10
注册 2003-12-15
状态 离线  #23  大 中 小
发表于 2006-2-8 17:28  资料  个人空间  短消息  加为好友  
'注意引用　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
 
 
 
jsjtyjp_001

略有小成

 

UID 31657
精华 0
积分 145
帖子 20
水晶 58 枚
威望 0 点
阅读权限 15
注册 2005-4-16
状态 离线  #24  大 中 小
发表于 2006-2-14 12:46  资料  个人空间  短消息  加为好友  
请教各位,如何使用自定义函数?

我在模块中写了一个计算个所税的自定义函数(名为"零四个税",在查询中使用,格式为: txt个税: Round(零四个税([txt应税工资合计数]),2)  但在执行查询时,有时会弹出"表达式中,'零四个税'函数尚未定义"的提示,请教各位,如何定义函数?
 
 
 
danis

版主

 

  
UID 37859
精华 1
积分 1277
帖子 592
水晶 872 枚
威望 3 点
阅读权限 100
注册 2005-7-9
来自 台灣
状态 离线  #25  大 中 小
发表于 2006-5-15 23:06  资料  个人空间  短消息  加为好友  
使用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
 
 
 
danis

版主

 

  
UID 37859
精华 1
积分 1277
帖子 592
水晶 872 枚
威望 3 点
阅读权限 100
注册 2005-7-9
来自 台灣
状态 离线  #26  大 中 小
发表于 2006-5-15 23:07  资料  个人空间  短消息  加为好友  
檢測檔案如果損壞就修復

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
 
 
 
danis

版主

 

  
UID 37859
精华 1
积分 1277
帖子 592
水晶 872 枚
威望 3 点
阅读权限 100
注册 2005-7-9
来自 台灣
状态 离线  #27  大 中 小
发表于 2006-5-15 23:08  资料  个人空间  短消息  加为好友  
列出自動編號字段

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
 
 
 
danis

版主

 

  
UID 37859
精华 1
积分 1277
帖子 592
水晶 872 枚
威望 3 点
阅读权限 100
注册 2005-7-9
来自 台灣
状态 离线  #28  大 中 小
发表于 2006-5-15 23:10  资料  个人空间  短消息  加为好友  
判斷是否安裝了程式(例: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
 
 
 
danis

版主

 

  
UID 37859
精华 1
积分 1277
帖子 592
水晶 872 枚
威望 3 点
阅读权限 100
注册 2005-7-9
来自 台灣
状态 离线  #29  大 中 小
发表于 2006-5-15 23:10  资料  个人空间  短消息  加为好友  
列出全部工作表

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
 
 
 
danis

版主

 

  
UID 37859
精华 1
积分 1277
帖子 592
水晶 872 枚
威望 3 点
阅读权限 100
注册 2005-7-9
来自 台灣
状态 离线  #30  大 中 小
发表于 2006-5-15 23:11  资料  个人空间  短消息  加为好友  
判斷程序是否在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