发表于 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
关于javascrīpt读取xml节点属性值的问题<?xml version="1.0" encoding="gb2312" ?>
<?xml version="1.0" encoding="gb2312"?>
{
var txt="";
{
}
}
Javascrīpt脚本读取xml数据到HTML文件中?谁会用Javascrīpt脚本读取xml数据到HTML文件中呀,帮兄弟把下面的数据读一下好吗?
