Office中国论坛/Access中国论坛
标题: Access技巧接龙 [打印本页]
作者: tmtony 时间: 2004-11-28 18:15
标题: Access技巧接龙
相信大家都玩过成语接龙，我们也来个Access的技巧接龙游戏，看看此龙能接多长。
接龙规则:
- 只要是你认为是好的使用或开发技巧和文章,就可跟贴
- 别人推荐给你的Access使用和开发技巧，也可跟贴
- 国外或国内Access网站的技巧，翻译或整理的文章，也可跟贴
- 技巧难度可以从简单、中级到高级应用。
- 技巧内容可以任意。比如使用技巧、表操作、vba、API、ActiveX、加载项、类、打包帮助等。
- 跟贴前请尽量看完楼上的贴，以避免重复。
- 为了尊重源作者，请尽量写明源作者
- 非常好的技巧贴，可被挑选放入网站首页的文章区
- 跟贴次数不限，但尽量避免闲聊，多发技巧文章贴
此贴总置顶，让Access的网友都来发挥自己的一份热量，来了Office中国永不沉落的贴子。
Excel、Word、sharepint等随后也将增加相应的接龙贴。
作者: yangzn 时间: 2004-11-29 02:00
我来支持一下，最近我写人事管理，中间要插入员工图片,acees自带的图片功能好像很弱（罗斯文里也太简单了点吧)（大家不要笑我，用了几年的Acess，这是我第一次使用图片) 这个是我花时间在网上找的如果用ole字段存取jpg图片，而且用image控件显示[attach]7874[/attach]
作者是叫 Stephen Lebans
真佩服国外的高手!!!
[此贴子已经被作者于2004-11-28 18:02:38编辑过]
作者: test2000 时间: 2004-12-1 17:33
也来一个: 打开属性窗体,单击任一工具集中的控件,设置此控件的默认属性. 十方便
作者: Trynew 时间: 2004-12-1 20:29
HZPY（String）:返回汉字拼音首字母函数：Function HZPY(hzstr As String) As String
Dim p0 As String, C As String, STR As String
Dim i As Integer, j As Integer
p0 = "吖八嚓咑妸发旮铪讥讥咔垃呣拿讴趴七呥仨他哇哇哇夕丫匝咗"
For i = 1 To Len(hzstr)
C = "z"
STR = Mid(hzstr, i, 1)
If Asc(STR) > 0 Then
C = STR
Else
For j = 1 To 26
If Mid(p0, j, 1) > STR Then
C = Chr(95 + j)
Exit For
End If
Next
End If
HZPY= HZPY+ C
Next
End Function
作者: yodong 时间: 2004-12-1 21:40
yangzn朋友的用ole字段存取jpg图片有错:出现提示找不到:ijl15.dll文件.
作者: zhengjialon 时间: 2004-12-1 22:00
以下是引用yodong在2004-12-1 13:39:38的发言：
yangzn朋友的
用ole字段存取jpg图片有错:
出现提示找不到:ijl15.dll文件.
ijl15.dll文件要先放到系统目录下如2000中在C:\WINNT\system32就行了.
[此贴子已经被作者于2004-12-2 8:13:15编辑过]
作者: skylark 时间: 2004-12-3 04:26
我用的不在列表中的代码，较为方便，用于不同的字段只要改一下表名即可。控件属性中标记为控件名也是表中字段名称，必须统一。Private Sub 材料_NotInList(NewData As String, Response As Integer)
Dim Rst As DAO.Recordset
Dim strName As String
Dim strMsg As String
strName = Me.ActiveControl.Tag
strMsg = "'" & NewData & "' is not an available '" & strName & "'"
strMsg = strMsg & "Do you want to associate the new Name to the current DLSAF?"
strMsg = strMsg & " Click Yes to link or No to re-type it."
Response = acDataErrContinue
If MsgBox(strMsg, vbQuestion + vbYesNo, "Add new name?") = vbYes Then
Set Rst = CurrentDb.OpenRecordset("材料表")
Rst.AddNew
Rst(strName) = NewData
Rst.Update
Rst.Close
Set Rst = Nothing
Me.Controls.Item(strName) = NewData
Me.Controls.Item(strName).Requery
Else
Me.Controls.Item(strName).Undo
End If
End Sub
作者: tmtony 时间: 2004-12-4 06:55
也来介绍一个工具,非常不错,主要用来处理过滤与通用查找的. 下载请到:
http://www.office-cn.net/Tools/ActiveXAddin/ActiveX/200412/108.asp
作者: chuting 时间: 2004-12-4 18:37
哈哈,学习
作者: Trynew 时间: 2004-12-5 20:20
自动编号。实现对字符型编号自动加1。
?auto_number('北京001‘)
显示为：北京002
?auto_number('001‘)
显示为：002
程序虽只有两行，但用到了好几个内置的字符串函数，还有前导0的处理：
StrReverse：字符串取反
Val：字符串转数值，取字符串左边数字，包括空格
Left：取字符串左边指定个数的子字符串，对应的还有Right,Mid
Len：返回字符串长度
Format：格式化字符串，这里是返回带前导0的数值
String：返回重复指定个数的字符的字符串，类似的有Space函数
Function AutoNum(strNum As String) As String
If Right(strNum, 1) = "0" Then
AutoNum = Left(strNum, Len(strNum) - 1) & "1"
Else
AutoNum = StrReverse(Val(StrReverse(strNum)))
AutoNum = Left(strNum, Len(strNum) - Len(AutoNum)) & Format((AutoNum + 1), String(Len(AutoNum), "0"))
End If
End Function
[此贴子已经被作者于2005-1-20 11:46:51编辑过]
作者: Trynew 时间: 2004-12-5 21:30
将秒为单位的如98989.90秒，转化为：时：分：＊＊.＊＊的形式的函数，如果前面是0则不显示！！Function SecToTime(dblSecond As Double) As String
SecToTime = Format((Int(dblSecond) / 60 / 60 / 24), "HH:MM:SS")
If Int(dblSecond) <> dblSecond Then SecToTime = SecToTime & Round(dblSecond - Int(dblSecond), 2)
SecToTime = IIf(Left(SecToTime, 6) = "00:00:", Mid(SecToTime, 7), IIf(Left(SecToTime, 3) = "00:", Mid(SecToTime, 4), SecToTime))
End Function
作者: Trynew 时间: 2004-12-5 23:15
读取英语单词首字母的函数:Function GetWordZM(strEng As String) As String
Dim i As Integer, Var As Variant
Var = Split(strEng, " ")
For i = 0 To UBound(Var)
GetWordZM = GetWordZM & UCase(Left(Var(i), 1))
Next
End Function
作者: hgt 时间: 2004-12-6 00:27
在 ADP 中使用“域聚合函数”的方法
在 Access 帮助中说，ADP 中“域聚合函数”不能引用窗体控件。
不要相信，这是微软欺骗善男信女的。没有“域聚合函数”真的非常不方便。
比如：从前有只窗，窗上有只框，名字叫做“穷”。从前有个表，名字叫做“表”，表中有两列，叫做“鸡”和“钱”
MDB 的统计“钱”的方法：变量 = Dsum("钱", "表", "鸡=穷")
模糊统计：变量 = Dsum("钱", "表", "鸡 Like '*' & 穷 & '*'")
ADP 的统计“钱”的方法：变量 = Dsum("钱", "表", "鸡='" & 穷 & "'")
模糊统计：变量 = Dsum("钱", "表", "鸡 Like '" & '%' & 穷 & '%' & "'")
其他的如：Davg；Dcount；Dlookup；Dlast…… 用法一样。
在 ADP 事件中写“=Sum(a)”再移一移鼠标，点“...”就会弹出“表达式生成器”。
[此贴子已经被作者于2004-12-5 16:31:57编辑过]
作者: hgt 时间: 2004-12-6 08:13
在一对多的窗体中，父子窗体都有很多计算控件，控件自动计算时，Access非常不稳定，经常错误退出。
经过试验，发现父子窗体的“记录源”由原来绑定“表”都改为绑定“查询”后，非常稳定，再没有错误发生。
作者: Trynew 时间: 2004-12-7 21:55
汉字转拼音函数:HZQP()expression必需的。包含要转换的字符串。delimiter可选的。用于标识分隔拼音的字符串字符。如果忽略，则使用空格字符(" ")作为分隔符。如果delimiter是一个长度为零的字符串，则返回仅包含一个元素，即完整的 expression字符串。limit可选的。要返回拼音字符数，–1表示返回所有的拼音字符数，1表示返回拼音首字母。Function HZQP(expression As String, Optional delimiter As String = " ", Optional limit As Integer = -1) As String
Dim STR As String, arrWord(400) As String
Dim i As Integer, j As Integer
arrWord(1) = "吖a"
arrWord(2) = "哎ai"
arrWord(3) = "腤an"
arrWord(4) = "肮ang"
arrWord(5) = "凹ao"
arrWord(6) = "八ba"
arrWord(7) = "挀bai"
arrWord(8) = "扳ban"
arrWord(9) = "邦bang"
arrWord(10) = "勹bao"
arrWord(11) = "陂bei"
arrWord(12) = "奔ben"
arrWord(13) = "崩beng"
arrWord(14) = "皀bi"
arrWord(15) = "边bian"
arrWord(16) = "杓biao"
arrWord(17) = "憋bie"
arrWord(18) = "邠bin"
arrWord(19) = "仌bing"
arrWord(20) = "拨bo"
arrWord(21) = "峬bu"
arrWord(22) = "嚓ca"
arrWord(23) = "猜cai"
arrWord(24) = "飡can"
arrWord(25) = "仓cang"
arrWord(26) = "撡cao"
arrWord(27) = "冊ce"
arrWord(28) = "嵾cen"
arrWord(29) = "噌ceng"
arrWord(30) = "叉cha"
arrWord(31) = "拆chai"
arrWord(32) = "辿chan"
arrWord(33) = "伥chang"
arrWord(34) = "抄chao"
arrWord(35) = "车che"
arrWord(36) = "抻chen"
arrWord(37) = "阷cheng"
arrWord(38) = "吃chi"
arrWord(39) = "充chong"
arrWord(40) = "抽chou"
arrWord(41) = "出chu"
arrWord(42) = "搋chuai"
arrWord(43) = "巛chuan"
arrWord(44) = "刅chuang"
arrWord(45) = "吹chui"
arrWord(46) = "旾chun"
arrWord(47) = "踔chuo"
arrWord(48) = "呲ci"
arrWord(49) = "从cong"
arrWord(50) = "凑cou"
arrWord(51) = "粗cu"
arrWord(52) = "汆cuan"
arrWord(53) = "崔cui"
arrWord(54) = "邨cun"
arrWord(55) = "搓cuo"
arrWord(56) = "咑da"
arrWord(57) = "呆dai"
arrWord(58) = "丹dan"
arrWord(59) = "当dang"
arrWord(60) = "刀dao"
arrWord(61) = "恴de"
arrWord(62) = "灯deng"
arrWord(63) = "仾di"
arrWord(64) = "敁dian"
arrWord(65) = "刁diao"
arrWord(66) = "爹die"
arrWord(67) = "丁ding"
arrWord(68) = "丟diu"
arrWord(69) = "东dong"
arrWord(70) = "剅dou"
arrWord(71) = "嘟du"
arrWord(72) = "耑duan"
arrWord(73) = "垖dui"
arrWord(74) = "吨dun"
arrWord(75) = "多duo"
arrWord(76) = "妸e"
arrWord(77) = "奀en"
arrWord(78) = "儿er"
arrWord(79) = "发fa"
arrWord(80) = "帆fan"
arrWord(81) = "方fang"
arrWord(82) = "飞fei"
arrWord(83) = "分fen"
arrWord(84) = "丰feng"
arrWord(85) = "仏fo"
arrWord(86) = "紑fou"
arrWord(87) = "夫fu"
arrWord(88) = "旮ga"
arrWord(89) = "该gai"
arrWord(90) = "干gan"
arrWord(91) = "冈gang"
arrWord(92) = "皋gao"
arrWord(93) = "戈ge"
arrWord(94) = "给gei"
arrWord(95) = "根gen"
arrWord(96) = "更geng"
arrWord(97) = "工gong"
arrWord(98) = "勾gou"
arrWord(99) = "估gu"
arrWord(100) = "瓜gua"
arrWord(101) = "乖guai"
arrWord(102) = "关guan"
arrWord(103) = "光guang"
arrWord(104) = "归gui"
arrWord(105) = "衮gun"
arrWord(106) = "呙guo"
arrWord(107) = "铪ha"
arrWord(108) = "嗨hai"
arrWord(109) = "佄han"
arrWord(110) = "夯hang"
arrWord(111) = "蒿hao"
arrWord(112) = "诃he"
arrWord(113) = "黒hei"
arrWord(114) = "拫hen"
arrWord(115) = "亨heng"
arrWord(116) = "叿hong"
arrWord(117) = "侯hou"
arrWord(118) = "乎hu"
arrWord(119) = "花hua"
arrWord(120) = "怀huai"
arrWord(121) = "欢huan"
arrWord(122) = "巟huang"
arrWord(123) = "灰hui"
arrWord(124) = "昏hun"
arrWord(125) = "吙huo"
arrWord(126) = "丌ji"
arrWord(127) = "加jia"
arrWord(128) = "戋jian"
arrWord(129) = "江jiang"
arrWord(130) = "艽jiao"
arrWord(131) = "阶jie"
arrWord(132) = "巾jin"
arrWord(133) = "坕jing"
arrWord(134) = "冂jiong"
arrWord(135) = "丩jiu"
arrWord(136) = "凥ju"
arrWord(1
作者: HG 时间: 2004-12-9 01:14
不用在VBA中调用API,实现文件选取对话框!
http://www.office-cn.net/bbs/dispbbs.asp?boardID=5&ID=23272&page=1
作者: yangzn 时间: 2004-12-9 04:52
[attach]8028[/attach]
连这种变量类型都没，我用的是ACCESS2000
作者: HG 时间: 2004-12-10 17:39
请加入一个引用:你可以看看我的引用,是不是比你的多一个!Office 2000 Runtime 的引用![attach]8060[/attach]
[此贴子已经被作者于2004-12-10 10:00:51编辑过]
作者: keecome 时间: 2004-12-12 23:31
更新后即保存记录 DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
作者: gnoy 时间: 2004-12-13 00:45
'--------============转二进制函数=============--------'Adapt By:Gnoy'-------------------------------------------------------------------------Private Declare Sub CopyMemory _
Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal length As Long)Public Function ByteArrayAsBin(ByVal b As Variant) As String
Dim z As Long
Dim u As Long
u = UBound(b)
For z = 0 To u
ByteArrayAsBin = ByteArrayAsBin & ByteAsBin(b(z))
If z <> u Then
If (z + 1) Mod 4 = 0 Then
ByteArrayAsBin = ByteArrayAsBin & vbNewLine
Else
ByteArrayAsBin = ByteArrayAsBin & " "
End If
End If
Next z
End FunctionPublic Function ByteAsBin(ByVal b As Byte) As String
Dim z As Long
For z = 7 To 0 Step -1
ByteAsBin = ByteAsBin & Abs(CLng(CBool(b And (2 ^ z))))
Next z
End FunctionPublic Function CurrencyAsBin(ByVal c As Currency) As String
Dim b(7) As Byte
CopyMemory b(0), c, 8
CurrencyAsBin = ByteArrayAsBin(b)
End FunctionPublic Function DateAsBin(ByVal d As Date) As String
Dim b(7) As Byte
CopyMemory b(0), d, 8
DateAsBin = ByteArrayAsBin(b)
End FunctionPublic Function DoubleAsBin(ByVal d As Double) As String
Dim b(7) As Byte
CopyMemory b(0), d, 8
DoubleAsBin = ByteArrayAsBin(b)
End FunctionPublic Function IntegerAsBin(ByVal i As Integer) As String
Dim b(1) As Byte
CopyMemory b(0), i, 2
IntegerAsBin = ByteArrayAsBin(b)
End FunctionPublic Function LongAsBin(ByVal l As Long) As String
Dim b(3) As Byte
CopyMemory b(0), l, 4
LongAsBin = ByteArrayAsBin(b)
End FunctionPublic Function SingleAsBin(ByVal s As Single) As String
Dim b(3) As Byte
CopyMemory b(0), s, 4
SingleAsBin = ByteArrayAsBin(b)
End FunctionPublic Function StringAsBin(ByVal s As String) As String
Dim b() As Byte
Dim z As Long
Dim u As Long
b = StrConv(s, vbFromUnicode)
StringAsBin = ByteArrayAsBin(b)
End Function
作者: Trynew 时间: 2004-12-17 20:07
让表中的所有空值等于其对应字段的上一条记录值的函数，rstName是表名或查询的名称，要引用DAOPublic Function InsNullFld(rstName As String) As Boolean
Dim rst1 As DAO.Recordset, rst2 As DAO.Recordset
Dim i As Integer, isChn As Boolean
Set rst1 = CurrentDb().OpenRecordset(rstName)
Set rst2 = CurrentDb().OpenRecordset(rstName)
rst2.MoveNext
Do While Not rst2.EOF
rst2.Edit
isChn = False
For i = 0 To rst2.Fields.Count - 1
If IsNull(rst2.Fields(i)) Then
rst2.Fields(i) = rst1.Fields(i)
isChn = True
InsNullFld = True
End If
Next
If isChn Then rst2.Update
rst1.MoveNext
rst2.MoveNext
Loop
End Function
作者: hgt 时间: 2004-12-17 21:25
如果一对多关系的表，用了“自动编号”连接，就会备份后不能还原，因为“自动编号”不能写入。
可以用办法代替“自动编号”，也能实现“自动编号”的功能。下面办法是“Lwwvb”版主发明的，我把它改進了。
支持多用户同时使用，不会冲突，不会重复编号。可以完全代替“自动编号”
1；做一个表，只有一行，放个 Int 类型的字段“ID”，初值为“0”用来放参考编号，
2；做一个“更新查询”更新这个“ID”，使每次执行“[ID] + 1”作为“自动编号”用。
3；在窗体的“插入前”写事件，先执行“更新查询”，然后取得这个“ID”值放在窗体“ID”控件的“默认值”里面。再在“插入后”事件清除“默认值”。
注意：要有控件绑定“ID”，控件才有“默认值”，窗体的字段没有“默认值”，数据表可以使用隐藏列。
[此贴子已经被作者于2004-12-17 13:26:14编辑过]
作者: hgt 时间: 2004-12-19 01:01
可是很不幸，上面那种方法不能在 ODBC 中的 数据表 粘贴多行。
作者: Trynew 时间: 2004-12-20 17:52
由字段名称求字段标题函数及由字段标题求字段名称函数
ublic Function GetFldName(TblName As String, FldCaption As String) As String
On Error Resume Next
Dim rst As DAO.Recordset, i As Integer
Set rst = CurrentDb().OpenRecordset(TblName)
For i = 0 To rst.Fields.Count - 1
If rst.Fields(i).Properties("Caption") = FldCaption Then
GetFldName = rst.Fields(i).Name
Exit For
End If
Next
End FunctionPublic Function GetFldCaption(TblName As String, FldName As String) As String
On Error Resume Next
Dim rst As DAO.Recordset
Set rst = CurrentDb().OpenRecordset(TblName)
GetFldCaption = rst.Fields(FldName).Properties("Caption")
End Function
如果在窗体内部应用，则不需要表名参数，用Me.Recordset来代替上面函数的Rst即可。Private Function GetFldName(FldCaption As String) As String
On Error Resume Next
Dim i As Integer
For i = 0 To Me.Recordset.Fields.Count - 1
If Me.Recordset.Fields(i).Properties("Caption") = FldCaption Then
GetFldName = Me.Recordset.Fields(i).Name
Exit For
End If
Next
End FunctionPrivate Function GetFldCaption(FldName As String) As String
GetFldCaption = Me.Recordset.Fields(FldName).Properties("Caption")
End Function
作者: ntcat 时间: 2004-12-28 19:13
关于取得汉字的第一个拼音字母的函数,推荐使用我的GetPyAbOfHz函数.速度比上述HZPY快一倍. 不信? 测试代码附后Public Function GetFirstChr(ByVal sSrc As String)
Dim sTemp As String
sTemp = Left(sSrc, 1)
Select Case Asc(sTemp)
Case 48 To 122
GetFirstChr = sTemp
Case Is >= Asc("匝")
GetFirstChr = "Z"
Case Is >= Asc("压")
GetFirstChr = "Y"
Case Is >= Asc("昔")
GetFirstChr = "X"
Case Is >= Asc("挖")
GetFirstChr = "W"
Case Is >= Asc("塌")
GetFirstChr = "T"
Case Is >= Asc("撒")
GetFirstChr = "S"
Case Is >= Asc("然")
GetFirstChr = "R"
Case Is >= Asc("期")
GetFirstChr = "Q"
Case Is >= Asc("啪")
GetFirstChr = "
"
Case Is >= Asc("哦")
GetFirstChr = "O"
Case Is >= Asc("拿")
GetFirstChr = "N"
Case Is >= Asc("妈")
GetFirstChr = "M"
Case Is >= Asc("垃")
GetFirstChr = "L"
Case Is >= Asc("喀")
GetFirstChr = "K"
Case Is >= Asc("击")
GetFirstChr = "J"
Case Is >= Asc("哈")
GetFirstChr = "H"
Case Is >= Asc("噶")
GetFirstChr = "G"
Case Is >= Asc("发")
GetFirstChr = "F"
Case Is >= Asc("蛾")
GetFirstChr = "E"
Case Is >= Asc("搭")
GetFirstChr = "D"
Case Is >= Asc("擦")
GetFirstChr = "C"
Case Is >= Asc("芭")
GetFirstChr = "B"
Case Is >= Asc("啊")
GetFirstChr = "A"
Case Else
GetFirstChr = "0"
End Select
End Function
'取得汉字的拼音缩写
Public Function GetPyAbOfHz(ByVal sHz As String) As String
Dim sTmp, ch As String
Dim i As Integer
For i = 1 To Len(sHz)
ch = Mid(sHz, i, 1)
Select Case ch
Case ".", "(", ")", "+", "-"
sTmp = sTmp & ch
Case " "
Case Else
sTmp = sTmp & GetFirstChr(ch)
End Select
Next
GetPyAbOfHz = sTmp
End Function
'----------------------------------------速度测试代码:---------Public Sub speed_HZPY()
Dim a1 As Single
Dim i As Long a1 = Timer
For i = 1 To 66542
HZPY ("地要不是在遥呐喊浊夺标炽烈二有遥感地于规划")
Next
Debug.Print Timer - a1
End Sub
Public Sub SPEED_GetPyAbOfHz()
Dim a1 As Single
Dim i As Long
a1 = Timer
For i = 1 To 66542
GetPyAbOfHz ("地要不是在遥呐喊浊夺标炽烈二有遥感地于规划")
Next
Debug.Print Timer - a1
End Sub
作者: 方漠 时间: 2004-12-30 01:20
汉字拼音首字母，我也贴一个，不过不是我写的。呵呵！'HZPY（String）:返回汉字拼音首字母函数：Function HZPY(hzstr As String) As String
Dim p0 As String, C As String, STR As String
Dim i As Integer, j As Integer
p0 = "吖八嚓咑妸发旮铪讥讥咔垃呣拿讴趴七呥仨他哇哇哇夕丫匝咗"
For i = 1 To Len(hzstr)
C = "z"
STR = Mid(hzstr, i, 1)
If Asc(STR) > 0 Then
C = STR
Else
For j = 1 To 26
If Mid(p0, j, 1) > STR Then
C = Chr(95 + j)
Exit For
End If
Next
End If
HZPY = HZPY + C
Next
End Function
作者: Trynew 时间: 2004-12-30 21:56
如何使窗体只能新增记录，不能修改旧记录在窗体的成为当前记录时间增加如下语句Private Sub Form_Current()
Me.AllowEdits = Me.NewRecord
End Sub
作者: 灵芝 时间: 2005-1-10 04:22
标题: 回楼上
回楼上,试过好用
但:如果strNum 尾数为0时会出错,如strNum =10,算法还得再加一句.
作者: Trynew 时间: 2005-1-20 19:51
以下是引用灵芝在2005-1-9 20:22:29的发言：
回楼上,试过好用
但:如果strNum 尾数为0时会出错,如strNum =10,算法还得再加一句.
Function AutoNum(strNum As String) As String
AutoNum = StrReverse(Val(StrReverse(strNum)))
AutoNum = IIf(Right(strNum, 1) = "0", Left(strNum, Len(strNum) - 1) & "1", Left(strNum, Len(strNum) - Len(AutoNum)) & Format((AutoNum + 1), String(Len(AutoNum), "0")))
End Function
作者: Trynew 时间: 2005-1-20 19:57
支持拼音首字母的组合框函数及实例(非常实用，能大大提高选择和录入速度)
Public Function ComboBoxKeyPress(KeyAscii As Integer) As String
'调用方法 在组合框的keypress方法中加入:
'--------------------------------------------
' If ComboBoxKeyPress(KeyAscii) <> "" Then KeyAscii = 0
'--------------------------------------------
On Error GoTo Err
Dim i As Integer
With Screen.ActiveControl
If .ControlType = acComboBox And (KeyAscii >= Asc("a") And KeyAscii <= Asc("z")) Then
'只能由组合框输入小写字母时调用
ComboBoxKeyPress = Nz(HZPY(Left(.Text, .SelStart))) & Chr(KeyAscii)
While HZPY(Left(.ItemData(i), .SelStart + 1)) <> ComboBoxKeyPress And i < .ListCount - 1
i = i + 1
Wend
If i <> .ListCount And Mid(.ItemData(i), .SelStart + 1, 1) <> Chr(KeyAscii) Then
ComboBoxKeyPress = Left(.ItemData(i), .SelStart + 1)
.Value = Null
SendKeys ComboBoxKeyPress
Else
ComboBoxKeyPress = "" '为英文时不代换，否则会进入死循环
End If
End If
End With
Exit Function
Err:
ComboBoxKeyPress = ""
End FunctionFunction HZPY(hzstr As String) As String
Dim p0 As String, C As String, str As String
Dim i As Integer, j As Integer
p0 = "吖八嚓咑妸发旮铪讥讥咔垃呣拿讴趴七呥仨他哇哇哇夕丫匝咗"
For i = 1 To Len(hzstr)
C = "z"
str = Mid(hzstr, i, 1)
If Asc(str) > 0 Then
C = str
Else
For j = 1 To 26
If Mid(p0, j, 1) > str Then
C = Chr(95 + j)
Exit For
End If
Next
End If
HZPY = HZPY + C
Next
End Function
作者: xinbao 时间: 2005-1-25 03:36
楼上非常棒!
作者: 竹笛 时间: 2005-1-28 04:14
哇，这么多好技巧，我也弄了一些，在：http://www.accessoft.com/Article_Special.asp?SpecialID=1
作者: ui 时间: 2005-2-2 08:57
vba.kill
vba.copy
作者: winterbells7 时间: 2005-3-9 23:50
hehe这个好玩
作者: Trynew 时间: 2005-3-23 20:45
ceiling函数 是Excel中的向上舍入函数，可以在引用Excel对象库后使用(包括其它Excel中的函数)，如msgbox Excel.WorksheetFunction.Ceiling(129.99,0.05)另外也可以在Access中自定义：Public Function Ceiling(Num As Double, Sign As Double) As Double
Dim intDot As Integer
intDot = IIf(InStr(Sign, ".") = 0, 0, Len(Sign) - InStr(Sign, "."))
Num = Int(Num * 10 ^ intDot)
Sign = Sign * 10 ^ intDot
Ceiling = (Num + IIf(Num Mod Sign = 0, 0, Sign) - (Num Mod Sign)) / 10 ^ intDot
End Function
作者: 000618 时间: 2005-3-26 03:39
标题: 我也正有一个这样的问题急待回答
如何让OLE对象反映到窗体或报表上的尺寸正好匹配
在数据库中保存或链接的OLE对象，反到窗体和报表上尺寸大小不匹配，有时只是显示局部一点，怎样使其匹配。请帮助．
作者: 八哥 时间: 2005-3-29 20:48
好厉害
作者: Trynew 时间: 2005-3-30 16:39
下面的程序效率不是很高，但超大整数乘法、加法的函数还是比较实用
Public Function factorial(num As Integer) As String
factorial = "1"
For num = num To 1 Step -1
factorial = strMult(factorial, Trim(Str(num)))
Next
End Function'1000 的阶乘=40238726007709377354370243392300398571937...用时6分钟
'超大整数乘法 （需调用下面的strAdd、strPlus自定义函数）
Public Function strMult(str1 As String, str2 As String) As String
Dim i As Integer
If Len(str2) = 1 Then
strMult = IIf(str2 = "0", "", str1)
For i = 1 To Val(str2) - 1
strMult = strAdd(strMult, str1)
Next
Else
strMult = strAdd(strMult(str1, Right(str2, 1)), strMult(str1 & "0", Left(str2, Len(str2) - 1)))
End If
End Function'超大整数加法 （需调用下面的strPlus自定义函数）
Public Function strAdd(str1 As String, str2 As String) As String
If Len(str1) < Len(str2) Then
strAdd = strAdd(str2, str1)
Else
Dim num As Long
strAdd = strPlus(str1, "", Val(Right(str2, 1)))
For num = 1 To Len(str2) - 1
strAdd = strPlus(Left(strAdd, Len(strAdd) - num), Right(strAdd, num), Val(Mid(str2, Len(str2) - num, 1)))
Next
End If
End FunctionPublic Function strPlus(str1 As String, str2 As String, num As Integer) As String
If Len(str1) = 1 Then
strPlus = (Val(str1) + num) & str2
Else
num = Val(Right(str1, 1)) + num
If num < 10 Then
strPlus = Left(str1, Len(str1) - 1) & num & str2
Else
strPlus = strPlus(Left(str1, Len(str1) - 1), (num Mod 10) & str2, 1)
End If
End If
End Function
作者: pxbld 时间: 2005-3-30 21:37
标题: 高
有用。只是，看了半天才明白。
只是中文的ASC码，从哪里能找到呢？
作者: 断翅 时间: 2005-3-31 20:26
俺是菜鸟，啥都看不懂。
作者: pxbld 时间: 2005-4-4 22:43
Private Sub Form_Timer()
Me!lblClock.Caption = Format(Now, "dddd, mmm d yyyy, hh:mm:ss AMPM")
End Sub
作者: tmtony 时间: 2005-4-7 01:29
取文本文件的行数
注意: myInFile是文件名 适应大小文件 (tmtony)
Function lineCount(myInFile As String) As Long
Dim lFileSize As Long, lChunk As Long
Dim bFile() As Byte
Dim lSize As Long
Dim strText As String
lSize = CLng(1024) * 10
ReDim bFile(lSize - 1) As Byte
Open myInFile For Binary As #1
lFileSize = LOF(1)
lChunk = 1
Do While (lSize * lChunk) < lFileSize
Get #1, , bFile
strText = StrConv(bFile, vbUnicode)
lineCount = lineCount + searchText(strText)
lChunk = lChunk + 1
<ST1LACE>Loop</ST1LACE>
ReDim bFile((lFileSize - (lSize * (lChunk - 1))) - 1) As Byte
Get #1, , bFile
strText = StrConv(bFile, vbUnicode)
lineCount = lineCount + searchText(strText)
Close #1
lineCount = lineCount + 1
End Function
作者: lanchong 时间: 2005-4-7 03:03
谁给个MD5加密密码的函数阿，免得用户的密码谁都看得见
作者: tmtony 时间: 2005-4-7 03:18
MD5加密算法:
Option Explicit
Dim w1 As String, w2 As String, w3 As String, w4 As String
Function MD5F(ByVal tempstr As String, ByVal w As String, ByVal X As S
tring, ByVal y As String, ByVal z As String, ByVal Xin As String, ByVa
l qdata As String, ByVal rots As Integer)
MD5F = BigMod32Add(RotLeft(BigMod32Add(BigMod32Add(w, tempstr), Bi
gMod32Add(Xin, qdata)), rots), X)
End Function
Sub MD5F1(w As String, ByVal X As String, ByVal y As String, ByVal z A
s String, ByVal Xin As String, ByVal qdata As String, ByVal rots As In
teger)
Dim tempstr As String
tempstr = BigXOR(z, BigAND(X, BigXOR(y, z)))
w = MD5F(tempstr, w, X, y, z, Xin, qdata, rots)
End Sub
Sub MD5F2(w As String, ByVal X As String, ByVal y As String, ByVal z A
s String, ByVal Xin As String, ByVal qdata As String, ByVal rots As In
teger)
Dim tempstr As String
tempstr = BigXOR(y, BigAND(z, BigXOR(X, y)))
w = MD5F(tempstr, w, X, y, z, Xin, qdata, rots)
End Sub
Sub MD5F3(w As String, ByVal X As String, ByVal y As String, ByVal z A
s String, ByVal Xin As String, ByVal qdata As String, ByVal rots As In
teger)
Dim tempstr As String
tempstr = BigXOR(X, BigXOR(y, z))
w = MD5F(tempstr, w, X, y, z, Xin, qdata, rots)
End Sub
Sub MD5F4(w As String, ByVal X As String, ByVal y As String, ByVal z A
s String, ByVal Xin As String, ByVal qdata As String, ByVal rots As In
teger)
Dim tempstr As String
tempstr = BigXOR(y, BigOR(X, BigNOT(z)))
w = MD5F(tempstr, w, X, y, z, Xin, qdata, rots)
End Sub
Function MD5_Calc(ByVal hashthis As String) As String
ReDim buf(0 To 3) As String
ReDim Xin(0 To 15) As String
Dim tempnum As Integer, tempnum2 As Integer, loopit As Integer, loopou
ter As Integer, loopinner As Integer
Dim a As String, b As String, c As String, d As String
' Add padding
tempnum = 8 * Len(hashthis)
hashthis = hashthis + Chr$(128) 'Add binary 10000000
tempnum2 = 56 - Len(hashthis) Mod 64
If tempnum2 < 0 Then
tempnum2 = 64 + tempnum2
End If
hashthis = hashthis + String$(tempnum2, Chr$(0))
For loopit = 1 To 8
hashthis = hashthis + Chr$(tempnum Mod 256)
tempnum = tempnum - tempnum Mod 256
tempnum = tempnum / 256
Next loopit
' Set magic numbers
buf(0) = "67452301"
buf(1) = "efcdab89"
buf(2) = "98badcfe"
buf(3) = "10325476"
' For each 512 bit section
For loopouter = 0 To Len(hashthis) / 64 - 1
a = buf(0)
b = buf(1)
c = buf(2)
d = buf(3)
' Get the 512 bits
For loopit = 0 To 15
Xin(loopit) = ""
For loopinner = 1 To 4
Xin(loopit) = Hex$(Asc(Mid$(hashthis, 64 * loopouter +
4 * loopit + loopinner, 1))) + Xin(loopit)
If Len(Xin(loopit)) Mod 2 Then Xin(loopit) = "0" + Xin
(loopit)
Next loopinner
Next loopit
' Round 1
MD5F1 a, b, c, d, Xin(0), "d76aa478", 7
MD5F1 d, a, b, c, Xin(1), "e8c7b756", 12
MD5F1 c, d, a, b, Xin(2), "242070db", 17
MD5F1 b, c, d, a, Xin(3), "c1bdceee", 22
MD5F1 a, b, c, d, Xin(4), "f57c0faf", 7
MD5F1 d, a, b, c, Xin(5), "4787c62a", 12
MD5F1 c, d, a, b, Xin(6), "a8304613", 17
MD5F1 b, c, d, a, Xin(7), "fd469501", 22
MD5F1 a, b, c, d, Xin(8), "698098d8", 7
MD5F1 d, a, b, c, Xin(9), "8b44f7af", 12
MD5F1 c, d, a, b, Xin(10), "ffff5bb1", 17
MD5F1 b, c, d, a, Xin(11), "895cd7be", 22
MD5F1 a, b, c, d, Xin(12), "6b901122", 7
MD5F1 d, a, b, c, Xin(13), "fd987193", 12
MD5F1 c, d, a, b, Xin(14), "a679438e", 17
MD5F1 b, c,
作者: lanchong 时间: 2005-4-7 04:21
标题: 老大啊，该用哪个才对啊
老大啊，该用哪个才对啊
MD5_Calc("123456")显示空的
不过俺到http://access911.net找了个dll
http://access911.net/down/software/msppmd5.rar (13KB)
解压缩后用 REGSVR32.EXE C:\TEMP\msppmd5.dll 可以注册
Function test_MD5()
'引用 ComMD5 1.0 Type Library
'该类库定位于 msppmd5.dll
Dim a As New CoMD5
Debug.Print a.MD5Hash("a")
Debug.Print a.MD5Hash("a")
End Function
作者: tmtony 时间: 2005-4-7 04:38
做了一个给你,用DLL也可, 不用DLL也可(可免注册,安装方便一点) 功能类似
[attach]9782[/attach]
作者: lanchong 时间: 2005-4-7 05:24
难道是俺的rpwt,直接在你的案例里放个按钮，出来都是空
Private Sub 命令0_Click()
On Error GoTo Err_命令0_Click
MsgBox MD5_Calc("12345")
Exit_命令0_Click:
Exit Sub
Err_命令0_Click:
MsgBox Err.Description
Resume Exit_命令0_Click
End Sub
[em06]
作者: lanchong 时间: 2005-4-7 17:13
救命啊，谁给个windows 2k可用的md5.dll
<!-- / icon and title --><!-- message -->
想找个能在office 2k vba里用的md5加密dll
上面找到的[http://access911.net/down/software/msppmd5.rar (13KB)]只能在windowsxp里用，555555，厂内大多是windows2k
tmtony的俺也没法用<!-- / message -->
作者: lanchong 时间: 2005-4-7 18:20
找到了一篇，唉，又得改程序，又得重新编译
VB中实现MD5加密
http://www.pcdog.com -- 互联网
msgbox DigestStrToHexStr("111")
源代码:
-----------剪切线------------------------------------------------------------
Option Explicit
'/******************************************************************************
' * Copyright (C) 2000 by Robert Hubley. *
' * All rights reserved. *
' * *
' * This software is provided ``AS IS'' and any express or implied *
' * warranties, including, but not limited to, the implied warranties of *
' * merchantability and fitness for a particular purpose, are disclaimed. *
' * In no event shall the authors be liable for any direct, indirect, *
' * incidental, special, exemplary, or consequential damages (including, but *
' * not limited to, procurement of substitute goods or services; loss of use, *
' * data, or profits; or business interruption) however caused and on any *
' * theory of liability, whether in contract, strict liability, or tort *
' * (including negligence or otherwise) arising in any way out of the use of *
' * this software, even if advised of the possibility of such damage. *
' * *
' ******************************************************************************
'
' CLASS: MD5
'
' DESCRIPTION:
' This is a class which encapsulates a set of MD5 Message Digest functions.
' MD5 algorithm produces a 128 bit digital fingerprint (signature) from an
' dataset of arbitrary length. For details see RFC 1321 (summarized below).
' This implementation is derived from the RSA Data Security, Inc. MD5 Message-Digest
' algorithm reference implementation (originally written in C)
'
' AUTHOR:
' Robert M. Hubley 12/1999
'
'
' NOTES:
' Network Working Group R. Rivest
' Request for Comments: 1321 MIT Laboratory for Computer Science
' and RSA Data Security, Inc.
' April 1992
'
'
' The MD5 Message-Digest Algorithm
'
' Summary
'
' This document describes the MD5 message-digest algorithm. The
' algorithm takes as input a message of arbitrary length and produces
' as output a 128-bit "fingerprint" or "message digest" of the input.
' It is conjectured that it is computationally infeasible to produce
' two messages having the same message digest, or to produce any
' message having a given prespecified target message digest. The MD5
' algorithm is intended for digital signature applications, where a
' large file must be "compressed" in a secure manner before being
' encrypted with a private (secret) key under a public-key cryptosystem
' such as RSA.
'
' The MD5 algorithm is designed to be quite fast on 32-bit machines. In
' addition, the MD5 algorithm does not require any large substitution
' tables; the algorithm can be coded quite compactly.
'
' The MD5 algorithm is an extension of the MD4 message-digest algorithm
' 1,2]. MD5 is slightly slower than MD4, but is more "conservative" in
' design. MD5 was designed because it was felt that MD4 was perhaps
' being adopted for use more quickly than justified by the existing
' critical review; because MD4 was designed to be exceptionally fast,
' it is "at the edge" in terms of risking successful cryptanalytic
' attack. MD5
作者: lanchong 时间: 2005-4-7 18:22
' Initialize the class
' This must be called before a digest calculation is started
'
Public Sub MD5Init()
ByteCounter = 0
State(1) = UnsignedToLong(1732584193#)
State(2) = UnsignedToLong(4023233417#)
State(3) = UnsignedToLong(2562383102#)
State(4) = UnsignedToLong(271733878#)
End Sub
'
' MD5 Final
'
Public Sub MD5Final()
Dim dblBits As Double
Dim padding(72) As Byte
Dim lngBytesBuffered As Long
padding(0) = &H80
dblBits = ByteCounter * 8
' Pad out
lngBytesBuffered = ByteCounter Mod 64
If lngBytesBuffered <= 56 Then
MD5Update 56 - lngBytesBuffered, padding
Else
MD5Update 120 - ByteCounter, padding
End If
padding(0) = UnsignedToLong(dblBits) And &HFF&
padding(1) = UnsignedToLong(dblBits) \ 256 And &HFF&
padding(2) = UnsignedToLong(dblBits) \ 65536 And &HFF&
padding(3) = UnsignedToLong(dblBits) \ 16777216 And &HFF&
padding(4) = 0
padding(5) = 0
padding(6) = 0
padding(7) = 0
MD5Update 8, padding
End Sub
'
' Break up input stream into 64 byte chunks
'
Public Sub MD5Update(InputLen As Long, InputBuffer() As Byte)
Dim II As Integer
Dim I As Integer
Dim J As Integer
Dim K As Integer
Dim lngBufferedBytes As Long
Dim lngBufferRemaining As Long
Dim lngRem As Long
lngBufferedBytes = ByteCounter Mod 64
lngBufferRemaining = 64 - lngBufferedBytes
ByteCounter = ByteCounter + InputLen
' Use up old buffer results first
If InputLen >= lngBufferRemaining Then
For II = 0 To lngBufferRemaining - 1
ByteBuffer(lngBufferedBytes + II) = InputBuffer(II)
Next II
MD5Transform ByteBuffer
lngRem = (InputLen) Mod 64
' The transfer is a multiple of 64 lets do some transformations
For I = lngBufferRemaining To InputLen - II - lngRem Step 64
For J = 0 To 63
ByteBuffer(J) = InputBuffer(I + J)
Next J
MD5Transform ByteBuffer
Next I
lngBufferedBytes = 0
Else
I = 0
End If
' Buffer any remaining input
For K = 0 To InputLen - I - 1
ByteBuffer(lngBufferedBytes + K) = InputBuffer(I + K)
Next K
End Sub
'
' MD5 Transform
'
Private Sub MD5Transform(Buffer() As Byte)
Dim x(16) As Long
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
a = State(1)
b = State(2)
c = State(3)
d = State(4)
Decode 64, x, Buffer
' Round 1
FF a, b, c, d, x(0), S11, -680876936
FF d, a, b, c, x(1), S12, -389564586
FF c, d, a, b, x(2), S13, 606105819
FF b, c, d, a, x(3), S14, -1044525330
FF a, b, c, d, x(4), S11, -176418897
FF d, a, b, c, x(5), S12, 1200080426
FF c, d, a, b, x(6), S13, -1473231341
FF b, c, d, a, x(7), S14, -45705983
FF a, b, c, d, x(8), S11, 1770035416
FF d, a, b, c, x(9), S12, -1958414417
FF c, d, a, b, x(10), S13, -42063
FF b, c, d, a, x(11), S14, -1990404162
FF a, b, c, d, x(12), S11, 1804603682
FF d, a, b, c, x(13), S12, -40341101
FF c, d, a, b, x(14), S13, -1502002290
FF b, c, d, a, x(15), S14, 1236535329
' Round 2
GG a, b, c, d, x(1), S21, -165796510
GG d, a, b, c, x(6), S22, -1069501632
GG c, d, a, b, x(11), S23, 643717713
GG b, c, d, a, x(0), S24, -373897302
GG a, b, c, d, x(5), S21, -701558691
GG d, a, b, c, x(10), S22, 38016083
GG c, d, a, b, x(15), S23, -660478335
GG b, c, d, a, x(4), S24, -405537848
GG a, b, c, d, x(9), S21, 568446438
GG d, a, b, c, x(14), S22, -1019803690
作者: lanchong 时间: 2005-4-12 23:10
谁帮写个清除空格的函数，不管空格在字段何处，通通清除
作者: xlonger 时间: 2006-8-4 23:24
以下是引用ntcat在2004-12-28 11:13:00的发言：
关于取得汉字的第一个拼音字母的函数,推荐使用我的GetPyAbOfHz函数.速度比上述HZPY快一倍. 不信? 测试代码附后
Public Function GetFirstChr(ByVal sSrc As String)
Dim sTemp As String
sTemp = Left(sSrc, 1)
Select Case Asc(sTemp)
Case 48 To 122
GetFirstChr = sTemp
Case Is >= Asc("匝")
GetFirstChr = "Z"
Case Is >= Asc("压")
GetFirstChr = "Y"
Case Is >= Asc("昔")
GetFirstChr = "X"
Case Is >= Asc("挖")
GetFirstChr = "W"
Case Is >= Asc("塌")
GetFirstChr = "T"
Case Is >= Asc("撒")
GetFirstChr = "S"
Case Is >= Asc("然")
GetFirstChr = "R"
Case Is >= Asc("期")
GetFirstChr = "Q"
Case Is >= Asc("啪")
GetFirstChr = ""
Case Is >= Asc("哦")
GetFirstChr = "O"
Case Is >= Asc("拿")
GetFirstChr = "N"
Case Is >= Asc("妈")
GetFirstChr = "M"
Case Is >= Asc("垃")
GetFirstChr = "L"
Case Is >= Asc("喀")
GetFirstChr = "K"
Case Is >= Asc("击")
GetFirstChr = "J"
Case Is >= Asc("哈")
GetFirstChr = "H"
Case Is >= Asc("噶")
GetFirstChr = "G"
Case Is >= Asc("发")
GetFirstChr = "F"
Case Is >= Asc("蛾")
GetFirstChr = "E"
Case Is >= Asc("搭")
GetFirstChr = "D"
Case Is >= Asc("擦")
GetFirstChr = "C"
Case Is >= Asc("芭")
GetFirstChr = "B"
Case Is >= Asc("啊")
GetFirstChr = "A"
Case Else
GetFirstChr = "0"
End Select
End Function
'取得汉字的拼音缩写
Public Function GetPyAbOfHz(ByVal sHz As String) As String
Dim sTmp, ch As String
Dim i As Integer
For i = 1 To Len(sHz)
ch = Mid(sHz, i, 1)
Select Case ch
Case ".", "(", ")", "+", "-"
sTmp = sTmp & ch
Case " "
Case Else
sTmp = sTmp & GetFirstChr(ch)
End Select
Next
GetPyAbOfHz = sTmp
End Function
'----------------------------------------速度测试代码:---------
Public Sub speed_HZPY()
Dim a1 As Single
Dim i As Long
a1 = Timer
For i = 1 To 66542
HZPY ("地要不是在遥呐喊浊夺标炽烈二有遥感地于规划")
Next
Debug.Print Timer - a1
End Sub
Public Sub SPEED_GetPyAbOfHz()
Dim a1 As Single
Dim i As Long
a1 = Timer
For i = 1 To 66542
GetPyAbOfHz ("地要不是在遥呐喊浊夺标炽烈二有遥感地于规划")
Next
Debug.Print Timer - a1
End Sub
你的函数不认识，“埭”，字，但能判断“金属”为JS。HZPY判断“金属”为JZ,但认识“埭”字。
作者: 菩明本何 时间: 2006-9-24 18:59
以下是引用lanchong在2005-4-12 15:10:00的发言：
谁帮写个清除空格的函数，不管空格在字段何处，通通清除
新鲜出炉。你试试！！嘿嘿。。。
Public Function txtpu(text As Variant)
If Not IsNull(text) Then '字符串为空时不计算
Dim my1 As Integer '取字符起始位置
Dim my2 As Integer '取字符终止位置
Dim mytt As Variant ' 取字符
' Dim text As Variant '原始字符串
Dim txt As Variant ' 结果
' text = text
my1 = 1 '起始位数
While my1 < Len(text) '循环次数
my2 = InStr(my1, text, " ", 1) '取得截取字符的结束位置
If my2 > 0 Then '是否为最后一次到值
mytt = Mid(text, my1, my2 - my1)
my1 = my2 + 1 '计数器加1
Else
mytt = Mid(text, my1)
my1 = Len(text) + 100 '计数加100。退出循环
End If
txt = txt & Trim(mytt)
Wend
txtpu = txt
End If
End Function
[此贴子已经被作者于2006-9-24 10:59:30编辑过]
作者: Trynew 时间: 2006-9-25 16:56
以下是引用lanchong在2005-4-12 15:10:00的发言：
谁帮写个清除空格的函数，不管空格在字段何处，通通清除
可以直接使用string=Replace(string," ",""),要连全角的空格也清除可以这样：
? replace(replace(" 123 123 qwer qwer ｑｗｅｒ ｑｗｅｒ ",chr(32),""),chr(-24159),"")
作者: Trynew 时间: 2006-9-28 17:31
Public Function jjos(x As Double, m As Integer, n As Integer)
'// **“四舍六入，逢五奇进偶舍”自定义函数过程 **
'// 函数形式 jjos(x,m,n) ,返回值ret_jjos为 Decimal 型
'// x为操作数值, m为最多保留小数位数,n为有效数字位数
'// m、n皆为 Integer 型
'// m = 0 表示取整数,n = 0 表示对有效数字无要求
Dim i As Integer, ret_jjos As Double, j As Integer
j = 1
If x < 0 Then j = -1 ' //j用于记忆是正数还是负数
If n > 0 Then
Do While Abs(x) >= 10 ^ (n - m)
x = x / 10 '//向前移动一个小数点
i = i + 1
Loop
End If
If Int(x * 10 ^ (m + 1)) = x * 10 ^ (m + 1) Then
x = Round(x, m + 2)
ret_jjos = Val(Left(Right(Str(x), 3), 1))
If Right(Str(x), 2) = "50" And Int(ret_jjos / 2) = ret_jjos / 2 Then
ret_jjos = Int(x / 10 ^ m) * 10 ^ i '//唯一此种情况舍
Else
ret_jjos = Round(x, m) * 10 ^ i '//不是那种情况执行四舍五入
End If
Else
ret_jjos = Round(x, m) * 10 ^ i ' //其它情况执行四舍五入
End If
If n > 0 Then
If Int(ret_jjos) >= 10 ^ (n - 1) Then
ret_jjos = Int(ret_jjos)
ElseIf Abs(ret_jjos) >= 1 Then
ret_jjos = Val(Left(Str(Abs(ret_jjos)), n + 1)) * j
End If
End If
jjos = ret_jjos '//返回处理结果
End Function
作者: 好学 时间: 2006-10-3 22:03
请问高手们,MD5加密是要来加密什么的?[em06]
作者: hi-wzj 时间: 2006-10-8 01:07
md5是实现的是单向加密，他人（比如系统管理人员）拿到加密后的字串是无法还原为加密前的字串的。系统验证的方式仍是通过将字串md5加密后，比较加密后的字串是否完全相同来判定。
主要适用于登陆密码的加密，最大限度的保证密码只有用户自己才能通过验证。
作者: 来点暴风雨 时间: 2006-10-12 22:26
学习了，顶上去[em01][em01]
作者: lilk 时间: 2006-10-14 23:32
真的学习
作者: eyewitnes 时间: 2006-10-15 04:10
以下是引用lanchong在2005-4-12 15:10:00的发言：
谁帮写个清除空格的函数，不管空格在字段何处，通通清除
试试函数trim 、LTRIM、RTRIM？好像就是这个功能的
作者: james_chung 时间: 2006-10-18 05:50
哈哈,学习
作者: tong2004 时间: 2006-10-22 06:31
学习！！！
作者: fan0217 时间: 2006-10-28 02:47
计算年龄
Function Age(vDate1 As Date, vdate2 As Date) As Integer
If Month(vdate2) < Month(vDate1) Or (Month(vdate2) = _
Month(Bdate) And Day(vdate2) < Day(vDate1)) Then
Age = Year(vdate2) - Year(vDate1) - 1
Else
Age = Year(vdate2) - Year(vDate1)
End If
End Function
作者: fan0217 时间: 2006-10-28 02:49
发送文本到剪贴板的函数
Function SendToScrap(strSendText As String) As Boolean
'===============================================================================
'-函数名称: SendToScrap
'-功能描述: 发送文本到剪贴板
'-输入参数说明: 必选：strSendText As String 发送的文本
'-返回参数说明: 发送成功：True 发送失败：False
'-使用语法示例: SendToScrap("你好！")
'-参考:
'-使用注意: 需要引用Microsoft Forms2.0 Object Library (%system32%\FM20.DLL)
'-兼容性:
'-作者: fan0217 fan0217@163.com
'-更新日期： 2006-02-24
'===============================================================================
On Error GoTo Err_SendToScrap
Dim tmpData As New DataObject
tmpData.SetText strSendText
tmpData.PutInClipboard
SendToScrap = True
Exit_SendToScrap:
Exit Function
Err_SendToScrap:
SendToScrap = False
MsgBox Err.Description
Resume Exit_SendToScrap
End Function
作者: ffgg333 时间: 2006-11-2 22:33
真的不错。谢谢分享。
作者: hoocg 时间: 2006-11-3 19:19
s
作者: andymark 时间: 2006-11-5 06:59
获取access程序自身名称
Function CurrentProjectName() As String
CurrentProjectName = Dir(CurrentDb.Name)
End Function
作者: van_zeng 时间: 2006-11-9 00:05
学习学习
作者: guzhonghua26 时间: 2006-11-9 00:49
dingding
作者: baije 时间: 2006-11-21 05:21
取得日期是一年中的第几周的函数
Public Function cweek(xx_date As Date)
Dim newyear As Date
newyear = Format(Year(xx_date) & "-01-01", "yyyy-mm-dd")
cweek = Int((xx_date + Weekday(newyear) - newyear - 1) / 7) + 1
End Function
作者: baije 时间: 2006-11-21 05:23
判别OFFICE版本的代码
'需引用mso.dll micrsoft office 10.0 object library
Private Sub 命令0_Click()
MsgBox "你使用的是" & CHKAccessVer & ChkLanguage & "版" & vbCrLf & "Office安装路径为" & vbCrLf & Application.SysCmd(acSysCmdAccessDir)
End Sub
Function ChkLanguage()
Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
Case 1028: lgg = "繁体"
Case 2052: lgg = "简体"
Case Else: lgg = "未知" & Application.LanguageSettings.LanguageID(msoLanguageIDUI)
End Select
ChkLanguage = lgg
End Function
Function CHKAccessVer()
Select Case Application.SysCmd(acSysCmdAccessVer)
Case 9
CHKAccessVer = "ACCESS 2000"
Case 10
CHKAccessVer = "ACCESS XP (2002)"
Case 11
CHKAccessVer = "ACCESS 2003"
Case Else
CHKAccessVer = "未知版本" & Application.SysCmd(acSysCmdAccessVer)
End Select
End Function
作者: laoyeche 时间: 2006-11-25 07:11
请教:有条件自动编码
如:42001XX0000
其中XX随年份而改变,例如2005年,XX=05;2006年XX=06
作者: 阡陌斜阳 时间: 2006-11-25 22:56
谢谢了，我正在为此犯愁呢。
作者: ycx007 时间: 2006-11-28 06:20
多多学习
作者: binuochao 时间: 2006-11-28 22:33
有个建议,如果做以MDB为数据库,MDB或MDE为前端的网络型应用,在窗体或查询中最好少用"域聚合函数",因为"域聚合函数"会要调用域中所有的数据进行,使网络流量明显增加,最好是使用单独查询来计算可大提高效率!
作者: scbzwv 时间: 2006-12-1 17:23
good!
作者: 红尘如烟 时间: 2006-12-10 05:48
在VBA中使用SQL语句，一般都是分段写的。如果语句太长，很容易出错，而VBA提供的错误提示经常让人不知所以，如果出错可以将SQL语句用MsgBox对话框显示出来，这样就会是一个连贯的语句，再根据VBA的出错提示就很容易找出错在哪里了。
作者: zyz218 时间: 2006-12-15 00:04
以下是引用baije在2006-11-20 21:21:00的发言：
取得日期是一年中的第几周的函数
Public Function cweek(xx_date As Date)
Dim newyear As Date
newyear = Format(Year(xx_date) & "-01-01", "yyyy-mm-dd")
cweek = Int((xx_date + Weekday(newyear) - newyear - 1) / 7) + 1
End Function
format(日期字段，"yyyy-ww")
结果为：2006-XX 其中XX为第多少周，不需要年的话可以这样：format(日期字段，"ww")
作者: youngmeme 时间: 2006-12-18 01:22
以下是引用yangzn在2004-11-28 18:00:00的发言：
我来支持一下，最近我写人事管理，中间要插入员工图片,acees自带的图片功能好像很弱（罗斯文里也太简单了点吧)（大家不要笑我，用了几年的Acess，这是我第一次使用图片) 这个是我花时间在网上找的如果用ole字段存取jpg图片，而且用image控件显示[attach]7874[/attach]
作者是叫 Stephen Lebans
真佩服国外的高手!!!
VB我不懂，请问这个工具怎么应用到我自己做的access数据库中？
作者: xjliyuehua 时间: 2007-1-14 22:19
以下是引用laoyeche在2006-11-24 23:11:00的发言：
请教:有条件自动编码
如:42001XX0000
其中XX随年份而改变,例如2005年,XX=05;2006年XX=06
给你一个连接：
http://www.office-cn.net/forum.php?mod=viewthread&tid=51406&replyID=&skin=1
作者: Jach 时间: 2007-1-18 23:22
好，顶一下！
作者: jiuzhensi 时间: 2007-1-23 19:37
我很想上传软件，不知从哪传，我是新手。
作者: huangqinyong 时间: 2007-2-11 23:10
产生随机号码的模块：
Private Sub Form_Open(Cancel As Integer)
Dim lonIntNum As Variant
lonIntNum = Fix(8999999999# * Rnd()) + 1000000000
Me.文本框 = lonIntNum
End Sub
作者: einstein_supeng 时间: 2007-2-16 22:24
我也来一段(不用子窗体,用LISTBOX随即查询):
PRIVATE SUB RUNSQL()
DIM SQL AS STRING
SQL=ME.TEXT0
ME.LIST1.COLUMNHEADS=TRUE
ME.LIST1.COLUMNCOUNT=255
ME.LIST1.ROWSOURCE=SQL
END SUB
见笑了
作者: plmm1999 时间: 2007-2-21 19:41
谢谢分享!这里有太多好东东,我只是初学者,希望能很快加入你们行列.
[em23][em23]
作者: GAOYUAN_1971 时间: 2007-3-2 07:08
链接有问题
作者: ferockpan 时间: 2007-3-9 07:50
支持！！！！！！！！！１
作者: 捉猫鼠 时间: 2007-4-4 06:55
顶起来再说，谢谢
作者: lqiyik 时间: 2007-4-17 03:47
see
作者: lqiyik 时间: 2007-4-17 03:48
高手多多
作者: user2007168 时间: 2007-4-29 04:56
good
作者: hoowei 时间: 2007-5-16 20:28
太好了。又学到了。
作者: shaoyong99 时间: 2007-7-24 06:22
怎么没有了
作者: BILLFEI 时间: 2007-8-27 19:36
好呀,支持,感谢大家
作者: eyre911 时间: 2007-9-20 23:10
真是高手如云啊!
作者: wangjeffson 时间: 2007-9-21 22:45
高手多多哈
作者: langfang01 时间: 2007-9-29 10:01
顶
顶
顶
顶
作者: M字头 时间: 2007-10-4 07:43
顶一下，谢谢共享
作者: zyb9335 时间: 2007-10-17 09:51
想开发适合自己需求ACCESS数据的朋友，请进
http://www.accessoft.com/cgi-bin/boke.asp?zyb9335.showtopic.117.html
作者: cadgee 时间: 2007-10-29 21:59
good good study ,up up day
| 欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/) |
Powered by Discuz! X3.3 |