控件： 常量 控件
acBoundObjectFrame 绑定对象框 acCheckBox 复选框 acComboBox 组合框
acCommandButton 命令按钮
acCustomControl ActiveX（自定义）控件 acImage 图像 acLabel 标签 acLine 线条
acListBox 列表框
acObjectFrame 未绑定对象框或图表 acOptionButton 选项按钮 acOptionGroup 选项组 acPage 页
acPageBreak 分页符 acRectangle 矩形
acSubform 子窗体/子报表 acTabCtl 选项卡 acTextBox 文本框
acToggleButton 切换按钮
在VB中对窗体控件的引用
键入包含控件的窗体或报表的标识符，后面紧接 ! 运算符和控件的名称。例如，下列标识符将引用“订单”窗体上“订单ID”控件值： Forms![订单]![订单ID]
引用子窗体或子报表上的控件，不必使用“窗体”或“报表”属性为窗体或报表指定完整的标识符。例如，可以使用下列标识符来引用“订单”子窗体上的“数量”控件： Forms![订单]![订单子窗体]![数量]
判断窗体或报表中控件的数目，然后将该数目赋给一个变量。 Dim intFormControls As Integer Dim intReportControls As Integer
intFormControls = Forms!Employees.Count
intReportControls = Reports!FreightCharges.Count 设置控件可见性
Dim i, ii As Integer For ii = 3 To 10
Me.Controls.Item(ii).Visible = True Next
For i = 11 To 22
Me.Controls.Item(i).Visible = False Next
按特殊名在VBA中设置控件的可见性： For i = 27 To 47
If Me.Controls.Item(i).Name Like \"A*\" Then Me.Controls.Item(i).Visible = False End If Next
指定一个控件能否接受焦点 Enabled属性：
me.控件.Enabled = true'能 =false'不能
指定一个控件能否被编辑： locked 如：
me.控件.Locked = true me.控件.Locked = false 设置控件标题显示的文字
Me.控件.Caption = \"显示窗体\"
设置标签颜色： Me.LabelColor =200
获得焦点及失去焦点时字段变更颜色。
如果你的控件是文本框，名称为“txt字段”，写如下代码：
Private Sub txt字段_GotFocus() Me.txt字段.BackColor = 12632256 End Sub
当中“”是灰色，你可以自己选择希望的颜色，如果想在失去焦点时改为原来的颜色，写如下代码：
Private Sub txt字段_LostFocus() Me.txt字段.BackColor = 16777215 End Sub
使标签闪烁以引人注意
设置窗体的TimerInterval 值为1000 (1秒).
forms OnTimer 加入代码:
Sub Form_Timer()
YourTextLabel.Visible = Not YourTextLabel.Visible End_Sub
设置标签字体颜色： Me.Label1.ForeColor = 设置文本框颜色： Me.TextColor = 300 设置文本框字体颜色： Me.TextFontColor = 500 标签等左边距离：
Me.Label2.Left = 2200
定位控件
Me.控件.Top = 8290 Me. 控件.Left = 100 设置控件宽度/高度
Me.考生答案.Width = 10000 Me.考生答案.Height = 1000 标签等字体粗细：
Me.Label2.FontWeight = 20000
控件边框颜色：
Me.Label2.BorderColor = 0 控件边框线条
BorderStyle 属性使用以下设置：
透明 0 （仅对于标签、图表和子报表而言是默认值）透明的 实线 1 （默认值）实线 虚线 2 虚线 短虚线 3 短虚线 点线 4 点线
稀疏点线 5 点距较宽的点线
点划线 6 虚线与点线组合的点划线
点点划线 7 虚线-点线-点线组合的点点划线 双实线 8 双实线 指定控件的边框宽度
使用 BorderWidth 属性可以指定控件的边框宽度 取值：0或1－6 指定控件是否透明
使BackStyle 属性可以指定控件是否透明。 True 、False 解除子窗体锁定
Me.进_子窗体.Locked = False '解除子窗体锁定 将窗体上所有控件的输入法关掉! 来源:不祥
Private Sub Form_Open(Cancel As Integer) Dim ctl As Access.Control For Each ctl In Me.Controls
Debug.Print ctl.Name & ctl.ControlType If ctl.ControlType = acTextBox Then ctl.IMEMode = 2 End If Next End Sub
上述代码控制文本框，你还可以控制其他的，只要copy进窗体就可以了 列表框的值的引用
如果是单选的列表框，用 me.[列表框名] 来引用；如果要引用不是结合型列的值，可以用 me.[列表框名].column(n) （第一列n=0，第二列n=1…）
引用多列组合框或列表框中特定的列或列与行的组合
用 0 引用第一列，用 1 引用第二列，依此类推。用 0 引用第一行，用 1 引用第二行，依此类推。例如在含有一列客户 ID 和一列客户名称的列表框中，可以使用如下方式引用第二列、第五行的客户名称： Forms!Contacts!Customers.Column(1, 4)
可以使用 Column 属性将组合框或列表框的内容指定给另一控件，如文本框。例如，若要将文本框的 ControlSource 属性设为列表框第二列中的值，可以使用以下表达式： =Forms!Customers!CompanyName.Column(1)
如果引用了组合框或列表框中的列，但用户未做选择，则 Column 属性设置将为 Null。可以使用 IsNull 函数来确定是否进行了选择，示例如下： If IsNull(Forms!Customers!Country) Then MsgBox \"No selection.\" End If
显示获得焦点的控件的 Name： ctl As Control
Set ctl = Screen.ActiveControl
MsgBox ctl.Name
窗体：
如何让窗体的标题条闪烁以引起用户注意？
在窗体中放一个Timer控件Timer1,设置其Inteval=200 *API函数声明
Private Declare Function FlashWindow Lib \"user32\" (ByVal hwnd As Long, ByVal bInvert As Long) As Long
注释：在窗体中写下如下代码: Private Sub Timer1_Timer() FlashWindow Me.hwnd, True End Sub
窗体上如何使用windows的媒体播放器 插入Microsoft Media Player控件
插入控件后，在控件中属性中的几个主要选项： :要播放的文件名，包括路径 AutoStrat:是否自动播放
AutoRevind:播放完后是否自动回到起点
指定当窗体上的命令按钮保持按下状态时，是否重复执行事件过程或宏
使用 AutoRepeat 属性可以指定当窗体上的命令按钮保持按下状态时，是否重复执行事件过程或宏 True 、False
以隐藏方式打开一个窗体 me.visible=false '允许添加
me.AllowAdditions= True '记录不锁定
me.RecordLocks = 1 是否自动居中
AutoCenter= True,False 是否自动调整
AutoResize = True,False
窗体边框样式
me.BorderStyle=1 中译:无 其它
1 无 2 细边框 3 可调边框 4 对话框边框
设置窗体、页眉、页脚颜色： Me.Section(0).BackColor = 200 Me.Section(1).BackColor = 200 Me.Section(2).BackColor = 200
窗体标题
me.Caption=\"中国ACCESS软件网\" 中译:窗体标题为\"中国ACCESS软件网\"(不含引号) 关闭按钮
me.CloseButton =True 中译 允许关闭按钮
其它:true:允许 False:不允许
控制框
me.ControlBox =True 允许 其它:true:允许 False:不允许
默认视图
me.DefaultView =0 为单一窗口
其它:0:单一窗口1:连续窗体2:数据表
vba如何獲取/設置在數據表方式下個列的寬度 一、Me.RowHeight = 800
二、Me.子窗体名.Form.Controls(\"列名\").ColumnWidth = 400 允许分隔线
me.DividingLines =True 中译 允许分隔线 其它:true:允许 False:不允许 允许打印版式
英文:me.LayoutForPrint =True 中译 允许打印版式 其它:true:允许 False:不允许 无最大最小化按钮
英文:me.MinMaxButtons =0 中译 无最大最小化按钮 其它:0:无 1:最大化 2:最小化 3:两者都有 允许浏览按钮
英文:me.NavigationButtons =True 中译 允许浏览按钮 其它:true:允许 False:不允许
滚动条
me.ScrollBars =0二者均无
其它:0:二者均无 1:只垂直 2:只水平3:二者都有
允许/不允许添加
me.AllowAdditions=True/False 允许/不允许删除
me.AllowDeletions=True/False 允许/不允许编辑
me.AllowEdits=True/False
指定是否允许打开绑定窗体进行数据输入
使用 DataEntry 属性可以指定是否允许打开绑定窗体进行数据输入。DataEntry 属性不决定是否可以添加记录，只决定是否显示已有的记录。Boolean 型，可读/写。 True 、False
允许/不允许筛选
me.AllowFilters=True/False Filter=\"筛选内容\"筛选 应用与/否筛选
FilterOn=True/False
将 MyForm 窗体的 BackColor 属性，改成 ColorCode 参数指定的色彩。 使用 QBColor 函数将 MyForm 窗体的 BackColor 属性，改成 ColorCode 参数指定的色彩。QBColor 可接受 0 到 15 的整型值。
Sub ChangeBackColor (ColorCode As Integer, MyForm As Form) MyForm.BackColor = QBColor(ColorCode) End Sub
窗体真正居中显示
如下代码可以做到真正居中显示
Private Sub Form_Load() DoCmd.Echo False Dim x, y As Integer DoCmd.Maximize x = Me.WindowWidth y = Me.WindowHeight DoCmd.Restore DoCmd.Echo True
Move (x - Me.WindowWidth) / 2, (y - Me.WindowHeight) / 2 End Sub
隐藏窗体[学生名册]数据表视图中的性别字段 Table!学生名册!性别.ColumnHidden = -1
显示获得焦点窗体的 Name 属性设置：
使用 ActiveForm 属性（和 Screen 对象一起）可以标识或引用获得焦点的窗体。 Dim dqhdct As Form
Set dqhdct = Screen.ActiveForm MsgBox dqhdct.Name
判断窗体是否打开的方法
Function IsLoaded(strName As String, Optional intObjectType As Integer = acForm)
IsLoaded = (SysCmd(acSysCmdGetObjectState, intObjectType, strName) <> 0) End Function
使用 IsLoaded 属性可以确定当前是否加载了 AccessObject。Boolean 型，只读。 以下是一个示例：
If CurrentProject.AllForms(\"frmMain\").IsLoaded = True Then Forms!frmMain.Form.Visible = False End If
窗体中组合框不在列表中示例 不在列表中事件代码：
Private Sub 名称_NotInList(NewData As String, Response As Integer) Response = acDataErrContinue
If MsgBox(\"您输入的名称不在列表中，在列表中添加新记录吗？\银河酒业\") = 6 Then
Me![名称] = Null
DoCmd.GoToControl \"单价\"
DoCmd.OpenForm \"酒名列表\ Else
Me![名称] = Null Me![名称].Dropdown End If End Sub
获得焦点事件代码：
Private Sub 名称_GotFocus() Me![名称].Requery End Sub
如何让窗体总在最前面？ *API函数声明
Declare Function SetWindowPos Lib \"user32\" ( ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long 注释：常量声明
Private Const SWP_NOSIZE = &H1 Private Const SWP_NOMOVE = &H2 Private Const HWND_TOPMOST = -1 Private Const HWND_NOTOPMOST = -2 注释： 在某个form里写：
SetWindowPos me.hWnd,WND_TOPMOST,0,0,0,0, SWP_NOMOVE 注释：或下面 SetWindowPos me.hWnd,WND_TOPMOST,0,0,0,0, SWP_NOSIZE 用代码选择图表样式 \"柱形图\"
Me.graphnow.Object.ChartType = xlColumnClustered \"折线图\"
Me.graphnow.Object.ChartType = xlLineMarkers \"饼形图\"
Me.graphnow.Object.ChartType = xl3DPie \"条形图\"
Me.graphnow.Object.ChartType = xlBarClustered
柱形图 簇状柱形图 xlColumnClustered 三维簇状柱形图 xl3DColumnClustered 堆积柱形图 xlColumnStacked
三维堆积柱形图 xl3DColumnStacked 百分比堆积柱形图 xlColumnStacked100
三维百分比堆积柱形图 xl3DColumnStacked100 三维柱形图 xl3DColumn
条形图 簇状条形图 xlBarClustered 三维簇状条形图 xl3DBarClustered 堆积条形图 xlBarStacked
三维堆积条形图 xl3DBarStacked 百分比堆积条形图 xlBarStacked100
三维百分比堆积条形图 xl3DBarStacked100 折线图 折线图 xlLine
数据点折线图 xlLineMarkers 堆积折线图 xlLineStacked
堆积数据点折线图 xlLineMarkersStacked 堆积百分比折线图 xlLineStacked100
百分比堆积数据点折线图 xlLIneMarkersStacked100 三维折线图 xl3DLine 饼图 饼图 xlPie
分离型饼图 xlPieExploded 三维饼图 xl3Dpie
三维分离型饼图 xl3DPieExploded 复合饼图 xlPieOfPie 复合柱饼图 xlBarOfPie
XY (散点图) 散点图 xlXYScatter 平滑线散点图 xlXYScatterSmooth
无数据点平滑线散点图 xlXYScatterSmoothNoMarkers 折线散点图 xlXYScatterLines
无数据点折线散点图 xlXYScatterLinesNoMarkers
气泡图 气泡图 xlBubble
三维气泡图 xlBubble3DEffect 面积图 面积图 xlArea 三维面积图 xl3DArea
堆积面积图 xlAreaStacked
三维堆积面积图 xl3DAreaStacked 百分比堆积面积图 xlAreaStacked100
三维百分比堆积面积图 xl3DAreaStacked100 圆环图 圆环图 xlDoughnut
分离型圆环图 xlDoughnutExploded 雷达图 雷达图 xlRadar
数据点雷达图 xlRadarMarkers 填充雷达图 xlRadarFilled 曲面图 三维曲面图 xlSurface
曲面图（俯视图） xlSurfaceTopView
三维曲面图（框架图） xlSurfaceWireframe
曲面图（俯视框架图） xlSurfaceTopViewWireframe 股价图 盘高-盘低-收盘图 xlStockHLC 成交量-盘高-盘低-收盘图 xlStockVHLC 开盘-盘高-盘低-收盘图 xlStockOHLC
成交量-开盘-盘高-盘低-收盘图 xlStockVOHLC 圆柱图 簇状柱形圆柱图 xlCylinderColClustered 簇状条形圆柱图 xlCylinderBarClustered 堆积柱形圆柱图 xlCylinderColStacked 堆积条形圆柱图 xlCylinderBarStacked
百分比堆积柱形圆柱图 xlCylinderColStacked100 百分比堆积条形圆柱图 xlCylinderBarStacked100 三维柱形圆柱图 xlCylinderCol
圆锥图 簇状柱形圆锥图 xlConeColClustered 簇状条形圆锥图 xlConeBarClustered 堆积柱形圆锥图 xlConeColStacked 堆积条形圆锥图 xlConeBarStacked
百分比堆积柱形圆锥图 xlConeColStacked100 百分比堆积条形圆锥图 xlConeBarStacked100 三维柱形圆锥图 xlConeCol
棱锥图 簇状柱形棱锥图 xlPyramidColClustered 簇状条形棱锥图 xlPyramidBarClustered 堆积柱形棱锥图 xlPyramidColStacked 堆积条形棱锥图 xlPyramidBarStacked
百分比堆积柱形棱锥图 xlPyramidColStacked100 百分比堆积条形棱锥图 xlPyramidBarStacked100 三维堆积柱形棱锥图 Color 属性 移动无边框窗体例子 模块：
Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function ReleaseCapture Lib \"user32\" () As Long Public Const WM_NCLBUTTONDOWN = &HA1 Public Const HTCAPTION = 2
应用：
Private Sub Form_Close()
DoCmd.RunCommand acCmdAppMaximize End Sub
Private Sub Form_Load()
DoCmd.RunCommand acCmdAppMinimize End Sub
Private Sub XPForm_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = 1 Then ReleaseCapture
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& End If End Sub
Private Sub 命令20_Click() DoCmd.Close End Sub
如何移动没有标题栏的窗口？
我们一般是用鼠标按住窗口的标题栏，然后移动窗口，当窗口没有标题栏时，我们可以用下面的方法来移动窗口：
*API函数声明：
Declare Function ReleaseCapture Lib \"user32\" () 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 Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1 在 Form_MouseDown 事件中：
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION,0& End Sub
日期、时间函数
如何将文本型：2003.08.04 转换为日期型：2003-08-04 cdate(replace(\"2003.08.04\显示当前日期在该年中所处的星期号 =Format(Now(), \"ww\") ww 为 1 到 53。
显示日期字段值的四位年份值。 =DatePart（\"yyyy\订购日期]）
显示日期字段值前 10 天的日期值。 =DateAdd（\"y\应付日期]） 显示日期字段值前一个月的日期值。 =DateAdd(\"m\
显示日期1和日期2之间相差的天数。
=DateDiff（\"d\订购日期], [发货日期]）
从今天算起到三个月后的日期之间的记录。 Betweeb date() and adddate(3,date()) 根据出生日期计算年龄（周岁）
=IIf(Month(Date())-Month([出生年月日])>-1,Year(Date())-Year([出生年月日]),Year(Date())-Year([出生年月日])-1)
自定义日期/时间格式 (Format 函数)
(:) 时间分隔符。在一些区域，可能用其他符号来当时间分隔符。格式化时间值时，时间分隔符可以分隔时、分、秒。时间分隔符的真正字符在格式输出时取决于系统的设置。
(/) 日期分隔符。在一些区域，可能用其他符号来当日期分隔符。格式化日期数值时，日期分隔符可以分隔年、月、日。日期分隔符的真正字符在格式输出时取决于系统设置。
C 以 ddddd 来显示日期并且以 ttttt 来显示时间。如果想显示的数值无小数部分，则只显示日期部分，如果想显示的数值无整数部分，则只显示时间部分。 D
以没有前导零的数字来显示日 (1 – 31)。 Dd
以有前导零的数字来显示日 (01 – 31)。 ddd
以简写来表示日 (Sun –Sat)。 dddd
以全称来表示日 (Sunday –Saturday)。 ddddd
以完整日期表示法显示（包括年、月、日），日期的显示要依系统的短日期格式设置而定。缺省的短日期格式为 m/d/yy。 dddddd
以完整日期表示法显示日期系列数（包括年、月、日），日期的显示要依系统识别的长日期格式而定。缺省的长日期格式为 mmmm dd, yyyy。 aaaa
与dddd 一样，它只是该字符串的本地化版本。 W
将一周中的日期以数值表示（1 表星期日~ 7表星期六）。 ww
将一年中的星期以数值表示 (1 – 54)。 M
以没有前导零的数字来显示月 (1 – 12)。如果 m 是直接跟在 h 或 hh 之后，那么显示的将是分而不是月。 mm
以有前导零的数字来显示月 (01 – 12)。如果m是直接跟在h或hh之后，那么显示的将是分而不是月。 mmm
以简写来表示月 (Jan –Dec)。 mmmm
以全称来表示月 (January –December)。 oooo
与mmmm一样，它只是该字符串的本地化版本。 Q
将一年中的季以数值表示 (1 – 4)。 Y
将一年中的日以数值表示 (1 – 366)。 Yy
以两位数来表示年 (00 – 99)。 yyyy
以四位数来表示年 (00 – 99)。 H
以没有前导零的数字来显示小时 (0 – 23)。 Hh
以有前导零的数字来显示小时 (00– 23)。 N
以没有前导零的数字来显示分 (0 – 59)。 Nn
以有前导零的数字来显示分 (00 – 59)。 S
以没有前导零的数字来显示秒 (0 – 59)。 Ss
以有前导零的数字来显示秒 (00 – 59)。
t t t t t
以完整时间表示法显示（包括时、分、秒），用系统识别的时间格式定义的时间分隔符进行格式化。如果选择有前导零并且时间是在 10:00 A.M. 或 P.M.之前，那么将显示有前导零的时间。缺省的时间格式为 h:mm:ss。 AM/PM
在中午前以 12 小时配合大写 AM 符号来使用；在中午和 11:59 P.M.间以 12 小时配合大写 PM 来使用。 Am/pm
在中午前以 12 小时配合小写 am 符号来使用；在中午和 11:59 P.M.间以 12 小时配合小写 pm 来使用。 A/P
在中午前以 12 小时配合大写A符号来使用；在中午和 11:59 P.M.间以12 小时配合大写P来使用。 a/p
在中午前以 12 小时配合小写a符号来使用；在中午和 11:59 P.M.间以 12 小时配合小写p来使用。 AMPM
在中午前以 12 小时配合系统设置的 AM字符串文字来使用；在中午和 11:59 P.M. 间以 12 小时配合系统设置的 PM 字符串文字来使用。AMPM 可以是大写或小写，但必须和您的系统设置相配。其缺省格式为 AM/PM。 日期函数示例
当天日期：=Date() 当日：=Day(date) 当月：=Month(date()) 当年：=Year(date())
当季：=DatePart(\"q\把日期大写
Function Date2Chinese(iDate) Dim num(10) Dim iYear Dim iMonth Dim iDay
num(0) = \"〇\" num(1) = \"一\" num(2) = \"二\" num(3) = \"三\" num(4) = \"四\" num(5) = \"五\" num(6) = \"六\" num(7) = \"七\" num(8) = \"八\" num(9) = \"九\"
iYear = Year(iDate) iMonth = Month(iDate) iDay = Day(iDate)
Date2Chinese = num(iYear \\ 1000) + _
num((iYear \\ 100) Mod 10) + num((iYear _ \\ 10) Mod 10) + num(iYear Mod _ 10) + \"年\" If iMonth >= 10 Then
If iMonth = 10 Then
Date2Chinese = Date2Chinese + _ \"十\" + \"月\" Else
Date2Chinese = Date2Chinese + _ \"十\" + num(iMonth Mod 10) + \"月\" End If Else
Date2Chinese = Date2Chinese + _ num(iMonth Mod 10) + \"月\" End If
If iDay >= 10 Then
If iDay = 10 Then
Date2Chinese = Date2Chinese + _ \"十\" + \"日\"
ElseIf iDay = 20 Or iDay = 30 Then Date2Chinese = Date2Chinese + _ num(iDay \\ 10) + \"十\" + \"日\" ElseIf iDay > 20 Then
Date2Chinese = Date2Chinese + _ num(iDay \\ 10) + \"十\" + _ num(iDay Mod 10) + \"日\" Else
Date2Chinese = Date2Chinese + _ \"十\" + num(iDay Mod 10) + \"日\" End If Else
Date2Chinese = Date2Chinese + _ num(iDay Mod 10) + \"日\" End If End Function
算出每个月的天数 一法：
Dim a, b, c a = Year(Now()) b = Month(Now())
c = Format((a & \"/\" & b + 1 & \"/1\"), \"######\") - Format((a & \"/\" & b & \"/1\"), \"######\") 二法：
DateDiff(\"d\DateDiff可以算出两个日期之间相差几天！ 三法：
Day(DateAdd(\"d\
day函数可以知道某个日期是这个月的第几天，我们把这个月的最后一天拿出来DAY一下！ 应该还有更好的方法！
比如说可以定义一个数组，把每个月的日子放进去，或者说写一个函数算每一个月的天数 只要考虑一下闺年的问题就可以了！
如何得到某年每个月的第一天是星期几 Private Sub Command1_Click()
Dim i As Integer, A As Integer, B As Integer, C As String A = InputBox(\"请输入年份\某年每个月的第一天是星期几\") Form1.Cls
For i = 1 To 12
C = A & \"-\" & i & \"-1\" B = Weekday(C) Select Case B Case vbSunday
Print A & \"年\" & i & \"月1日是 星期日\" Case vbMonday
Print A & \"年\" & i & \"月1日是 星期一\" Case vbTuesday
Print A & \"年\" & i & \"月1日是 星期二\" Case vbWednesday
Print A & \"年\" & i & \"月1日是 星期三\" Case vbThursday
Print A & \"年\" & i & \"月1日是 星期四\" Case vbFriday
Print A & \"年\" & i & \"月1日是 星期五\" Case vbSaturday
Print A & \"年\" & i & \"月1日是 星期六\" End Select Next i End Sub
计算天数及月初月末日期
Function 本月天数(日期 As Date) As Byte
本月天数 = DateSerial(Year(日期), Month(日期) + 1, Day(日期)) - 日期 End Function
Function 月末(日期 As Date) As Date
月末 = DateSerial(Year(日期), Month(日期) + 1, 1) - 1 End Function
Function 月初(日期 As Date) As Date 月初 = 日期 - Day(日期) + 1 End Function
本月最后一日是周几 SELECT
Weekday(DateAdd(\"m\本月最后一日是周几, 下月最后一日是周几 SELECT
Weekday(DateAdd(\"m\下月最后一日是周几, 本月最后一个周5到月底的天数 SELECT
(Weekday(DateAdd(\"m\本月最后一个周5到月底的天数;
下月最后一个周5到月底的天数 SELECT
(Weekday(DateAdd(\"m\下月最后一个周5到月底的天数;
本月最后一个周5的日期 SELECT
DateAdd(\"m\(Date()),Month(Date()),1)-1))+1) Mod 7 AS 本月最后一个周5的日期; 下月最后一个周5的日期 SELECT
DateAdd(\"m\(Date()),Month(Date()),1)-1))+1) Mod 7 AS 下月最后一个周5的日期;
数据输入、查询、计算、连接： 通过英特网的ACCESS联接 在ACCESS中使用ADO：
Private Sub ABC_Click()
Dim cn As New ADODB.Connection Dim rs As New ADODB.Recordset cn.OPEN \"DSN=alwin;UID=;PWD=;\"
rs.OPEN \"Select * from tbTABLE\’ rs.ABC App.Path & \"\estdata.dat\rs.Close cn.Close
MsgBox (\"OPERATION OK\") End Sub
Private Sub OPEN_Click() Dim strConnect As String
strConnect = \"Provider=MSPersist\" Dim rs As New ADODB.Recordset
rs.OPEN \"http://远程服务器的IP/test/testdata.dat\Do While Not rs.EOF
Debug.Print rs(\"USERID\").value rs.MoveNext Loop End Sub
数据库网络使用时,速度很慢!
即使采取始终隐藏运行一个联接后端表的窗体的办法!也必须运行一次一个无条件的查询(窗体状态)后,速度才比较令人满意!!有没有更好的办法!! 在ADSL连接的互连网,而不是局域网!
一,建立一个隐藏运行的连接后端的窗体.
二,在打开启动窗体时自动运行一个用窗体显示的查询,注意,要显示到最后一条记录,不然,速度只能提高一部分,然后自动关闭该窗体(以上过程都要隐藏,所以实际上看不见,另因为要运行一定的时间,最好设置一个正在连接和连接完毕的的提示框),这样一来,读取速度几乎跟在单机上使用没有区别! 将用户输入的身份证号15位数据转化为18位。
Function IDCode15to18(sCode15 As String) As String
'* 功能:将15的身份证号升为18位(根据GB 113-1999) '* 参数:原来的号码
'* 返回:升位后的18位号码 Dim i As Integer Dim num As Integer Dim code As String num = 0
IDCode15to18 = Left(sCode15, 6) + \"19\" + Right(sCode15, 9) ' 计算校验位
For i = 18 To 2 Step -1
num = num + (2 ^ (i - 1) Mod 11) * (Mid(IDCode15to18, 19 - i, 1)) Next i
num = num Mod 11 Select Case num Case 0
code = \"1\" Case 1
code = \"0\" Case 2
code = \"X\" Case Else
code = Trim(Str(12 - num))
End Select
IDCode15to18 = IDCode15to18 + code End Function
据身份证号自动输入出生日期 Dim Length As Integer
Length = Len(Me.[身份证号])
If Not IsNull(Length) Then
If Length = 15 Then
Me.[性别] = IIf(Val(Mid(Me.身份证号, 15, 1)) / 2 = Int(Val(Mid(Me.身份证号, 15, 1)) / 2), \"女\男\")
Me.[出生日期] = \"19\" & Mid([身份证号], 7, 2) & \"-\" & Mid([身份证号], 9, 2) & \"-\" & Mid([身份证号], 11, 2)
ElseIf Length = 18 Then
Me.[性别] = IIf(Val(Mid(Me.身份证号, 17, 1)) / 2 = Int(Val(Mid(Me.身份证号, 17, 1)) / 2), \"女\男\")
Me.[出生日期] = Mid([身份证号], 7, 4) & \"-\" & Mid([身份证号], 11, 2) & \"-\" & Mid([身份证号], 13, 2) Else
MsgBox \"身份证号错误！\"
End If
End If
两行代码打开另一数据库
Private Sub 命令4_Click()
On Error GoTo Err_命令4_Click Dim strDb As String strDb = \"C:\\db1.mdb\"
SendKeys \"{F11}%FO\" & strDb & \"{enter}\" Exit_命令4_Click: Exit Sub Err_命令4_Click:
MsgBox Err.Description Resume Exit_命令4_Click End Sub
实现打开外部数据库中的报表。
Private Declare Function apiSetForegroundWindow Lib \"user32\" _ Alias \"SetForegroundWindow\" _ (ByVal hwnd As Long) _ As Long
Private Declare Function apiShowWindow Lib \"user32\" _ Alias \"ShowWindow\" _ (ByVal hwnd As Long, _ ByVal nCmdShow As Long) _ As Long
Private Const SW_MAXIMIZE = 3
Private Const SW_NORMAL = 1
Function fOpenRemoteReport(strMDB As String, strReport As String, _ Optional intView As Variant) _ As Boolean
' strMDB: 外部数据库名称(含路径) ' strReport: 报表名称 ' intView: 报表的打开方式
Dim objAccess As Access.Application Dim lngRet As Long
On Error GoTo fOpenRemoteReport_Err
If IsMissing(intView) Then intView = acViewPreview
If Len(Dir(strMDB)) > 0 Then
Set objAccess = New Access.Application With objAccess
lngRet = apiSetForegroundWindow(.hWndAccessApp) lngRet = apiShowWindow(.hWndAccessApp, SW_NORMAL) ' 第一次调用ShowWindow似乎不做任何事情
lngRet = apiShowWindow(.hWndAccessApp, SW_NORMAL) .OpenCurrentDatabase strMDB
.DoCmd.OpenReport strReport, intView Do While Len(.CurrentDb.Name) > 0 DoEvents Loop End With End If
fOpenRemoteReport_Exit: On Error Resume Next objAccess.Quit
Set objAccess = Nothing Exit Function
fOpenRemoteReport_Err:
fOpenRemoteReport = False Select Case Err.Number Case 7866:
' mdb 已经被用独占方式打开
MsgBox \"该数据库：\" & strMDB & _
vbCrLf & \"已经被用独占方式打开！\" & vbCrLf _ & vbCrLf & \"请重新用共享方式打开，再试一次！\ vbExclamation + vbOKOnly, \"不能打开数据库\" Case 2103:
' 报表不存在
MsgBox \"在这个\" & strMDB & \"数据库中不存在该报表：\" & strReport & _ vbCrLf & vbCrLf , _
vbExclamation + vbOKOnly, \"报表不存在\" Case 7952:
' 用户关闭了这个 mdb fOpenRemoteReport = True
Case Else:
MsgBox \"错误#: \" & Err.Number & vbCrLf & Err.Description, _ vbCritical + vbOKOnly, \"运行时错误\" End Select
Resume fOpenRemoteReport_Exit End Function
为列表框定数据源 Dim str3 As String
str3 = \"SELECT jhd_mx_jiage.wp_leibie AS 类别, jhd_mx_jiage.wp_migceg AS 名称, jhd_mx_jiage.wp_xighao AS 型号, jhd_mx_jiage.jhmx_danwei AS 单位, jhd_mx_jiage.jhmx_danjia AS 单价 FROM jhd_mx_jiage \" & \" where jhd_mx_jiage.wp_leibie='\" & Listjhlb & \"'\" Me.Listjhwp.RowSource = str3 Me.Listjhwp.Requery
为组合框、子窗体设置数据源
下面的示例将组合框的 RowSourceType 属性设为“Table/Query”，然后将 RowSource 属性设为“雇员列表”查询。
Forms!Employees!cmboNames.RowSourceType = \"Table/Query\" Forms!Employees!cmboNames.RowSource = \"EmployeeList\" 一：
Dim str1 As String
str1 = \"SELECT ziyuag.zy_daihao, ziyuag.zy_mima,ziyuag.zy_ziwu,ziyuag.zy_xigmig FROM ziyuag \" & \" where zy_daihao='\" & Text8dldh & \"'and zy_mima='\" & Text10dlmm & \"'\" Me.Child6zy.Form.RecordSource = str1 Me.Child6zy.Requery 二：
子窗体.FORM.recordsourse=\"SELECT ziyuag.zy_daihao, ziyuag.zy_mima,ziyuag.zy_ziwu,ziyuag.zy_xigmig FROM ziyuag \" & \" where zy_daihao='\" & Text8dldh & \"'and zy_mima='\" & Text10dlmm & \"'\" 三：
Private Sub Command38_Click() Dim sjy As String Dim pd As Integer pd = True
sjy = \"SELECT 病历明细表.* FROM 病历明细表\" If Not IsNull(Text0) Then If pd Then
sjy = sjy & \" where 姓名 like '\" & Text0 & \"'\" pd = False Else
sjy = sjy & \" and 姓名 like '\" & Text0 & \"'\" End If End If
If Not IsNull(Text1) And Not IsNull(Text2) Then
sjy = sjy & \" where 时间 between #\" & Text1 & \"# and #\" & Text2 & \"#\" pd = False Else
str2 = str2 & \" and 时间 between #\" & Text1 & \"# and #\" & Text2 & \"#\" End If
If Not IsNull(Text3) Then If pd Then
sjy = sjy & \" where 姓名 like '\" & Text3 & \"'\" pd = False
Else
sjy = sjy & \" and 姓名 like '\" & Text3 & \"'\" End If End If
Me.子窗体.RowSource = sjy Me.Requery End Sub
为主窗体、报表设数据源
使用 RecordSource 属性可以指定窗体或报表的数据源。String 型，可读写。 一：
Dim sjy As String
sjy = \"SELECT 名单.* FROM 名单\" & \" where 姓名 like '*\" & List101 & \"*'\" Me.RecordSource = sjy Requery 二：
me.RecordSource = \"名单\"
用其他ACCESS的表作为本ACCESS 窗体的数据源 来源：ACCESS中国 Trynew
在Sql语句中的表名前加上数据库名就行了，下面语句动态引用当前目录的另一MDB文件的表做数据源： Private Sub Form_Load()
Me.RecordSource = \"SELECT 表
1.* FROM [\" & CurrentProject.Path & \"\\db1.mdb\" & \"].表1;\" End Sub
插入／删除一条记录
新建：DoCmd.RunCommand acCmdRecordsGoToNew
删除：DoCmd.RunCommand acCmdDeleteRecord
用代码实现对数据修改或增加的取消
在窗体中修改数据时，关闭窗体，数据已经修改，这样很容易产生错误数据. 可采用如下方法解决: 在窗体更新前判断:
Private Sub FORM_BeforeUpdate(Cancel As Integer)
If MsgBox(\"保存吗?\vbYesNo, Me.Caption) <> vbYes Then Cancel = True End If End Sub
' 去除系统的报错信息:
Private Sub FORM_Error(DataErr As Integer, Response As Integer) Response = acDataErrContinue End Sub
检查数据是否被修改，无则退出，有则询问是否保存
'在窗体的字段的“属性”“事件”“更新后”的右边输入“=NoAllowSave()”， '在窗体的“打开”事件中代码“allowSave = False” '定义模块
Option Compare Database Option Explicit
Public allowSave As Boolean Public Function NoAllowSave()
allowSave = True End Function
“退出”按钮的单击事件代码 If allowSave = True Then
If MsgBox(\"当前数据已经被修改，是否保存？\vbYesNo + vbQuestion, \"请选择...\") = vbYes Then Else
Me.Undo End If End If DoCmd.Close 定义记录集
Dim rst As New ADODB.Recordset 打开记录集
rst.Open \"SELECT 语句, 关键字 FROM 结果语句表\adLockOptimistic
两子窗体之间字段赋值：
Forms!aaa!bbb.Form!bb = Forms!aaa!ccc.Form!cc
确定所显示的当前记录的记录编号。
下面的示例显示如何使用 Currentrecord 属性来确定所显示的当前记录的记录编号。在通用过程 Currentformrecord 中将当前记录的编号值赋给变量 Lngrecordnum。
Sub CurrentFormRecord(frm As Form) Dim lngrecordnum As Long
lngrecordnum = frm.CurrentRecord 'CurrentRecord是当前记录号 End Sub
读取最后一条记录
dlast(\"字段名\表名\")
在字段默认值中用此函数能使该字段的新纪录显示上一条记录该字段的值 怎样使窗体一打开就定位到指定记录上
定义了一个变量lngbh，要窗体打开时显示ID=Lngbh的这条记录。
DoCmd.OpenForm \"formname\使用API函数sendmessage，获得光标所在行和列。
Sub getcaretpos(byval TextHwnd&,LineNo&,ColNo&)
注释：TextHwnd为TextBox的hWnd属性值， LineNo为所在行数，ColNo为列数 dim I&,j&,k& 注释：获取起始位置到光标所在位置字节数 I=SendMessage(TextHwnd,&HB0&,0,0) j=I/2^16 注释：确定所在行 LineNo=SendMessage(TextHwnd,&HC9&,j,0)+1 注释：确定所在列
k=SendMessage(TextHwnd,&HBB&,-1,0) ColNo=j-k+1 End sub
如何在打开窗体时自动到相应记录
用法:DoCmd.RunCommand acCmdRecordsGoToNew acCmdRecordsGoToFirst 移到第一条记录 acCmdRecordsGoToLast 移到最后一条记录 acCmdRecordsGoToNew 新增一条记录 acCmdRecordsGoToNext 移到下一条记录
acCmdRecordsGoToPrevious 移到上一条记录 判断记录的位置
来自：ACCESS中国 ysf
me.Recordset.AbsolutePosition = 0 '第一条记录
me.Recordset.AbsolutePosition = me.Recordset.RecordCount -1 '最后一条记录 me.Recordset.AbsolutePosition=-1 '第一条记录前 me.Recordset.bof=true me.Recordset.AbsolutePosition=me.Recordset.RecordCount '最后一条记录后 me.Recordset.eof=true
me.Recordset.AbsolutePosition=n '第n+1条记录 判断为是否新增记录 me.newrecord=true me.newrecord=false
自动编号 一：
=IIf(Left(Nz(DMax(\"[jhd_id]\m\") & \"001\& Format(Val(Right(Nz(DMax(\"[jhd_id]\二：
=nz(DLookUp(\"编号\登记表\登记表')\"))+1 自动编号
方法一按时间自动编号： dim a,b
a=dmax(\"[自动编号]\编号表\")+1 b=format(date(),\"yyyymm\") & 00 if a>b then me.自动编号=a else:
me.自动编号=b+1 end if
方法二，按时间自动编号： Dim a As String
a = Nz(DMax(\"销售单号\销售帐单\If Left(a, 6) <> Format(Date, \"yyyymm\") Then 销售单号 = Format(Date, \"yyyymm\") & \"01\" Else
销售单号 = Format(Date, \"yyyymm\") & Format(Val(Right(a, 2)) + 1, \"00\") End If
方法三，按月分类自动编号： Dim id, date2 As String
date2 = \"GF\" & [部门代码] & Format([入库日期], \"YYYYMM\")
id = DMax(\"[rk编号]\入库单]\编号] Like '\" & date2 & \"???'\") If IsNull(id) Then
Me.RK编号 = date2 & \"001\" Else
Me.RK编号 = date2 & Format(CStr(CInt(Right(id, 3)) + 1), \"000\") End If
按任意输入的日期值的年月自动编号 Dim a, b, c
c = Format(Me.凭证日期, \"yyyymm\") b = Nz(c, 0) * 1000
a = Nz(DMax(\"[凭证号码]\凭证\凭证.凭证日期,'yyyymm')=format([forms]![凭证录入].[凭证日期],'yyyymm')\"), 0) + 1 If a > b Then Me.凭证号码 = a
Else:
Me.凭证号码 = b + 1 End If
新增一条记录时使用Right及DMax函数让字段的数字部分自动加1
答：使用Right及DMax函数返回字段“FOO”的数字部分的最大值，然后加1 表达式为：
=\"REC-\" & right(DMax(\"FOO\Len(DMax(\"FOO\
InStr(1, DMax(\"FOO\
注意：但如果很多用户或多个程序都使用DMax去实现这个结果的话，特别在一个很大的表中这个过程会很慢，所以建议使用DefaultValue，它仅仅使用DMax一次 程序如下，写在更新事件中
Private Sub SomeField_AfterUpdate() Dim strMax as string
strMax =DMax(\"FOO\
me!HiddenFooCtl = \"REC-\" & right(strMax, len(strMax) - Instr(1,strMax, \"-\")) +1 End Sub
用按钮在窗体中添加新记录
Private Sub 添加新记录_Click() DoCmd.GoToRecord , , acNewRec
End Sub
选择保存文件路径 建模块：
Option Compare Database Option Explicit
' 调用方式:: string = BrowseForFolders(Hwnd,TitleOfDialog) ' 例如:String1 = BrowseForFolders(Hwnd, \"请选择位置……\") Public Type BrowseInfo hwndOwner As Long pIDLRoot As Long
pszDisplayName As Long lpszTitle As Long ulFlags As Long
lpfnCallback As Long lParam As Long iImage As Long End Type
Public Const BIF_RETURNONLYFSDIRS = 1 Public Const MAX_PATH = 260
Public Declare Sub CoTaskMemFree Lib \"ole32.dll\" (ByVal hMem As Long)
Public Declare Function lstrcat Lib \"kernel32\" Alias \"lstrcatA\" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib \"shell32\" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib \"shell32\" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String Dim iNull As Integer Dim lpIDList As Long Dim lResult As Long Dim sPath As String
Dim udtBI As BrowseInfo '初始化变量 With udtBI
.hwndOwner = hwndOwner
.lpszTitle = lstrcat(sPrompt, \"\") .ulFlags = BIF_RETURNONLYFSDIRS End With '调用 API
lpIDList = SHBrowseForFolder(udtBI) If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath) Call CoTaskMemFree(lpIDList) iNull = InStr(sPath, vbNullChar)
If iNull Then sPath = Left$(sPath, iNull - 1) End If
'如果选择取消, sPath = \"\" BrowseForFolder = sPath End Function
调用：
文本 = BrowseForFolder(Hwnd, \"Select target folder...\")
调用打开文件对话框 建立模块一：
Global Const conDialogTitle = \"请选择文件……\" 建立模块二：
Option Explicit ' Require variables to be declared before being used. Option Compare Database ' Use database order for string comparisons.
Declare Function GetOpen Lib \"comdlg32.dll\" Alias _ \"GetOpen\" (pOpen As OPEN) As Boolean
Declare Function GetSave Lib \"comdlg32.dll\" Alias _ \"GetSave\" (pOpen As OPEN) As Boolean
Private Declare Function apiGetComputerName Lib \"kernel32\" Alias _
\"GetComputerNameA\" (ByVal lpBuffer As String, nSize As Long) As Long Type MSA_OPEN
strFilter As String lngFilterIndex As Long strInitialDir As String strInitial String
strDialogTitle As String
strDefaultExtension As String lngFlags As Long
strFullPathReturned As String str As String int As Integer int As Integer End Type
Const ALLFILES = \"All Files\" Type OPEN
lStructSize As Long hwndOwner As Long hInstance As Long
lpstrFilter As String lpstrCustomFilter As Long nMaxCustrFilter As Long nFilterIndex As Long lpstr String nMax Long
lpstr As String nMax As Long
lpstrInitialDir As String lpstrTitle As String Flags As Long n As Integer n As Integer
lpstrDefExt As String lCustrData As Long lpfnHook As Long
lpTemplateName As Long End Type
Const OFN_ALLOWMULTISELECT = &H200 Const OFN_CREATEPROMPT = &H2000 Const OFN_EXPLORER = &H80000 Const OFN_ = &H1000
Const OFN_HIDEREADONLY = &H4 Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000 Const OFN_NONETWORKBUTTON = &H20000 Const OFN_NOREADONLYRETURN = &H8000 Const OFN_NOVALIDATE = &H100 Const OFN_OVERWRITEPROMPT = &H2 Const OFN_PATHMUSTEXIST = &H800 Const OFN_READONLY = &H1 Const OFN_SHOWHELP = &H10
Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String Dim strFilter As String Dim intRet As Integer Dim intNum As Integer intNum = UBound(varFilt) If (intNum <> -1) Then
For intRet = 0 To intNum
strFilter = strFilter & varFilt(intRet) & vbNullChar Next
If intNum Mod 2 = 0 Then
strFilter = strFilter & \"*.*\" & vbNullChar End If
strFilter = strFilter & vbNullChar Else
strFilter = \"\" End If
MSA_CreateFilterString = strFilter End Function
Function MSA_ConvertFilterString(strFilterIn As String) As String Dim strFilter As String
Dim intNum As Integer, intPos As Integer, intLastPos As Integer
strFilter = \"\" intNum = 0 intPos = 1 intLastPos = 1 Do
intPos = InStr(intLastPos, strFilterIn, \"|\") If (intPos > intLastPos) Then
strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar intNum = intNum + 1 intLastPos = intPos + 1
ElseIf (intPos = intLastPos) Then intLastPos = intPos + 1 End If
Loop Until (intPos = 0) intPos = Len(strFilterIn)
If (intPos >= intLastPos) Then
strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar intNum = intNum + 1 End If
If intNum Mod 2 = 1 Then
strFilter = strFilter & \"*.*\" & vbNullChar End If
If strFilter <> \"\" Then
strFilter = strFilter & vbNullChar End If
MSA_ConvertFilterString = strFilter End Function
Private Function MSA_GetSave(msaof As MSA_OPEN) As Integer Dim of As OPEN
Dim intRet As Integer MSAOF_to_OF msaof, of
of.Flags = of.Flags Or OFN_HIDEREADONLY intRet = GetSave(of) If intRet Then
OF_to_MSAOF of, msaof End If
MSA_GetSave = intRet End Function
Function MSA_SimpleGetSave() As String Dim msaof As MSA_OPEN Dim intRet As Integer Dim strRet As String
intRet = MSA_GetSave(msaof) If intRet Then
strRet = msaof.strFullPathReturned End If
MSA_SimpleGetSave = strRet End Function
Private Function MSA_GetOpen(msaof As MSA_OPEN) As Integer Dim of As OPEN
Dim intRet As Integer MSAOF_to_OF msaof, of intRet = GetOpen(of) If intRet Then
OF_to_MSAOF of, msaof End If
MSA_GetOpen = intRet End Function
Function MSA_SimpleGetOpen() As String Dim msaof As MSA_OPEN Dim intRet As Integer Dim strRet As String
intRet = MSA_GetOpen(msaof) If intRet Then
strRet = msaof.strFullPathReturned End If
MSA_SimpleGetOpen = strRet End Function
Private Sub OF_to_MSAOF(of As OPEN, msaof As MSA_OPEN)
msaof.strFullPathReturned = left(of.lpstrFile, InStrB(of.lpstrFile, vbNullChar) - 1) msaof.str = of.lpstr msaof.int = of.n msaof.int = of.n End Sub
Private Sub MSAOF_to_OF(msaof As MSA_OPEN, of As OPEN) Dim str String * 512
of.hwndOwner = Application.hWndAccessApp of.hInstance = 0
of.lpstrCustomFilter = 0 of.nMaxCustrFilter = 0 of.lpfnHook = 0
of.lpTemplateName = 0 of.lCustrData = 0
If msaof.strFilter = \"\" Then
of.lpstrFilter = MSA_CreateFilterString(ALLFILES) Else
of.lpstrFilter = msaof.strFilter End If
of.nFilterIndex = msaof.lngFilterIndex of.lpstrFile = msaof.strInitialFile _
& String(512 - Len(msaof.strInitialFile), 0) of.nMaxFile = 511
of.lpstr = String(512, 0) of.nMax = 511
of.lpstrTitle = msaof.strDialogTitle of.lpstrInitialDir = msaof.strInitialDir of.lpstrDefExt = msaof.strDefaultExtension of.Flags = msaof.lngFlags of.lStructSize = Len(of) End Sub
Function FindNorthwind(strSearchPath) As String Dim msaof As MSA_OPEN
msaof.strDialogTitle = conDialogTitle msaof.strInitialDir = strSearchPath
msaof.strFilter = MSA_CreateFilterString(\"Databases\ MSA_GetOpen msaof
FindNorthwind = Trim(msaof.strFullPathReturned)
End Function
Function MSAMachineName() As String Dim lngLen As Long, lngx As Long Dim strCompName As String lngLen = 16
strCompName = String$(lngLen, 0)
lngx = apiGetComputerName(strCompName, lngLen) If lngx <> 0 Then
MSAMachineName = left$(strCompName, lngLen) Else
MSAMachineName = \"\" End If End Function
应用：
Private Sub Command43_Click() Dim str As String
str = FindNorthwind(\"C:\\\") MsgBox str End Sub
查看当前库的路径 方法1.
= CurrentProject.Path 方法2.
Dim DBLongname, DBName, DBDir As String DBLongname = CodeDb.Name DBName = Dir(DBLongname)
DBDir = Left(DBLongname, Len(DBLongname) - Len(DBName)) MsgBox \"数据库所在目录：\" & DBDir 获取路径、文件名、扩展名 'ResultFlag=0 获取路径 'ResultFlag=1 获取文件名 'ResultFlag=2 获取扩展名
Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String Dim SplitPos As Integer, DotPos As Integer SplitPos = InStrRev(FullPath, \"\\\") DotPos = InStrRev(FullPath, \".\") Select Case ResultFlag Case 0
SplitPath = Left(FullPath, SplitPos - 1) Case 1
If DotPos = 0 Then DotPos = Len(FullPath) + 1
SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1) Case 2
If DotPos = 0 Then DotPos = Len(FullPath) SplitPath = Mid(FullPath, DotPos + 1) Case Else
Err.Raise vbObjectError + 1, \"SplitPath Function\End Select End Function
数据库与照片的关系如何处理？
有照片若干，怎样能在数据库中存储并显示？
1、把照片放进数据库，照片的格式最好是bmp，这样就可以在窗体上显示出来，不过这样数据库的体积会暴增。设一个OLE字段，然后插入对象就行了（对着字段单击右键）
2、不把照片放入数据库，只把照片的路径保存到数据库中，动态加载，这样可以支持很多种图片格式。（见示例）
If Dir(Application.CurrentProject.Path & \"\\img\\\" & Me!ID & \".jpg\") <> \"\" Then Me!照片.Picture = Application.CurrentProject.Path & \"\\img\\\" & Me!ID & \".jpg\" Else
Me!照片.Picture = Application.CurrentProject.Path & \"\\img\\0.jpg\" End If
导出成EXECL表
DoCmd.TransferSpreadsheet acExport, 8, \"\" & Text0 & \"\6、如何建立简单的超级连接？ *API函数声明
Private Declare Function ShellExecute Lib \"shell32.dll\" Alias \"ShellExecute A\" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lp String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd A s Long) As Long 注释：打开某个网址
ShellExecute 0, \"open\\"\";, vbNullString, vbNullString, 3 注释：给某个信箱发电子邮件
ShellExecute hwnd, \"open\\"mailto:\vbNullString, vbNullString, 0
ACCESS表
用ADO编程隐藏表 sub hide_table()
Dim cnn As New ADODB.Connection Dim cat As New ADOX.Catalog
Set cat.ActiveConnection = CurrentProject.Connection Dim tbl As ADOX.Table Dim pro As Property
For Each tbl In cat.Tables Debug.Print tbl.name
For Each pro In tbl.Properties
Debug.Print pro.name & \"=\" & pro.value Next
If tbl.name = \"需要隐藏的表名
\" Then tbl.Properties.Item(\"Jet OLEDB:Table Hidden In Access\") = True Next End Sub
删除外数据库mdb的所有表或一个表
DoCmd.DeleteObject acTable, \"表名\"，如果是连接表，并不能“删除外数据库mdb的所有表或一个表”。 不妨调用下面的子过程试试： Sub sbDeleteAllTables() Dim db As Database Dim td As TableDef
Set db = OpenDatabase(\"D:\\Documents and Settings\\GGLDD\\My Documents\\db1.mdb\") For Each td In db.TableDefs
If (td.Attributes And dbSystemObject) = 0 Then '不可删除系统表 db.Execute \"DROP TABLE \" & td.Name & \";\" End If Next
db.TableDefs.Refresh Set td = Nothing
Set db = Nothing End Sub
如何用VBA代码更改表中字段的数据类型或加字段 使用ALTER COLUMN改变一个当前字段的数据类型，需要指定字段名、新数据类型、还可以 (对文本和二进制字段)指定长度。 改字段
alter table 你的表名 alter column 你的字段名 数据类型
例如，下列语句把雇员表中一个字段的数据类型, 被称为ZipCode（最初被定义为整数），改变成一个10字符文本字段：
CurrentDb.Execute \"ALTER TABLE 地址 ALTER COLUMN sz TEXT(22)\" 改为逻辑型：
CurrentDb.Execute \"ALTER TABLE 地址 ALTER COLUMN sz BIT\" 日期时间：
CurrentDb.Execute \"ALTER TABLE 地址 ALTER COLUMN sz date\" 备注型：
CurrentDb.Execute \"ALTER TABLE 地址 ALTER COLUMN sz memo\" 货币：
money 8 个字节 介于 – 922,337,203,685,477.5808 到 922,337,203,685,477.5807 之间的符号整数。 real 4 个字节 单精度浮点数，负数范围是从 –3.402823e38 到 –1.401298e-45，正数从1.401298e-45 到 3.402823e38，和 0。
float 8 个字节 双精度浮点数，负数范围是从 –1.79769313486232e308 到 –4.947e-324，正数从 4.947e-324 到 1.79769313486232e308，和 0。
smallint 2 个字节 介于 –32,768 到 32,767 的短整型数。
integer 4 个字节 介于 –2,147,483,8 到 2,147,483,7 的长整型数。
decimal 17 个字节 容纳从 1028 - 1到 - 1028 - 1. 的值的精确的数字数据类型。你可以定义精度 (1 - 28) 和 符号 (0 - 定义精度)。缺省精度和符号分别是18和0
加字段
CurrentDb.Execute \"Alter Table 地址 Add Column 字段三 Char(2)\" CurrentDb.Execute \"Alter Table 地址 Add Column 字段1 BIT\" 如何用sql语句添加删除主键？ 来源：access911.net
Function AddPrimaryKey() '添加主键到[编号]字段 Dim strSQL As String
strSQL = \"ALTER TABLE 表1 ADD CONSTRAINT PRIMARY_KEY \" _ & \"PRIMARY KEY (编号)\"
CurrentProject.Connection.Execute strSQL End Function
Function DropPrimaryKey() '删除主键
Dim strSQL As String
strSQL = \"ALTER TABLE 表1 Drop CONSTRAINT PRIMARY_KEY \" CurrentProject.Connection.Execute strSQL End Function
用VBA代码建立表间字段的关系
转自：爱赛思应用俱乐部 gglddqccdc Sub CreateRelationX()
Dim relNew As Relation With CurrentDb
Set relNew = .CreateRelation(\"表2表1ID编号\\"表2\\"表
1\dbRelationDontEnforce + dbRelationUnique) 'dbRelationUnique)表示一对一 relNew.Fields.Append relNew.CreateField(\"ID\") relNew.Fields!ID.ForeignName = \"编号\" .Relations.Append relNew .Close End With End Sub
用ADO打开链接表
这是我以前十分头痛的问题，不知道那一堆一串的是什么意思现在知道了，这个是打开ACCESS的，打开别的表不在此讨论之内。
Dim appAccess As ADODB.Connection Dim strCn, temp As String Dim cat As ADOX.Catalog
Dim rstEmployees As ADODB.Recordset Dim intloop As Integer
Dim tbl1, tblEmp As ADOX.Table Dim idx As ADOX.Index
strCn = \"provider=microsoft.jet.oledb.4.0;password=;user id=admin; data source=\" _ & \"C:\\Program Files\\zhanyexing\\123.mdb;Jet OLEDB:Database Password=；\" Set appAccess = New ADODB.Connection appAccess.Open strCn
Set cat = New ADOX.Catalog cat.ActiveConnection = appAccess
路径改成自己的，如果有密码则在红色的Password=后面写上正确的密码，别的照抄就行了 如何更该链接表的设置 来源：ALEX
例如，数据库当前的路径可以用application.CurrentProject.Path得到，然后
用 application.CurrentProject.Path + \"\\link\\abc.mdb\"就可以指向数据库安装目录下面 link子目录下的ABC.MDB。
从文本框里输入新的数据库路径，然后更新链接。 Private Sub Command0_Click() Dim cat As ADOX.Catalog Dim tdf As ADOX.Table Me.txtDBnewNAME.SetFocus Set cat = New ADOX.Catalog
Set cat.ActiveConnection = CurrentProject.Connection Set tdf = cat.Tables(\"mytable\")
tdf.Properties(\"jet oledb:link datasource\")=Me.txtDBnewNAME.Text End Sub
如何在ADP启动时,判断数据库连接是否有效并重新连接
这是微软MSDN中，在ADP项目中创建ADP的数据库的默认连接的代码
Public Function sCreateConnection(sSvrName As String, sUID As String, sPWD As String, sDatabase As String) As String
'该函数在ADP中检查连接，如果没有，它将通过输入参数创建一个连接
'输入:sSvrName 数据库服务器名sUID 用户名sPWD 口令sDatabase MSDE数据库名 '输出:连接状态
On Error GoTo sCreateConnectionTrap:
If Application.CurrentProject.BaseConnectionString = \"\" Then '表示ADP处于无连接状态
sConnectionString = \"PROVIDER=SQLOLEDB.1;PASSWORD=\" & sPWD _ & \";PERSIST SECURITY INFO=TRUE;USER ID=\" & sUID & \"; _ INITIAL CATALOG=\" & sDatabase & \";DATA SOURCE=\" & sSvrName Application.CurrentProject.OpenConnection sConnectionString
sCreateConnection = \"创建了到 \" & sDatabase & \" 数据库的连接!\" Else '连接已存在
sCreateConnection = \"已经存在到 \" & sDatabase & \" 数据库的连接!\" End If
sCreateConnectionExit: Exit Function
sCreateConnectionTrap:
sCreateConnection = Err.Description Resume sCreateConnectionExit End Function
此例程将从 ADP 删除连接,使其处于无连接状态。 Sub MakeADPConnectionless()
Application.CurrentProject.CloseConnection '关闭连接
Application.CurrentProject.OpenConnection '将连接设置为无 End Sub
重新定位链接表二步走
来源：爱赛思应用俱乐部 kevindeng
尽管Accxp网上有很多关于定位链接表的贴子，但还是有很多的朋友询问这方面的问题。应letter网友的提议，结合Alex总版主的重新定位链接表文件源码，现将这方面的具体操作介绍如下： 假设前台数据库文件名为frontBase.mdb 后台数据库文件名为backData.mdb
frontBase当中有链接表tbl1, tbl2, tbl3, …，链接到backData.mdb中
首先我们要在前台数据库文件的启动窗体加载事件中判断链接是否正确，方法是打开任意一个链接表，假设为tbl1，代码如下：
Public Function CheckLinks() As Boolean
' 检查到后台数据库的链接；如果链接存在且正确的话，返回 True 。 Dim dbs As Database, rst As DAO.Recordset Set dbs = CurrentDb()
' 打开链接表查看表链接信息是否正确。 On Error Resume Next
Set rst = dbs.OpenRecordset(“tbl1”) rst.Close
' 如果没有错误，返回 True 。 If Err = 0 Then CheckLinks = True Else
CheckLinks = False End If End Function
启动窗体的加载事件：
Private Sub FORM_Load()
If CheckLinks = False then Docmd.OpenFORM “frmConnect” End If End Sub
frmConnect 连接窗体如下图 [img]f:\\m.bmp[/img]
接下来的事情就是如何刷新链接表了。
上面的窗体右边的按钮是用用来调用API打开文件对话框，具体代码如下：
Declare Function GetOpen Lib \"comdlg32.dll\" Alias \"GetOpen\" (pOpen As OPEN) As Boolean
Type OPEN
lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String
lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstr String nMax Long
lpstr As String nMax As Long
lpstrInitialDir As String lpstrTitle As String flags As Long n As Integer n As Integer
lpstrDefExt As String lCustData As Long lpfnHook As Long
lpTemplateName As String End Type
Private Sub ()
Dim ofn As OPEN Dim rtn As String
ofn.lStructSize = Len(ofn) ofn.hwndOwner = Me.hwnd
ofn.lpstrFilter = \"数据库文件 (*.mdb)\" & ofn.lpstrFile = Space(254) ofn.nMaxFile = 255 ofn.lpstr = Space(254) ofn.nMax = 255
ofn.lpstrInitialDir = CurrentProject.Path ofn.lpstrTitle = \"后台数据文件为\" ofn.flags = 6148 rtn = GetOpen(ofn)
If rtn = True Then = ofn.lpstrFile =
OK.Enabled = True Else
= \"\" End If End Sub
连接按钮刷新链接表，代码如下： Private Sub OK_Click() Dim tabDef As TableDef
For Each tabDef In CurrentDb.TableDefs If Len(tabDef.Connect) > 0 Then
vbNullChar & \"*.mdb\" tabDef.Connect = \";DATABASE=\" & Me. & \";PWD=\" + 后台数据库密码 tabDef.RefreshLink End If Next
MsgBox \"连接成功！\"
DoCmd.Close acFORM, Me.Name End Sub
其实很简单只有两步，判断链接是否正确和刷新链接表。
清空表记录的方法
1、CurrentDb().Execute \"delete * from 表名\" 2、docmd.runsql \"SQL语句\" 3，RunSQL \"Delete * From 表名\" VB语句删除记录： For I = 1 To 20
SQL = \"DELETE 订单明细ID FROM 订单明细 WHERE 订单明细ID=\" & I DoCmd.RunSQL SQL Next 或：
CurrentProject.Connection.Execute \"DELETE * FROM要删除记录的表\" 用VBA编程把Excel表中数据追加到Access表中 Private Sub Command0_Click()
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, \"temp\End Sub
SQL--JOIN之完全用法 来源：ACCESS设计在线
外联接。外联接可以是左向外联接、右向外联接或完整外部联接。 在 FROM 子句中指定外联接时，可以由下列几组关键字中的一组指定： LEFT JOIN 或 LEFT OUTER JOIN。
左向外联接的结果集包括 LEFT OUTER 子句中指定的左表的所有行，而不仅仅是联接列所匹配的行。如果左表的某行在右表中没有匹配行，则在相关联的结果集行中右表的所有选择列表列均为空值。 RIGHT JOIN 或 RIGHT OUTER JOIN。
右向外联接是左向外联接的反向联接。将返回右表的所有行。如果右表的某行在左表中没有匹配行，则将为左表返回空值。
FULL JOIN 或 FULL OUTER JOIN。
完整外部联接返回左表和右表中的所有行。当某行在另一个表中没有匹配行时，则另一个表的选择列表列包含空值。如果表之间有匹配行，则整个结果集行包含基表的数据值。
仅当至少有一个同属于两表的行符合联接条件时，内联接才返回行。内联接消除与另一个表中的任何行不匹配的行。而外联接会返回 FROM 子句中提到的至少一个表或视图的所有行，只要这些行符合任
何 WHERE 或 HAVING 搜索条件。将检索通过左向外联接引用的左表的所有行，以及通过右向外联接引用的右表的所有行。完整外部联接中两个表的所有行都将返回。
Microsoft® SQL Server™ 2000 对在 FROM 子句中指定的外联接使用以下 SQL-92 关键字： LEFT OUTER JOIN 或 LEFT JOIN
RIGHT OUTER JOIN 或 RIGHT JOIN
FULL OUTER JOIN 或 FULL JOIN
SQL Server 支持 SQL-92 外联接语法，以及在 WHERE 子句中使用 *= 和 =* 运算符指定外联接的旧式语法。由于 SQL-92 语法不容易产生歧义，而旧式 Transact-SQL 外联接有时会产生歧义，因此建议使用 SQL-92 语法。
使用左向外联接
假设在 city 列上联接 authors 表和 publishers 表。结果只显示在出版商所在城市居住的作者（本例中为 Abraham Bennet 和 Cheryl Carson）。
若要在结果中包括所有的作者，而不管出版商是否住在同一个城市，请使用 SQL-92 左向外联接。下面是 Transact-SQL 左向外联接的查询和结果： USE pubs
SELECT a.au_fname, a.au_lname, p.pub_name
FROM authors a LEFT OUTER JOIN publishers p ON a.city = p.city
ORDER BY p.pub_name ASC, a.au_lname ASC, a.au_fname ASC 下面是结果集：
au_fname au_lname pub_name
------------------- ------------------------------ ----------------- Reginald Blotchet-Halls NULL Michel DeFrance NULL Innes del Castillo NULL Ann Dull NULL
Marjorie Green NULL Morningstar Greene NULL Burt Gringlesby NULL Sheryl Hunter NULL Livia Karsen NULL
Charlene Locksley NULL Stearns MacFeather NULL Heather McBadden NULL Michael O'Leary NULL Sylvia Panteley NULL Albert Ringer NULL Anne Ringer NULL Meander Smith NULL Dean Straight NULL Dirk Stringer NULL Johnson White NULL Akiko Yokomoto NULL
Abraham Bennet Algodata Infosystems Cheryl Carson Algodata Infosystems (23 row(s) affected)
不管是否与 publishers 表中的 city 列匹配，LEFT OUTER JOIN 均会在结果中包含 authors 表的所有行。注意：结果中所列的大多数作者都没有相匹配的数据,因此，这些行的 pub_name 列包含空值。 使用右向外联接
假设在 city 列上联接 authors 表和 publishers 表。结果只显示在出版商所在城市居住的作者（本例中为 Abraham Bennet 和 Cheryl Carson）。SQL-92 右向外联接运算符 RIGHT OUTER JOIN 指明：不管第一个表中是否有匹配的数据，结果将包含第二个表中的所有行。
若要在结果中包括所有的出版商，而不管城市中是否还有出版商居住，请使用 SQL-92 右向外联接。下面是 Transact-SQL 右向外联接的查询和结果： USE pubs
SELECT a.au_fname, a.au_lname, p.pub_name
FROM authors AS a RIGHT OUTER JOIN publishers AS p ON a.city = p.city
ORDER BY p.pub_name ASC, a.au_lname ASC, a.au_fname ASC 下面是结果集：
au_fname au_lname pub_name
-------------------- ------------------------ -------------------- Abraham Bennet Algodata Infosystems
Cheryl Carson Algodata Infosystems NULL NULL Binnet & Hardley
NULL NULL Five Lakes Publishing NULL NULL GGG&G
NULL NULL Lucerne Publishing NULL NULL New Moon Books NULL NULL Ramona Publishers NULL NULL Scootney Books (9 row(s) affected)
使用谓词（如将联接与常量比较）可以进一步外联接。下例包含相同的右向外联接，但消除销售量低于 50 本的书籍的书名： USE pubs
SELECT s.stor_id, s.qty, t.title
FROM sales s RIGHT OUTER JOIN titles t ON s.title_id = t.title_id AND s.qty > 50
ORDER BY s.stor_id ASC 下面是结果集：
stor_id qty title
------- ------ --------------------------------------------------------- (null) (null) But Is It User Friendly?
(null) (null) Computer Phobic AND Non-Phobic Individuals: Behavior Variations
(null) (null) Cooking with Computers: Surreptitious Balance Sheets (null) (null) Emotional Security: A New Algorithm
(null) (null) Fifty Years in Buckingham Palace Kitchens 7066 75 Is Anger the Enemy? (null) (null) Life Without Fear (null) (null) Net Etiquette
(null) (null) Onions, Leeks, and Garlic: Cooking Secrets of the Mediterranean
(null) (null) Prolonged Data Deprivation: Four Case Studies (null) (null) Secrets of Silicon Valley
(null) (null) Silicon Valley Gastronomic Treats (null) (null) Straight Talk About Computers (null) (null) Sushi, Anyone?
(null) (null) The Busy Executive's Database Guide (null) (null) The Gourmet Microwave
(null) (null) The Psychology of Computer Cooking (null) (null) You Can Combat Computer Stress! (18 row(s) affected)
有关谓词的更多信息，请参见 WHERE。 使用完整外部联接
若要通过在联接结果中包括不匹配的行保留不匹配信息，请使用完整外部联接。Microsoft® SQL Server™ 2000 提供完整外部联接运算符 FULL OUTER JOIN，不管另一个表是否有匹配的值，此运算符都包括两个表中的所有行。
假设在 city 列上联接 authors 表和 publishers 表。结果只显示在出版商所在城市居住的作者（本例中为 Abraham Bennet 和 Cheryl Carson）。SQL-92 FULL OUTER JOIN 运算符指明：不管表中是否有匹配的数据，结果将包括两个表中的所有行。
若要在结果中包括所有作者和出版商，而不管城市中是否有出版商或者出版商是否住在同一个城市，请使用完整外部联接。下面是 Transact-SQL 完整外部联接的查询和结果： USE pubs
SELECT a.au_fname, a.au_lname, p.pub_name
FROM authors a FULL OUTER JOIN publishers p
ON a.city = p.city
ORDER BY p.pub_name ASC, a.au_lname ASC, a.au_fname ASC 下面是结果集：
au_fname au_lname pub_name
-------------------- ---------------------------- -------------------- Reginald Blotchet-Halls NULL Michel DeFrance NULL Innes del Castillo NULL Ann Dull NULL
Marjorie Green NULL Morningstar Greene NULL Burt Gringlesby NULL Sheryl Hunter NULL Livia Karsen NULL
Charlene Locksley NULL Stearns MacFeather NULL Heather McBadden NULL Michael O'Leary NULL Sylvia Panteley NULL Albert Ringer NULL Anne Ringer NULL Meander Smith NULL Dean Straight NULL Dirk Stringer NULL Johnson White NULL Akiko Yokomoto NULL
Abraham Bennet Algodata Infosystems Cheryl Carson Algodata Infosystems NULL NULL Binnet & Hardley
NULL NULL Five Lakes Publishing NULL NULL GGG&G
NULL NULL Lucerne Publishing NULL NULL New Moon Books NULL NULL Ramona Publishers NULL NULL Scootney Books (30 row(s) affected)
数字金额转换为大写的函数
函数只支持到千亿,如果需要,可以增加 CU 数组的长度,算法不变. '将数字转换为大写
Public Function MoneyConv(Money As Currency) As String On Error GoTo Doerr
Dim CN(9) As String Dim CU(15) As String
Dim Temp As String, strNum As String Dim CM As String
Dim tFirst As String, tEnd As String
Dim i As Long, j As Long, k As Long CN(0) = \"零\" CN(1) = \"壹\" CN(2) = \"贰\" CN(3) = \"叁\" CN(4) = \"肆\" CN(5) = \"伍\"
CN(6) = \"陆\" CN(7) = \"柒\" CN(8) = \"捌\" CN(9) = \"玖\"
' CU(0) = \"分\" ' CU(1) = \"角\" CU(0) = \"圆\" CU(1) = \"十\" CU(2) = \"佰\" CU(3) = \"仟\" CU(4) = \"万\" CU(5) = \"十\" CU(6) = \"佰\" CU(7) = \"仟\" CU(8) = \"亿\" CU(9) = \"十\" CU(10) = \"佰\" CU(11) = \"仟\"
If Money = 0 Then CM = \"零圆整\" GoTo Complete End If
strNum = Trim(str(FormatCurrency(Money, 2, vbTrue, vbFalse, If Left(strNum, 1) = \"-\" Then tFirst = \"负\"
strNum = Right(strNum, Len(strNum) - 1) Else
tFirst = \"\" End If
i = InStrRev(strNum, \".\") If i <> 0 Then
Temp = Right(strNum, i)
If Len(strNum) - i = 1 Then Temp = Temp + \"0\" CM = CN(CInt(Left(Right(Temp, 2), 1))) + \"角\" + CN(CInt(Right(Temp, 1))) + \"分\" tEnd = \"\"
strNum = Left(strNum, i - 1) Else
tEnd = \"整\" End If
i = 0
For j = Len(strNum) To 1 Step -1
k = CInt(Right(Left(strNum, j), 1)) If k = 0 Then
If i <> 0 And i <> 4 And i <> 8 Then CM = CN(k) + CM Else
CM = CN(k) + CU(i) + CM End If Else
vbFalse))) CM = CN(k) + CU(i) + CM End If
' CM = CN(k) + CU(i) + CM i = i + 1 Next j
CM = tFirst + CM + tEnd
CM = Replace(CM, \"零零\\"零\") CM = Replace(CM, \"零零\\"零\")
CM = Replace(CM, \"亿零万零圆\\"亿圆\") CM = Replace(CM, \"亿零万\\"亿零\") CM = Replace(CM, \"万零圆\\"万圆\") CM = Replace(CM, \"零亿\\"亿\") CM = Replace(CM, \"零万\\"万\") CM = Replace(CM, \"零圆\\"圆\") CM = Replace(CM, \"零零\\"零\")
CM = Replace(CM, \"零零\\"零\") '重复替换一次 Complete:
Gerr = 0 '操作成功,无错误发生 MoneyConv = CM
Exit Function Doerr:
Gerr = -1 '未知错误 Errexit:
MoneyConv = \"\" End Function
数字货币转换为大写格式
以下为数字货币转换为大写格式程序, 首先建一个模块, 将以下程序复制进去并保存. (位)
调用方式为:
dollars = chMoney(Val(inputValue)) ^ ^ 须显示 填写小 大写的 写的控 控件 件名
' 名称： CCh
' 得到一位数字 N1 的汉字大写 ' 0 返回 \"\"
Public Function CCh(N1) As String Select Case N1 Case 0
CCh = \"零\" Case 1
CCh = \"壹\" Case 2
CCh = \"贰\" Case 3
CCh = \"叁\" Case 4
CCh = \"肆\" Case 5
CCh = \"伍\"
注: 最高位数为千万 Case 6
CCh = \"陆\" Case 7
CCh = \"柒\" Case 8
CCh = \"捌\" Case 9
CCh = \"玖\" End Select End Function
'名称： ChMoney
' 得到数字 N1 的汉字大写。最大为 千万位。 O 返回 Public Function chMoney(N1) As String Dim tMoney As String Dim lMoney As String Dim tn '小数位置
Dim s1 As String '临时STRING 小数部分 Dim s2 As String '1000 以内 Dim s3 As String '10000 Dim st1, t1
If N1 = 0 Then chMoney = \" \" Exit Function End If
If N1 < 0 Then
chMoney = \"负\" + chMoney(Abs(N1)) Exit Function End If
tMoney = Trim(Str(N1))
tn = InStr(tMoney, \".\") '小数位置 s1 = \"\"
If tn <> 0 Then
st1 = Right(tMoney, Len(tMoney) - tn) If st1 <> \"\" Then t1 = Left(st1, 1)
st1 = Right(st1, Len(st1) - 1) If t1 <> \"0\" Then
s1 = s1 + CCh(Val(t1)) + \"角\" End If
If st1 <> \"\" Then t1 = Left(st1, 1)
s1 = s1 + CCh(Val(t1)) + \"分\" End If End If
st1 = Left(tMoney, tn - 1) Else
st1 = tMoney End If
s2 = \"\"
If st1 <> \"\" Then
t1 = Right(st1, 1)
st1 = Left(st1, Len(st1) - 1) s2 = CCh(Val(t1)) + s2 End If
If st1 <> \"\" Then t1 = Right(st1, 1)
st1 = Left(st1, Len(st1) - 1) If t1 <> \"0\" Then
s2 = CCh(Val(t1)) + \"拾\" + s2 Else
If Left(s2, 1) <> \"零\" Then s2 = \"零\" + s2 End If End If
If st1 <> \"\" Then t1 = Right(st1, 1)
st1 = Left(st1, Len(st1) - 1) If t1 <> \"0\" Then
s2 = CCh(Val(t1)) + \"佰\" + s2 Else
If Left(s2, 1) <> \"零\" Then s2 = \"零\" + s2 End If End If
If st1 <> \"\" Then t1 = Right(st1, 1)
st1 = Left(st1, Len(st1) - 1) If t1 <> \"0\" Then
s2 = CCh(Val(t1)) + \"仟\" + s2 Else
If Left(s2, 1) <> \"零\" Then s2 = \"零\" + s2 End If End If
s3 = \"\"
If st1 <> \"\" Then t1 = Right(st1, 1)
st1 = Left(st1, Len(st1) - 1) s3 = CCh(Val(t1)) + s3 End If
If st1 <> \"\" Then t1 = Right(st1, 1)
st1 = Left(st1, Len(st1) - 1) If t1 <> \"0\" Then
s3 = CCh(Val(t1)) + \"拾\" + s3 Else
If Left(s3, 1) <> \"零\" Then s3 = \"零\" + s3 End If End If
If st1 <> \"\" Then
t1 = Right(st1, 1)
st1 = Left(st1, Len(st1) - 1) If t1 <> \"0\" Then
s3 = CCh(Val(t1)) + \"佰\" + s3 Else
If Left(s3, 1) <> \"零\" Then s3 = \"零\" + s3 End If End If
If st1 <> \"\" Then t1 = Right(st1, 1)
st1 = Left(st1, Len(st1) - 1) If t1 <> \"0\" Then
s3 = CCh(Val(t1)) + \"仟\" + s3 End If End If
If Right(s2, 1) = \"零\" Then s2 = Left(s2, Len(s2) - 1) If Len(s3) > 0 Then
If Right(s3, 1) = \"零\" Then s3 = Left(s3, Len(s3) - 1) s3 = s3 & \"万\" End If
chMoney = IIf(s3 & s2 = \"\元\" & s1)
End Function
ACCESS查询 分段统计人数
这样一个表 tblScore：
班级 姓名 总分 语文 数学 1班 a 601 108 120 2班 b 5 112 133 3班 C 551 98 145 2班 D 502 80 124 1班 E 508 90 85 3班 F 561 97 135
TRANSFORM Count(tblScore.总分) AS 总分OfCount SELECT tblScore.班级 FROM tblScore
GROUP BY tblScore.班级
PIVOT Switch([总分]>=600,\">=600\总分]>=550 And [总分]<600,\"550-599\总分]>=500 And [总分]<550,\"500-549\
可得到第一個查詢
班级 总分600分以上人数 总分550-600人数 总分550以下人数 1
班 1 0 1 2
班 0 1 1
3班 0 2 0
本示例假设您有一个“Orders”表，且里头含有一个“Freight”字段。程序建立一个“选择”来计算运费落在某些范围内的订单数量。Partition 函数是用来确定这些范围，然后调用 SQL Count 函数来计算在每个范围内的订单数量。本示例中，Partition 函数的参数值为 start = 0，stop = 500，interval = 50。第一个范围会是 0：49，每隔 50 一个范围，依次而下直到运费为 500 为止。 SELECT DISTINCTROW Partition([freight],0, 500, 50) AS Range, Count(Orders.Freight) AS Count FROM Orders
GROUP BY Partition([freight],0,500,50);
用代码在ACCESS中生成永久查询 来源：竹笛整理的技巧集 dim strSQL as string dim qdf as QueryDef
strSQL = \"SELECT * from tblaa\" 'tblaa为表
Set qdf = CurrentDb.CreateQueryDef(\"创建的查询\DoCmd.OpenQuery qdf.Name 屏蔽操作查询提示
DoCmd.SetWarnings False 用代码删除一个已存在的查询 来源：爱赛思应用俱乐部 wxjgw Dim Query1 As QueryDef
CurrentDb.QueryDefs.Refresh For Each Query1 In CurrentDb.QueryDefs
If Query1.Name = \"想要删除的查询名称\" Then CurrentDb.QueryDefs.Delete Query1.Name Exit For End If
Next Query1
使用ADO和SQL语句建立一个新查询 来源：ACCESS中国 huanghai
Dim cat As New ADOX.Catalog Dim cmd As New ADODB.Command
Set cat.ActiveConnection = CurrentProject.Connection cmd.CommandText = \"SELECT * FROM 表1\" cat.Views.Append \"newView\cmd
以窗体的文体框为条件进行模糊查询时查询的设计视图中准则：
Like IIf(IsNull([Forms]![存书查询窗体]![作者]),'*','*' & [Forms]![存书查询窗体]![作者] & '*')
用VBA代码生成一个条件组合的字符串作为子窗体的窗体筛选的条件来实现窗体的多条件查询。
Option Compare Database
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ '刘小军（ALEX），2003-5-22 '
'由浅入深的介绍几种最常用的利用主/子窗体来实现查询的方法， '使初学者和有一定VBA基础的人可以更好的使用窗体查询这种手段。 '
'本例程是讲解用VBA代码生成一个条件组合的字符串作为子窗体的 '窗体筛选的条件来实现窗体的多条件查询。 '
'欢迎访问 ACCESS编程应用网
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Private Sub cmd查询_Click() On Error GoTo Err_cmd查询_Click
Dim strWhere As String '定义条件字符串
strWhere = \"\" '设定初始值－空字符串
'判断【书名】条件是否有输入的值 If Not IsNull(Me.书名) Then '有输入
strWhere = strWhere & \"([书名] like '*\" & Me.书名 & \"*') AND \" End If
'判断【类别】条件是否有输入的值 If Not IsNull(Me.类别) Then '有输入
strWhere = strWhere & \"([类别] like '\" & Me.类别 & \"') AND \" End If
'判断【作者】条件是否有输入的值 If Not IsNull(Me.作者) Then '有输入
strWhere = strWhere & \"([作者] like '*\" & Me.作者 & \"*') AND \" End If
'判断【出版社】条件是否有输入的值 If Not IsNull(Me.出版社) Then '有输入
strWhere = strWhere & \"([出版社] like '\" & Me.出版社 & \"') AND \" End If
'判断【单价】条件是否有输入的值，由于有【单价开始】【单价截止】两个文本框 '所以要分开来考虑
If Not IsNull(Me.单价开始) Then '【单价开始】有输入
strWhere = strWhere & \"([单价] >= \" & Me.单价开始 & \") AND \" End If
If Not IsNull(Me.单价截止) Then '【单价截止】有输入
strWhere = strWhere & \"([单价] <= \" & Me.单价截止 & \") AND \" End If
'判断【进书日期】条件是否有输入的值，由于有【进书日期开始】【进书日期截止】两个文本框 '所以要分开来考虑
If Not IsNull(Me.进书日期开始) Then '【进书日期开始】有输入
strWhere = strWhere & \"([进书日期] >= #\" & Format(Me.进书日期开始, \"yyyy-mm-dd\") & \"#) AND \"
End If
If Not IsNull(Me.进书日期截止) Then '【进书日期截止】有输入
strWhere = strWhere & \"([进书日期] <= #\" & Format(Me.进书日期截止, \"yyyy-mm-dd\") & \"#) AND
\"
End If
'如果输入了条件，那么strWhere的最后肯定有\" AND \"，这是我们不需要的， '要用LEFT函数截掉这5个字符。 If Len(strWhere) > 0 Then '有输入条件
strWhere = Left(strWhere, Len(strWhere) - 5) End If
'先在立即窗口显示一下strWhere的值，代码调试完成后可以取消下一句 Debug.Print strWhere
'让子窗体应用窗体查询
Me.存书查询子窗体.Form.Filter = strWhere Me.存书查询子窗体.Form.FilterOn = True
'在子窗体筛选后要运行一下自编子程序CheckSubformCount() Call CheckSubformCount
Exit_cmd查询_Click: Exit Sub
Err_cmd查询_Click:
MsgBox Err.Description Resume Exit_cmd查询_Click End Sub
Private Sub cmd导出_Click() On Error GoTo Err_cmd导出_Click '刘小军(Alex) 2003-5-22
'这里将使用DAO来改变查询的SQL语句，必须先在“工具”→“引用”中选择 'Microsoft DAO 3.6 Object Library.
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Dim qdf As DAO.QueryDef 'qdf被定义为一个查询定义对象 Dim strWhere, strSQL As String
strWhere = Me.存书查询子窗体.Form.Filter If strWhere = \"\" Then '没有条件
strSQL = \"SELECT * FROM [存书查询]\" Else
'有条件
strSQL = \"SELECT * FROM [存书查询] WHERE \" & strWhere End If
Set qdf = CurrentDb.QueryDefs(\"查询结果\") qdf.SQL = strSQL qdf.Close
Set qdf = Nothing
DoCmd.OutputTo acOutputQuery, \"查询结果\
Exit_cmd导出_Click: Exit Sub
Err_cmd导出_Click:
MsgBox Err.Description Resume Exit_cmd导出_Click End Sub
Private Sub cmd清除_Click() On Error GoTo Err_cmd清除_Click '刘小军(Alex) 2003-5-22
'这里将使用FOR EACH CONTROL的方法来清除控件的值 '这在控件比较多的时候非常有用。
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Dim ctl As Control
For Each ctl In Me.Controls
'根据ctl的控件类型来选择 Select Case ctl.ControlType
Case acTextBox '是文本框，要清空(注意，子窗体下面还有两个锁定的文本框不能赋值) If ctl.Locked = False Then ctl.Value = Null
Case acComboBox '是组合框，也要清空 ctl.Value = Null '其它类型的控件不处理
End Select Next
'取消子窗体的筛选
Me.存书查询子窗体.Form.Filter = \"\"
Me.存书查询子窗体.Form.FilterOn = False
'在子窗体取消筛选后要运行一下自编子程序CheckSubformCount() Call CheckSubformCount
Exit_cmd清除_Click: Exit Sub
Err_cmd清除_Click:
MsgBox Err.Description Resume Exit_cmd清除_Click End Sub
Private Sub cmd预览报表_Click()
On Error GoTo Err_cmd预览报表_Click
Dim stDocName, strWhere As String
stDocName = \"藏书情况报表\"
strWhere = Me.存书查询子窗体.Form.Filter
'在打开报表的同时把子窗体的筛选条件字符串也传递给报表， '这样地话报表也会显示和子窗体相同的记录。
DoCmd.OpenReport stDocName, acPreview, , strWhere
Exit_cmd预览报表_Click: Exit Sub
Err_cmd预览报表_Click: MsgBox Err.Description
Resume Exit_cmd预览报表_Click End Sub
Private Sub CheckSubformCount() '刘小军(Alex) 2003-5-22
'这是一个自编子程序，专门用来检查子窗体上的记录数， '以便修改主窗体上的“计数”和“合计”的控件来源， '以防止出现“#错误”。
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
If Me.存书查询子窗体.Form.Recordset.RecordCount > 0 Then '子窗体的记录数>0
Me.计数.ControlSource = \"=[存书查询子窗体].[Form].[txt计数]\" Me.合计.ControlSource = \"=[存书查询子窗体].[Form].[txt单价合计]\" Else
'子窗体的记录数=0
Me.计数.ControlSource = \"=0\" Me.合计.ControlSource = \"=0\" End If End Sub
用VBA代码+DAO生成带条件的交叉表查询 Option Compare Database
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ '刘小军（ALEX），2003-5-26 '
'由浅入深的介绍几种最常用的利用主/子窗体来实现查询的方法， '使初学者和有一定VBA基础的人可以更好的使用窗体查询这种手段。 '
'本例程是讲解用VBA代码+DAO生成带条件的交叉表查询。 '
'欢迎访问 ACCESS编程应用网
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Private Sub cmd查询_Click() On Error GoTo Err_cmd查询_Click
Dim strWhere As String '定义条件字符串
Dim qdf As DAO.QueryDef 'qdf被定义为一个查询定义对象 Dim strSQL As String
strWhere = \"\" '设定初始值－空字符串
'判断【类别】条件是否有输入的值 If Not IsNull(Me.类别) Then '有输入
strWhere = strWhere & \"([类别] like '\" & Me.类别 & \"') AND \" End If
'判断【出版社】条件是否有输入的值 If Not IsNull(Me.出版社) Then '有输入
strWhere = strWhere & \"([出版社] like '\" & Me.出版社 & \"') AND \" End If
'判断【单价】条件是否有输入的值，由于有【单价开始】【单价截止】两个文本框 '所以要分开来考虑
If Not IsNull(Me.单价开始) Then '【单价开始】有输入
strWhere = strWhere & \"([单价] >= \" & Me.单价开始 & \") AND \" End If
If Not IsNull(Me.单价截止) Then '【单价截止】有输入
strWhere = strWhere & \"([单价] <= \" & Me.单价截止 & \") AND \" End If
'判断【进书日期】条件是否有输入的值，由于有【进书日期开始】【进书日期截止】两个文本框 '所以要分开来考虑
If Not IsNull(Me.进书日期开始) Then '【进书日期开始】有输入
strWhere = strWhere & \"([进书日期] >= #\" & Format(Me.进书日期开始, \"yyyy-mm-dd\") & \"#) AND \"
End If
If Not IsNull(Me.进书日期截止) Then '【进书日期截止】有输入
strWhere = strWhere & \"([进书日期] <= #\" & Format(Me.进书日期截止, \"yyyy-mm-dd\") & \"#) AND \"
End If
'如果输入了条件，那么strWhere的最后肯定有\" AND \"，这是我们不需要的， '要用LEFT函数截掉这5个字符。 If Len(strWhere) > 0 Then '有输入条件
strWhere = Left(strWhere, Len(strWhere) - 5) End If
'先在立即窗口显示一下strWhere的值，代码调试完成后可以取消下一句
'Debug.Print strWhere
'根据是否有条件来设定交叉表查询的SQL语句 If Len(strWhere) > 0 Then
strSQL = \"TRANSFORM Sum(存书查询.单价) AS 单价之Sum SELECT 存书查询.类别 FROM 存书查询 \" strSQL = strSQL & \"WHERE(\" & strWhere
strSQL = strSQL & \") GROUP BY 存书查询.类别 PIVOT Format([进书日期],'yyyy/mm')\" Else
strSQL = \"TRANSFORM Sum(存书查询.单价) AS 单价之Sum\" & _ \" SELECT 存书查询.类别\" & _ \" FROM 存书查询\" & _
\" GROUP BY 存书查询.类别\" & _
\" PIVOT Format([进书日期],'yyyy/mm')\" End If
'修改交叉表查询的SQL语句
Set qdf = CurrentDb.QueryDefs(\"存书查询_交叉表\") qdf.SQL = strSQL qdf.Close
Set qdf = Nothing
'显示交叉表的内容，不能直接刷新 Me.存书查询子窗体.SourceObject = \"\"
Me.存书查询子窗体.SourceObject = \"查询.存书查询_交叉表\"
'刷新计数和合计显示
Me.计数 = DCount(\"*\存书查询_交叉表\")
Me.合计 = DSum(\"[单价]\存书查询\
Exit_cmd查询_Click: Exit Sub
Err_cmd查询_Click:
MsgBox Err.Description Resume Exit_cmd查询_Click End Sub
Private Sub cmd导出_Click() On Error GoTo Err_cmd导出_Click '刘小军(Alex) 2003-5-27
'由于前面我们已经通过DAO修改了“存书查询_交叉表”的SQL语句， '所以这里我们直接导出就可以了。
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
DoCmd.OutputTo acOutputQuery, \"存书查询_交叉表\
Exit_cmd导出_Click: Exit Sub
Err_cmd导出_Click:
MsgBox Err.Description Resume Exit_cmd导出_Click End Sub
Private Sub cmd清除_Click() On Error GoTo Err_cmd清除_Click '刘小军(Alex) 2003-5-27
'这里将使用FOR EACH CONTROL的方法来清除控件的值 '这在控件比较多的时候非常有用。
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Dim ctl As Control
Dim qdf As DAO.QueryDef 'qdf被定义为一个查询定义对象 Dim strSQL As String
For Each ctl In Me.Controls
'根据ctl的控件类型来选择 Select Case ctl.ControlType
Case acTextBox '是文本框，要清空(注意，子窗体下面还有两个锁定的文本框不能赋值) If ctl.Locked = False Then ctl.Value = Null
Case acComboBox '是组合框，也要清空 ctl.Value = Null '其它类型的控件不处理
End Select Next
strSQL = \"TRANSFORM Sum(存书查询.单价) AS 单价之Sum\" & _ \" SELECT 存书查询.类别\" & _ \" FROM 存书查询\" & _
\" GROUP BY 存书查询.类别\" & _
\" PIVOT Format([进书日期],'yyyy/mm')\"
'修改交叉表查询的SQL语句
Set qdf = CurrentDb.QueryDefs(\"存书查询_交叉表\") qdf.SQL = strSQL qdf.Close
Set qdf = Nothing
'显示交叉表的内容，不能直接刷新 Me.存书查询子窗体.SourceObject = \"\"
Me.存书查询子窗体.SourceObject = \"查询.存书查询_交叉表\"
'刷新计数和合计显示
Me.计数 = DCount(\"*\存书查询_交叉表\") Me.合计 = DSum(\"[单价]\存书查询\")
Exit_cmd清除_Click: Exit Sub
Err_cmd清除_Click:
MsgBox Err.Description Resume Exit_cmd清除_Click End Sub
Private Sub cmd预览报表_Click() On Error GoTo Err_cmd预览报表_Click
Dim stDocName, strWhere As String
stDocName = \"藏书情况报表\"
DoCmd.OpenReport stDocName, acViewPreview
Exit_cmd预览报表_Click: Exit Sub
Err_cmd预览报表_Click: MsgBox Err.Description
Resume Exit_cmd预览报表_Click End Sub
Private Sub Form_Open(Cancel As Integer)
'如果没有这一段代码，窗体打开时，虽然子窗体有显示，但下面的两个文本框是空的。 '刷新计数和合计显示
Me.计数 = DCount(\"*\存书查询_交叉表\") Me.合计 = DSum(\"[单价]\存书查询\")
End Sub
*在报表的打开事件中写：
Private Sub Report_Open(Cancel As Integer) 'ALEX 2003-5-27
'根据交叉表查询的实际字段数来设定报表各节可以显示的控件数。 '需要使用DAO 3.6
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Dim rst As DAO.Recordset, intFieldsNum As Integer, I As Integer
'打开查询
Set rst = CurrentDb.OpenRecordset(\"SELECT * FROM [存书查询_交叉表] WHERE 1=2\")
rst.MoveLast rst.MoveFirst
Debug.Print rst.RecordCount
'记录字段总数
intFieldsNum = rst.Fields.Count
'由于报表仅有10个可变字段＋1个固定字段，所以，如果字段总数>11时， '只显示前面的11个字段，并给出提示。 If intFieldsNum > 11 Then intFieldsNum = 11
MsgBox \"字段总数太多，报表仅显示前11个字段。\提示\" End If
For I = 1 To 10
If I <= (intFieldsNum - 1) Then
'有对应字段，rst.Fields(I) 中 rst.Fields(0)是第一个，是“类别”字段。
'页眉标签可见
Section(acPageHeader).Controls(\"标签\" & I).Caption = rst.Fields(I).Name Section(acPageHeader).Controls(\"标签\" & I).Visible = True
'主体字段可见
Section(acDetail).Controls(\"txt\" & I).ControlSource = rst.Fields(I).Name Section(acDetail).Controls(\"txt\" & I).Visible = True
'报表页脚合计可见
Section(acFooter).Controls(\"txt合计\" & I).ControlSource = \"=SUM(NZ([\" rst.Fields(I).Name & \"],0))\"
Section(acFooter).Controls(\"txt合计\" & I).Visible = True Else
'没有对应字段
'页眉标签不可见
Section(acPageHeader).Controls(\"标签\" & I).Visible = False
'主体字段不可见
Section(acDetail).Controls(\"txt\" & I).ControlSource = \"\" Section(acDetail).Controls(\"txt\" & I).Visible = False
'报表页脚合计可见
Section(acFooter).Controls(\"txt合计\" & I).ControlSource = \"\" Section(acFooter).Controls(\"txt合计\" & I).Visible = False End If Next
rst.Close
Set rst = Nothing End Sub
进行多条件查询, 希望某一条件为空时显示全部
where name1 like *temp1* and name2 like *temp2*
如何判断奇数（单数）、偶数（双数）？ dim a as string
(这里有一段给a赋值的代码）
& if a mod 2=0 then
msgbox\"这是一个偶数\" esle
msgbox\"这是一个奇数\" end if
使用 Val 函数返回字符串中所含的数值。 Dim MyValue
MyValue = Val(\"2457\") ' 返回 2457。 MyValue = Val(\" 2 45 7\") ' 返回 2457。 MyValue = Val(\"24 and 57\") ' 返回 24。
计算在每个范围内的数量
本示例假设您有一个“Orders”表，且里头含有一个“Freight”字段。程序建立一个“选择”来计算运费落在某些范围内的订单数量。Partition 函数是用来确定这些范围，然后调用 SQL Count 函数来计算在每个范围内的订单数量。本示例中，Partition 函数的参数值为 start = 0，stop = 500，interval = 50。第一个范围会是 0：49，每隔 50 一个范围，依次而下直到运费为 500 为止。 SELECT DISTINCTROW Partition([freight],0, 500, 50) AS Range, Count(Orders.Freight) AS Count FROM Orders
GROUP BY Partition([freight],0,500,50);
使用 Trim 函数显示字段的值，并且删除首尾的空格。
使用 Trim 函数显示“地址”字段的值，并且删除首尾的空格。 =Trim([地址]) Like函数示例：
查询条件为“Like \"*\" & [forms]![销售单输入]![文本26]”，当我输入60时，所有包含60的记录全部得出，诸如160、260、360等
只想要60的记录，并且当不输入任何数据时，所有记录全部得出
Like IIf([forms]![销售单输入]![文本26] Is Not Null,[forms]![销售单输入]![文本26],\"*\") 使用 Left 函数来得到某字符串最左边的几个字符。 Dim AnyString, MyStr
AnyString = \"Hello World\" ' 定义字符串。 MyStr = Left(AnyString, 1) ' 返回 \"H\"。
MyStr = Left(AnyString, 7) ' 返回 \"Hello W\"。
MyStr = Left(AnyString, 20) ' 返回 \"Hello World\"。
使用 Mid 语句来得到某个字符串中的几个字符。 Dim MyString, FirstWord, LastWord, MidWords
MyString = \"Mid Function Demo\" 建立一个字符串。 FirstWord = Mid(MyString, 1, 3) ' 返回 \"Mid\"。 LastWord = Mid(MyString, 14, 4) ' 返回 \"Demo\"。 MidWords = Mid(MyString, 5) ' 返回 \"Funcion Demo\"。
使用 Right 函数来返回某字符串右边算起的几个字符。 Dim AnyString, MyStr
AnyString = \"Hello World\" ' 定义字符串。 MyStr = Right(AnyString, 1) ' 返回 \"d\"。
MyStr = Right(AnyString, 6) ' 返回 \" World\"。
MyStr = Right(AnyString, 20) ' 返回 \"Hello World\"。
使用 InStr 函数来查找某字符串在另一个字符串中首次出现的位置。 Dim SearchString, SearchChar, MyPos
SearchString =\"XXpXXpXXPXXP\" ' 被搜索的字符串。 SearchChar = \"P\" ' 要查找字符串 \"P\"。
' 从第四个字符开始，以文本比较的方式找起。返回值为 6（小写 p）。 ' 小写 p 和大写 P 在文本比较下是一样的。
MyPos = Instr(4, SearchString, SearchChar, 1)
' 从第一个字符开使，以二进制比较的方式找起。返回值为 9（大写 P）。 ' 小写 p 和大写 P 在二进制比较下是不一样的。 MyPos = Instr(1, SearchString, SearchChar, 0)
' 缺省的比对方式为二进制比较（最后一个参数可省略）。 MyPos = Instr(SearchString, SearchChar) ' 返回 9。
MyPos = Instr(1, SearchString, \"W\") ' 返回 0。 字符串A在B中出现的次数 模块：
Function CountStr(somestr, target) Dim a, count As Integer
a = InStr(1, somestr, target) Do While a > 0
count = count + 1
a = InStr(a + 1, somestr, target) Loop
CountStr = count End Function
运行：MsgBox CountStr(\"ASAASDWA\ MsgBox CountStr(\"ASAASDWA\
使用 Space 函数来生成一个字符串，字符串的内容为空格，长度为指定的长度。 Dim MyString
' 返回 10 个空格的字符串。 MyString = Space(10)
' 将 10 个空格插入两个字符串中间。
MyString = \"Hello\" & Space(10) & \"World\"
使用 String 函数来生成一指定长度，且只含单一字符的字符串。 Dim MyString
MyString = String(5, \"*\") ' 返回 \"*****\"。 MyString = String(5, 42) ' 返回 \"*****\"。
MyString = String(10, \"ABC\") ' 返回 \"AAAAAAAAAA\"。 使用 DLookup 函数
=DLookup(\"[联系人姓名]\供应商]\供应商ID] =\"[供应商ID])
一、变量为数字
If IsNull(DLookup(\"[纺号]\\"另一个表的名字\\"[纺号] = \" & 文本框的值)) Then Msgbox \"该纺号不存在!\" End If
二、变量为字符串
If IsNull(DLookup(\"[纺号]\\"另一个表的名字\\"[纺号] = '\" & 文本框的值 &\"'\")) Then Msgbox \"该纺号不存在!\" End If
使用 Len 函数来得知某字符串的长度（字符数）或某变量的大小（位数）。
Type...End Type 程序区块定义一个自定义数据类型 CustomerRecord。如果该数据类型定义在对象类模块中，则必需以关键字 Private 开头（表示为私有）。若定义在常规模块中，Type 定义就可以为 Public。 Type CustomerRecord ' 定义用户自定义的数据类型。
ID As Integer ' 将此定义放在常规模块中。 Name As String * 10 Address As String * 30 End Type
Dim Customer As CustomerRecord ' 声明变量。 Dim MyInt As Integer, MyCur As Currency Dim MyString, MyLen
MyString = \"Hello World\" ' 设置变量初值。 MyLen = Len(MyInt) ' 返回 2。 MyLen = Len(Customer) ' 返回 42。 MyLen = Len(MyString) ' 返回 11。 MyLen = Len(MyCur) ' 返回 8。
Round四舍五入。
Round(数值表达式，小数点右边应保留的位数)
用按钮在窗体中按指定字段查找记录 例一：
Private Sub 查找记录_Click()
On Error GoTo Err_查找记录_Click ''指定字段名称[学生编号]
DoCmd.GoToControl \"学生编号\"
DoCmd.DoMenuItem acFormBar, acEditMenu, 10, , acMenuVer70
Exit_查找记录_Click: Exit Sub
Err_查找记录_Click:
MsgBox Err.Description
Resume Exit_查找记录_Click End Sub 例二
Private Sub 按毕业时间查找_Click() On Error GoTo 按毕业时间查找_Click_Err ''在窗体中按基础表的参数筛选
DoCmd.ApplyFilter \"\学生基本情况]![学生编号],4)+6=[请输入学生毕业年份(四位数)]\"
按毕业时间查找_Click_Exit: Exit Sub
按毕业时间查找_Click_Err: MsgBox Error$
Resume 按毕业时间查找_Click_Exit
End Sub
使用 Eval 函数可以计算一个结果为文本字符串或数值的表达式的值。
可以构造一个字符串，然后就像是一个真正的表达式一样把字符串传给 Eval 函数，。Eval 函数将计算字符串表达式并返回计算结果值。例如， Eval(\"1 + 1\") 返回 2。 如果传给 Eval 函数的字符串包含一个函数的名称，Eval 函数会返回该函数的返回值。例如，Eval(\"Chr$(65)\") 返回 \"A\"。
如果把函数名传给 Eval 函数，则必须在 stringexpr 参数中的函数名后加上括号。例如： ' ShowNames is user-defined function. Debug.Print Eval(\"ShowNames()\")
Debug.Print Eval(\"StrComp(\"\"Joe\"\Debug.Print Eval(\"Date()\")
可以在窗体或报表上的计算控件中，或者宏或模块中使用 Eval 函数。Eval 函数将返回一个字符串或数值类型的 Variant。
stringexpr 参数必须是一个以字符串形式存储的表达式。如果传给 Eval 函数的字符串不包括数值表达式或函数名称而仅仅是一个简单的文本字符串，则会出现运行时错误。例如， Eval(\"Smith\") 将产生错误。 使用 Eval 函数可决定存储在控件中的 Value 的属性值。下面的示例传给 Eval 函数一个包含对控件的完整引用的字符串，然后在对话框中显示该控件的当前值。 Dim ctl As Control Dim strCtl As String
Set ctl = Forms!Employees!LastName strCtl = \"Forms!Employees!LastName\"
MsgBox (\"The current value of \" & ctl.Name & \" is \" & Eval(strCtl))
使用 Eval 函数可以访问在 Visual Basic 中通常不能使用的表达式运算符。例如，不能在代码中直接使用 SQL 运算符 Between...And 或 In，但是在传给 Eval 函数的表达式中可以使用它们。
下面的示例中，假设有 50 个定义为 A1、 A2 这样的一系列函数，然后使用 Eval 函数依次调用每个函数。
Dim intI As Integer For intI = 1 To 50
Eval(\"A\" & intI & \"()\") Next intI
下面的示例将触发一个 Click 事件，就像用户单击窗体上的一个按钮一样。如果按钮的 OnClick 属性值以等号（=）打头表明它是函数名，Eval 函数就会调用该函数，这与触发 Click 事件的效果相同。如果属性值不以等号打头，那么它必须指定一个宏的名称。DoCmd 对象的 RunMacro 方法运行该宏。 Dim ctl As Control Dim varTemp As Variant
Set ctl = Forms!Contacts!HelpButton If (Left(ctl.OnClick, 1) = \"=\") Then
varTemp = Eval(Mid(ctl.OnClick,2)) Else
DoCmd.RunMacro ctl.OnClick End If
ＳＱＬ 语法参考手册
DB2 提供了关连式资料库的查询语言 ＳＱＬ (Structured Query Language)， 是一种非常口语化、既易学又易懂的语法。此一语言几乎是每个资料库系统都 必须提供的，用以表示关连式的操作，包含了资料的定义（ＤＤＬ）以及资料 的处理（ＤＭＬ）。SQL原来拼成 SEQUEL，这语言的原型以“系统 R“的名 字在 IBM 圣荷西实验室完成，经过 IBM 内部及其他的许多使用性及效率测试， 其结果相当令人满意，并决定在系统R 的技术基础发展出来 IBM 的产品。而 且美国国家标准学会（ANSI）及国际标准化组织（ISO 在 1987 遵循一个几乎 是以 IBM SQL 为基础的标准关连式资料语言定义。
基本查询
SELECT column1,columns2,... FROM table_name 说明：把table_name 的特定栏位资料全部列出来 SELECT *
FROM table_name
WHERE column1 = xxx
[AND column2 > yyy] [OR column3 <> zzz] 说明：
1.'*'表示全部的栏位都列出来
2.WHERE 之後是接条件式，把符合条件的资料列出来 SELECT column1,column2 FROM table_name
ORDER BY column2 [DESC] 说明：
ORDER BY 是指定以某个栏位做排序，[DESC]是指从大到小排列，若 没有指明，则是从小到大排列
组合查询
组合查询是指所查询得资料来源并不只有单一的表格，而是联合一个以上的表格才能够得到结果的。 SELECT *
FROM table1,table2
WHERE table1.colum1=table2.column1 说明：
1.查询两个表格中其中 column1 值相同的资料
2.当然两个表格相互比较的栏位，其资料形态必须相同 3.一个复杂的查询其动用到的表格可能会很多个
整合性的查询： SELECT COUNT (*) FROM table_name
WHERE column_name = xxx 说明：
查询符合条件的资料共有几笔
SELECT SUM(column1) FROM table_name 说明：
1.计算出总和，所选的栏位必须是可数的数字形态 2.除此以外还有 AVG() 是计算平均、MAX()、MIN() 计算最大最小值的整合性查询
SELECT column1,AVG(column2) FROM table_name GROUP BY column1
HAVING AVG(column2) > xxx 说明：
1.GROUP BY: 以column1 为一组计算 column2 的平均值 必须和 AVG、SUM 等整合性查询的关键字一起使用
2.HAVING : 必须和 GROUP BY 一起使用作为整合性的
复合性的查询 SELECT *
FROM table_name1 WHERE EXISTS ( SELECT *
FROM table_name2 WHERE conditions ) 说明：
1.WHERE 的 conditions 可以是另外一个的 query 2.EXISTS 在此是指存在与否
SELECT *
FROM table_name1 WHERE column1 IN ( SELECT column1 FROM table_name2 WHERE conditions ) 说明
1. IN 後面接的是一个集合，表示column1 存在集合里面 2. SELECT 出来的资料形态必须符合 column1
联合查询示例 1联合查询排序：
SELECT [公司名称], [城市] FROM [供应商]
UNION SELECT [公司名称], [城市] FROM [客户]
ORDER BY [城市];
2联合查询重命名字段：
SELECT [公司名称] AS [供应商/客户名], [城市] FROM [供应商]
UNION SELECT [公司名称] AS [供应商/客户名], [城市] FROM [客户];
3用 UNION ALL 语句来检索包含重复记录在内的所有记录。 SELECT [公司名称], [城市] FROM [供应商]
UNION ALL SELECT [公司名称], [城市] FROM [客户];
其他查询 SELECT *
FROM table_name1
WHERE column1 LIKE 'x%' 说明：
LIKE 必须和後面的'x%' 相呼应表示以 x为开头的字串
SELECT *
FROM table_name1
WHERE column1 IN ('xxx','yyy',..) 说明
IN 後面接的是一个集合，表示column1 存在集合里面
SELECT *
FROM table_name1
WHERE column1 BETWEEN xx AND yy 说明
BETWEEN 表示 column1 的值介於 xx 和 yy 之间
更改资料：
UPDATE table_name SET column1='xxx' WHERE conditoins 说明：
1.更改某个栏位设定其值为'xxx'
2.conditions 是所要符合的条件、若没有 WHERE 则 整个 table 的那个栏位都会全部被更改
删除资料：
DELETE FROM table_name WHERE conditions
说明：删除符合条件的资料
报表
如果您想判断一个数据库中的报表是否打开，您需要检查报表连接，如下函数可以做到。 如果返回true,则报表是打开，false则报表没有打开。 Sub fCheckReport(strReport As String) As Boolean Dim rpt As Report fCheckReport=False
For Each rpt In Reports
If rpt.Name=strReportName Then fCheckReport=True Next rpt End Function
打印当前窗体上的记录的报表
DoCmd.OpenReport \"rptName\acViewNormal, , \"[UniqueFieldOnReport]=Forms![frmName]![UniqueFieldOnReport]\"
全部范围内,从第二张打到第五张,高品质打印,印三份
DoCmd.PrintOut acPrintAll, 2, 5, acHigh, 3, False
生成间隔背景颜色的报表
要求:生成间隔背景颜色的报表，奇数行的背景颜色为兰色,偶数行的背景颜色为白色,兰白相间,方便查看. 方法:根据行号进行判定,设定背景色.
1 设计报表INVOICE ,必须有行号字段NO(由1开始连续的系列号) 2 设计宏SETINVOICECOLOR,条件及操作如下
条件 ([Reports]![INVOICE]![NO]) Mod 2=1 操作 Setvalue
项目 [Reports]![INVOICE].[Section](0).[BackColor] 表达式1632256
条件 ([Reports]![INVOICE]![NO]) Mod 2=0 操作 Setvalue
项目 [Reports]![INVOICE].[Section](0).[BackColor] 表达式16777215
3 设计报表INVOICE ,选定节Detail的属性中,事件\"打印\"为宏 SETINVOICECOLOR. 4 打印报表INVOICE,生成间隔背景颜色的报表.
报表奇偶页不同颜色显示 Option Compare Database Option Explicit Dim i As Integer
Private Sub 主体_Format(Cancel As Integer, FormatCount As Integer) i = i + 1
If i Mod 2 = 0 Then
Me.主体.BackColor = 12632256 Else
Me.主体.BackColor = 16777215 End If End Sub
如何在报表中产生递增的顺序编号
在报表的细节上放一个文本框，控件源等于=1 并设\"运行总和\"属性设置为“工作组之上”即可。
给输出的报表加个边框
Private Sub Report_Page()
Line (0, 0)-(ScaleWidth, ScaleHeight), , B End Sub 报表页小计
在报表的主体节复制、粘贴一个要统计的数据的文本框TEXT1，属性的数据----运行总和为“全部之上”，可见性可设为“否”；
在页脚建一未绑定文本框TEXT2，用来显示页合计数据值；
在报表的页脚的打印事件中写： Dim x As Single
Me.TEXT2 = TEXT1 - x x = TEXT1
实际上是每个记录的工资累计。每页结束后把这个值赋给X，下页再合计后减去X就是本页合计，以此类推。
每页固定打印7行，数据不足时用空行补齐。
最好还是用Line语句。在报表的“打印页前”事件中输入下面内容。
Private Sub Report_Page()
Dim rpt As Report, lngColor As Long Dim i As Integer
Set rpt = Reports!当前报表 rpt.ScaleMode = 7
lngColor = RGB(255, 0, 0)
rpt.Line (2.503, 2.5)-(4.735, 6.588), lngColor, B rpt.Line (7.354, 2.5)-(9.074, 6.588), lngColor, B rpt.Line (10.317, 2.5)-(12.037, 6.588), lngColor, B rpt.Line (13.81, 2.5)-(15.952, 6.588), lngColor, B rpt.Line (19.123, 2.5)-(19.123, 6.588), lngColor For i = 1 To 7
rpt.Line (0.4, 2.5 + (i - 1) * 0.584)-(19.123, 2.5 + i * 0.584), lngColor, B Next i End Sub
应用筛选打印报表以及取消后 Sub 打印发货单_Click()
' 这段代码由“命令按钮向导”创建。 On Error GoTo Err_PrintInvoice_Click
Dim strDocName As String
strDocName = \"发货单\"
' 打印“发货单”报表，使用“发货单筛选”查询打印当前订单的发货单。
DoCmd.OpenReport strDocName, acViewNormal, \"发货单筛选\"
Exit_PrintInvoice_Click: Exit Sub
Err_PrintInvoice_Click:
' 如果用户取消操作，不显示错误消息。 Const conErrDoCmdCancelled = 2501 If (Err = conErrDoCmdCancelled) Then Resume Exit_PrintInvoice_Click Else
MsgBox Err.Description
Resume Exit_PrintInvoice_Click End If
End Sub
报表打印如何用代码设定页面 Dim qdf As QueryDef
Dim ctlLabel As Control, ctlText As Control Dim intDataX As Integer, intDataY As Integer Dim intLabelX As Integer, intLabelY As Integer Dim ncnt As Integer Dim i As Integer
Dim ttlwidth As Double Dim rptWaste As Report Me.Painting = False On Error Resume Next
Dim Dbs As Database, ctr As Container, doc As Document Set Dbs = CurrentDb ncnt = 0
Set rptWaste = CreateReport
Dbs.QueryDefs.Delete \"www\"
Set qdf = Dbs.CreateQueryDef(\"www\sql) Dbs.QueryDefs.refresh ttlwidth = 30
rptWaste.Section(acPageHeader).Height = 800 For i = 1 To 30 - 1
If Not (IsNull(adata(i)) Or Trim(adata(i)) = \"\") Then
Set ctlText = CreateReportControl(rptWaste.name, acTextBox, , \"\\"\intDataX, intDataY)
Set ctlLabel = CreateReportControl(rptWaste.name, acLabel, acPageHeader, , \"NewLabel\intLabelX, intLabelY)
ctlLabel.Caption = adata(i)
ctlText.Width = 1000
If adata(i) = \"card_no\" Then ctlText.Width = 1200
ctlLabel.Caption = \"卡号\" End If
If adata(i) = \"date\" Then
ctlText.Width = 1300
ctlLabel.Caption = \"日期\" End If
If adata(i) = \"op_name\" Then ctlText.Width = 1300
ctlLabel.Caption = \"工序号\" End If
If adata(i) = \"class_name\" Then ctlText.Width = 1300
ctlLabel.Caption = \"产品类型\" End If
If adata(i) = \"dept_code\" Then ctlText.Width = 1000
ctlLabel.Caption = \"车间代码\" End If
If adata(i) = \"totalwaste_qty\" Then ctlText.Width = 1000
ctlLabel.Caption = \"废品总重\" End If ' End If
ctlLabel.Width = ctlText.Width ctlText.ControlSource = adata(i) ctlText.BorderStyle = 1 ctlLabel.BorderStyle = 1 ctlText.Left = ttlwidth ctlLabel.Left = ttlwidth
ctlLabel.Top = 800 - ctlLabel.Height ctlLabel.FontBold = True
ttlwidth = ttlwidth + ctlText.Width End If Next i
rptWaste.RecordSource = \"www\"
rptWaste.Section(acDetail).Height = ctlText.Height
Set ctlLabel = CreateReportControl(rptWaste.name, acLabel, acPageHeader, l\intLabelX, intLabelY)
ctlLabel.Top = 0
ctlLabel.Caption = Trim(txtDepartment.value) & \"废品统计报表\" ctlLabel.TextAlign = 2 ctlLabel.FontSize = 16 ctlLabel.FontBold = True ctlLabel.Width = 4000 ctlLabel.Height = 500
ctlLabel.Left = (rptWaste.Width - ctlLabel.Width) / 2
Const DM_PORTRAIT = 1 Const DM_LANDSCAPE = 2
Dim DevString As str_DEVMODE Dim DM As type_DEVMODE
Dim strDevModeExtra As String
If Not IsNull(rptWaste.PrtDevMode) Then
strDevModeExtra = rptWaste.PrtDevMode
, \"NewLabe DevString.RGB = strDevModeExtra LSet DM = DevString
DM.lngFields = DM.lngFields Or DM.intOrientation ' Initialize fields.
'If DM.intOrientation = DM_PORTRAIT Then DM.intOrientation = DM_LANDSCAPE 'Else
' DM.intOrientation = DM_PORTRAIT 'End If
LSet DevString = DM ' Update property.
Mid(strDevModeExtra, 1, 94) = DevString.RGB rptWaste.PrtDevMode = strDevModeExtra End If
DoCmd.DeleteObject acReport, \"rptwaste_tmp\" DoCmd.Save , \"rptwaste_tmp\"
DoCmd.Close acReport, \"rptwaste_tmp\acSaveNo ' For i = 0 To FORMs.Count - 1 ' FORMs(i).Visible = False ' Next
DoCmd.OpenReport \"rptwaste_tmp\acViewPreview
Me.Painting = True
报表中使用自定义纸张,及设置自定义纸张大小 正 文：
Private Type str_DEVMODE RGB As String * 94 End Type
Private Type type_DEVMODE
strDeviceName As String * 32 intSpecVersion As Integer intDriverVersion As Integer intSize As Integer
intDriverExtra As Integer lngFields As Long
intOrientation As Integer intPaperSize As Integer intPaperLength As Integer intPaperWidth As Integer intScale As Integer intCopies As Integer
intDefaultSource As Integer intPrintQuality As Integer intColor As Integer intDuplex As Integer intResolution As Integer intTTOption As Integer intCollate As Integer
strFormName As String * 32 lngPad As Long lngBits As Long lngPW As Long lngPH As Long lngDFI As Long lngDFr As Long End Type
' rptName: 为报表名称
Public Sub CheckCustomPage(ByVal rptName As String)
Dim DevString As str_DEVMODE Dim DM As type_DEVMODE
Dim strDevModeExtra As String Dim rpt As Report
Dim intResponse As Integer
' 在设计视图下打开报表
DoCmd.OpenReport rptName, acDesign Set rpt = Reports(rptName)
If Not IsNull(rpt.PrtDevMode) Then strDevModeExtra = rpt.PrtDevMode
' 获取当前的 DEVMODE 结构
DevString.RGB = strDevModeExtra LSet DM = DevString
If DM.intPaperSize = 256 Then
' 显示用户自定义纸张的尺寸
intResponse = MsgBox(\"当前的自定义纸张为(mm)：\" & _ DM.intPaperWidth / 10 & \" 宽 X \" & _
DM.intPaperLength / 10 & \" 长。 你想改变吗？\ vbYesNo + vbQuestion) Else
' 非自定义纸张
intResponse = MsgBox(\"报表没有使用自定义纸张。 \" & _
\"你想使用自定义纸张吗?\ End If
If intResponse = vbYes Then
' 用户要改变纸张设置，初始化 DM 的各个域
DM.lngFields = DM.lngFields Or DM.intPaperSize Or _ DM.intPaperLength Or DM.intPaperWidth
' 设置为自定义纸张 DM.intPaperSize = 256
' 提示输入长度和宽度
DM.intPaperLength = InputBox(\"请输入纸张的长度(mm)：\") * 10 DM.intPaperWidth = InputBox(\"请输入纸张的宽度(mm)：\") * 10
' 更新属性值
LSet DevString = DM
Mid(strDevModeExtra, 1, 94) = DevString.RGB rpt.PrtDevMode = strDevModeExtra End If End If
Set rpt = Nothing End Sub
Vba技巧:
自动注册控件函数
Function AutoReg As String) Dim reged As Boolean Dim RegFile1 As String Dim RegFile2 As String Dim BeReg As String Dim RetVal
BeReg = CurrentProject.Path & \"\\\" &
RegFile1 = Environ(\"windir\") & \"\\system\\regsvr32.exe \" RegFile2 = Environ(\"windir\") & \"\\system32\\regsvr32.exe \" If Dir(RegFile1) <> \"\" Or Dir(RegFile2) <> \"\" Then If Dir(RegFile1) <> \"\" Then
RegFile1 = RegFile1 & \"/s\" & \" \" & BeReg RetVal = Shell(RegFile1, 1) Else
RegFile2 = RegFile2 & \"/s\" & \" \" & BeReg RetVal = Shell(RegFile2, 1) End If Else
MsgBox \"找不到regsvr32.exe文件，你可能无法使用本软件！\vbCritical, \"无法自动注册控件\" End If
End Function 使用方法：
把控件跟mdb文件放在同一个目录里,然后在程序中使用以下语句注册 AutoRegFile \"控件名称\"
用VBA代码创建一个新的目录文件夹
来源：ACCESS中国 ADAM Dim fs, f Set fs = CreateObject(\"Scripting.\")
Set f = fs.createfolder(CurrentProject.Path & \"\\hlp\est\")
现有100元钱,要买100只鸡,已知,公鸡5元一只,母鸡3元一只,小鸡3只1元.要求:用编程方法得:公鸡,母鸡,小鸡的数目和所花的钱.求得后还得把答案存入数据库中,并在窗体中显示答案. Private Sub Command0_Click() Dim a1 As Integer Dim a2 As Integer Dim a3 As Integer Dim stattime As Date
Dim rst As DAO.Recordset stattime = Now()
Set rst = CurrentDb.OpenRecordset(\"test\‘a1<20,a2<33
For a1 = 1 To 19
For a2 = 1 to int((100-a1*5)/3) a3 = 100 - a1 - a2
If a1 * 5 + a2 * 3 + a3 / 3 * 1 = 100 Then rst.AddNew
rst.Fields(\"a1\") = a1 rst.Fields(\"a2\") = a2 rst.Fields(\"a3\") = a3 rst.Update End If Next Next
MsgBox \"stattime:\" + CStr(stattime) + vbCrLf + \"now:\" + CStr(Now()) + vbCrLf + \"sub:\" + CStr(DateDiff(\"s\DoCmd.OpenTable \"test\" End Sub
显示窗体“第n条记录 共m条记录”的函数 调用方法：
=RecordNumber(\"第\指当前窗体
可在文框的控件来源中写：=RecordNumber(\"第\当前窗体名) 在代码的窗体成为当前事件中写：me.文本框=RecordNumber(\"第\结果虽相同，但在代码中的要快！
但是，在代码的窗体成为当前事件中写：Me.标签.Caption = RecordNumber(\"第\用标签，速度明显要比前两个用法还要快！
Function RecordNumber(pstrPreFix As String, pfrm As Form) As String On Error GoTo RecordNumber_Err Dim rst
Dim lngNumRecords As Long Dim lngCurrentRecord As Long Dim strTmp As String
Set rst = pfrm.RecordsetClone rst.MoveLast
rst.Bookmark = pfrm.Bookmark lngNumRecords = rst.RecordCount
lngCurrentRecord = rst.AbsolutePosition + 1
strTmp = pstrPreFix & \" \" & lngCurrentRecord & \" 页，\" & \" 共 \" & lngNumRecords & \" \" & \"页\" RecordNumber_Exit: On Error Resume Next RecordNumber = strTmp rst.Close
Set rst = Nothing Exit Function RecordNumber_Err: Select Case Err Case 3021
strTmp = \"New Record\" Resume RecordNumber_Exit Case Else
strTmp = \"#\" & Error Resume RecordNumber_Exit End Select
End Function
获取ACCESS错误号与对应的中文解释 Sub MMM()
For e = 1 To 100
Debug.Print e; \" - \"; Error(e) Next
End Sub
执行上述代码将显示如下结果：
1 - 应用程序定义或对象定义错误 2 - 应用程序定义或对象定义错误 3 - 无 GoSub 返回
4 - 应用程序定义或对象定义错误 5 - 无效的过程调用或参数 6 - 溢出 7 - 内存溢出 对话框返回文本框内容
InputBox(prompt[, title] [, default] [, xpos] [, ypos] [, helpfile, context]) InputBox 函数的语法具有以下几个命名参数：
Prompt：必需的。作为对话框消息出现的字符串表达式。prompt 的最大长度大约是 1024 个字符，由所用字符的宽度决定。如果 prompt 包含多个行，则可在各行之间用回车符 (Chr(13))、换行符 (Chr(10)) 或回车换行符的组合 (Chr(13) & Chr(10)) 来分隔。
Title：可选的。显示对话框标题栏中的字符串表达式。如果省略 title，则把应用程序名放入标题栏中。 Default：可选的。显示文本框中的字符串表达式，在没有其它输入时作为缺省值。如果省略 default，则文本框为空。
Xpos：可选的。数值表达式，成对出现，指定对话框的左边与屏幕左边的水平距离。如果省略 xpos，则对话框会在水平方向居中。
Ypos：可选的。数值表达式，成对出现，指定对话框的上边与屏幕上边的距离。如果省略 ypos，则对话框被放置在屏幕垂直方向距下边大约三分之一的位置。
Helpfile：可选的。字符串表达式，识别帮助文件，用该文件为对话框提供上下文相关的帮助。如果已提供 helpfile，则也必须提供 context。
Context: 可选的。数值表达式，由帮助文件的作者指定给某个帮助主题的帮助上下文编号。如果已提供 context，则也必须要提供 helpfile。
示例：
本示例说明使用 InputBox 函数来显示用户输入数据的不同用法。如果省略 x 及 y 坐标值，则会自动将对话框放置在两个坐标的正中。如果用户单击“确定”按钮或按下“ENTER”按键，则变量 MyValue 保存用户输入的数据。如果用户单击“取消”按钮，则返回一零长度字符串。 Dim Message, Title, Default, MyValue
Message = \"Enter a value between 1 and 3\" ' 设置提示信息。 Title = \"InputBox Demo\" ' 设置标题。 Default = \"1\" ' 设置缺省值。 ' 显示信息、标题及缺省值。
MyValue = InputBox(Message, Title, Default)
' 使用帮助文件及上下文。“帮助”按钮便会自动出现。
MyValue = InputBox(Message, Title, , , , \"DEMO.HLP\
' 在 100, 100 的位置显示对话框。
MyValue = InputBox(Message, Title, Default, 100, 100)
在桌面上创建快捷方式 '本例作者：黄海
'须引用Activex Data Objects 2.1
Option Compare Database Option Explicit
Private Sub Command0_Click()
Call createShortCut(CurrentProject.FullName, \"桌面上显示的名称\") End Sub
Public Function createShortCut(ByVal strFullName As String, ByVal strShortCutName As String) As Boolean
If Len(Dir(DesktopPath() & \"\\\" & strShortCutName & \".lnk\")) > 0 Then '如果已经存在同文件先删除
Kill DesktopPath() & \"\\\" & strShortCutName & \".lnk\" End If
Open DesktopPath() & \"\emp.lnk\" For Output As #1 '在桌面上建立临时快捷方式文件
Close #1
Shell \"Rundll32.exe AppWiz.Cpl,NewLinkHere \" & DesktopPath() & \"\emp.lnk\" '打开系统的建立快捷方式对话框
SendKeys strFullName '输入要目录文件全名，这里是当前文件全名 SendKeys \"{enter}\" '回车
SendKeys strShortCutName '输入快捷方式名称 SendKeys \"{enter}\" '回车结束
End Function
Public Function DesktopPath() As String '取得桌面路径 Dim wshshell As Object Dim strDesktop
Set wshshell = CreateObject(\"wscript.shell\") strDesktop = wshshell.regread(\"HKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders\\desktop\")
DesktopPath = strDesktop End Function
根据屏幕分辨率自动调整窗体大小： Option Compare Database
Private Declare Function GetSystemMetrics Lib \"user32\" (ByVal nIndex As Long) As Long Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1
Private Sub Form_Open(Cancel As Integer)
Dim x As Long, y As Long, a As Long, b As Long x = GetSystemMetrics(SM_CXSCREEN) y = GetSystemMetrics(SM_CYSCREEN) a = 10000 / 800 * x b = 7000 / 600 * y
DoCmd.MoveSize 1134, 1134, a, b End Sub
获得系统的屏幕区域大小
Private Declare Function GetSystemMetrics Lib \"user32\" (ByVal nIndex As Long) As Long Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Sub Command0_Click() Dim x As Long, y As Long
x = GetSystemMetrics(SM_CXSCREEN) y = GetSystemMetrics(SM_CYSCREEN) MsgBox x & \" \" & y End Sub
让控件自适应屏幕分辨率2 来源：ACCESS爱好者
'这个函数可以使你开发的程序适应各种分辨率，这是我见过的最完美的解决方案！强列推荐 ''如果你是在1024*768的分辨率下写的程序，就把下面那句改为 Const DesignSize = 1024，如果是800*600分 '辨率下写的，就改为Const DesignSize = 800
'用法：把下面所有的代码放在一个模块里，在需要适应分辨率的窗体的Load事 '件里加入Call FormResiz_OnOpen(Me) '
'Const DesignSize = 1024 Const DesignSize = 800
'☆★☆★☆★☆★☆★☆★☆★☆★☆★ 'API宣言
Declare Function GetDesktopWindow Lib \"User32\" () As Long
Declare Function GetWindowRect Lib \"User32\" (ByVal hWnd As Long, rectangle As Long 'Type宣言 Type RECT x1 As Long y1 As Long x2 As Long y2 As Long End Type '国标码宣言
Dim frm As Form Dim ctrl As Control Dim prp As Property Dim rat As Double Dim flgSec
Dim X As Long
Dim WinHeight As Long Dim hWnd As Long Dim ret As Long Dim i As Integer Dim R As RECT Dim SizeL As Long Dim SizeT As Long Dim SizeW As Long Dim SizeH As Long
'--------------------------------------------------------------------------------
Public Function FormResiz_OnOpen(parFrm As Form, Optional perSizeL As Long, erSizeT As Long, Optional perSizeW As Long, Optional perSizeH As Long) On Error Resume Next
As RECT) Optional pSet frm = parFrm '窗口驾驶盘的取得
hWnd = GetDesktopWindow() '现在分辨率取得
ret = GetWindowRect(hWnd, R)
'比例计算 常例：现在800 开发1024 800/1024 = 0.78加倍 X = (R.x2 - R.x1) rat = X / DesignSize
SizeL = 0: SizeT = 0: SizeW = 0: SizeH = 0 If Not IsEmpty(perSizeL) = True Then SizeL = perSizeL * rat SizeT = perSizeT * rat SizeW = perSizeW * rat SizeH = perSizeH * rat End If
'现在分辨率＝开发分辨率如果终了
If X = DesignSize Then Exit Function If X < DesignSize Then
'细小策划时、控制＞部分＞表单的次序 Call ChangeCtrl Call ChengeSec Call ChangeFrm Else
'大掬取时、表单＞部分＞控制的次序 Call ChangeFrm Call ChengeSec Call ChangeCtrl End If
'最后、表单的使清新 frm.Refresh Exit Function End Function
'-------------------------------------------------------------------------------- Private Sub ChangeCtrl() On Error Resume Next '控制转
For Each ctrl In frm.Controls
'*******************************************************************
'选项卡修正，原著没有这段代码，后来有个朋友发现了这个BUG，就是选项卡的位置会偏得很厉害 '所以就加了这段代码来修正
'主要是\"Top\\"Height\这几个参数的值，根据实际情况适当调整就行了 If ctrl.ControlType = 123 Or ctrl.ControlType = 124 Then For Each prp In ctrl.Properties Select Case prp.Name
Case \"FontSize\\"DatasheetFontHeight\" prp.value = Fix(prp.value * rat + 0.5) Case \"FontWeight\"
prp.value = Fix((prp.value * rat) / 100) * 100 Case \"Top\\"Height\"
prp.value = Fix(prp.value * rat * 0.85) 'prp.value = Fix(prp.value * rat) Case \"Left\"
prp.value = Fix(prp.value * rat * 0.9) Case \"Width\"
prp.value = Fix(prp.value * rat * 0.7) End Select Next prp
'******************************************************************************************** Else '属性转
For Each prp In ctrl.Properties '大小·配置关于属性被发现们压缩 Select Case prp.Name
Case \"FontSize\\"DatasheetFontHeight\"
'通常计算假如行…情况之下的 +0.5 之类的话不需要是…但…、 '捆Zo~Ma办法。稍微心情坏因为 +0.5
prp.value = Fix(prp.value * rat + 0.5) Case \"FontWeight\"
prp.value = Fix((prp.value * rat) / 100) * 100 Case \"Left\\"Top\\"Width\\"Height\" prp.value = Fix(prp.value * rat) End Select Next prp End If Next ctrl End Sub
'-------------------------------------------------------------------------------- Private Sub ChengeSec() On Error GoTo Err_Disp '部分转
flgSec = True i = 0
'不存在部分的参照错误化验出终了 Do Until flgSec = False '部分被发现们高度变更
frm.Section(i).Height = Fix(frm.Section(i).Height * rat) i = i + 1 Loop
Exit Sub Err_Disp:
If Err = 2462 Then flgSec = False Resume Next Else
MsgBox Err.Description End If
Resume Next End Sub
'-------------------------------------------------------------------------------- Private Sub ChangeFrm() On Error Resume Next '表单的大小变更
'Optional参数数值渡下次收拾ば、而且使合（计算正在完毕） If SizeL > 0 Then
DoCmd.MoveSize SizeL, SizeT, SizeW, SizeH Else
'特别是指定啊假如踢、变更了表单的大小表示 '表单的属性（宽与高度）
frm.Width = Fix(frm.Width * rat)
WinHeight = Fix(frm.WindowHeight * rat) DoCmd.MoveSize , , frm.Width, WinHeight End If End Sub
用VBA赋应用程序图标 见测试窗体
Toolbar 控件使用
本例在一个Toolbar控件中添加五个 Button 对象，并且向每个 Button 对象添加二个 ButtonMenu 对象。单击ButtonMenu对象时，其行为由ButtonMenuClick事件来决定。为了试验本例，在窗体中放置一个 Toolbar 控件，将代码粘贴到代码模块的声明部分。 Option Explicit
Private Sub Toolbar1_ButtonMenuClick(ByVal ButtonMenu As ComctlLib.ButtonMenu) Select Case ButtonMenu.Index Case 1
MsgBox \"Press the button.\" Case 2
MsgBox \"Offer some option\" End Select End Sub
' 窗体加载事件：
Private Sub Form_Load() Dim i As Integer Dim btn As Button
' 添加五个 Button 对象到 Toolbar 控件。 For i = 1 To 5
Set btn = Toolbar1.Buttons.Add(Caption:= i, Style:= tbrDropDown) ' 添加两个 ButtonMenu 对象到每一个Button。 btn.ButtonMenus.Add Text:=\"Help\" btn.ButtonMenus.Add Text:=\"Options\" Next i End Sub
Treeview 控件的使用方法
建立一个窗体，在窗体上放置如下控件： Treeview 控件：名称 Treeview1；
Imagelist 控件：名称 Imagelist1，并在该控件中放置三张个性图片（32×32），建立索引1、2、3；（方法：在Imagelist 控件上单击鼠标右键选择属性）
Label 控件：名称分别为Lab（0）、Lab（1），Caption分别为“父节点：”、“子节点：”； Textbox 控件：名称分别为Txt（0）、Txt（1），text都为“”；
commandbutton 控件：名称为系统默认，Caption分别为“添加”、“展开”、“收起”、“排序”、“删除”、“退出”；
将下列代码加入到代码框： Option Explicit Dim I As Integer Dim J As Integer Dim nodx As Node
Dim CunZai As Boolean '定义变量
Private Sub Command1_Click()
If Txt(0).Text <> \"\" And Txt(1).Text <> \"\" Then '不允许建立零字节的父节点和子节点 CunZai = False
J = TreeView1.Nodes.Count
For I = 1 To TreeView1.Nodes.Count '检查新输入的父节点名称是否存在 If TreeView1.SelectedItem.Children > 0 Then
If Txt(0).Text = TreeView1.Nodes(I).Text Then CunZai = True End If Next I
If CunZai = True Then '若存在, 则在父节点下建立子节点
Set nodx = TreeView1.Nodes.Add(Txt(0).Text, tvwChild, \"child\" & J, Txt(1).Text, 3) Else ,若不存在,则建立父节点和子节点
Set nodx = TreeView1.Nodes.Add(, , Txt(0).Text, Txt(0).Text, 1) Set nodx = TreeView1.Nodes.Add(Txt(0).Text, tvwChild, \"child\" & J,_ Txt(1).Text, 3) End If
TreeView1.Refresh
ElseIf Txt(0).Text = \"\" Then MsgBox \"请输入父节点名称!\vbInformation, \"警告！\" '系统提示
ElseIf Txt(1).Text = \"\" Then MsgBox \"请输入子节点名称!\vbInformation, \"警告！\" End If End Sub
Private Sub Command2_Click()
For I = 1 To TreeView1.Nodes.Count
TreeView1.Nodes(I).Expanded = True '展开所有节点 Next I End Sub
Private Sub Command3_Click()
For I = 1 To TreeView1.Nodes.Count
TreeView1.Nodes(I).Expanded = False '收起所有节点 Next I End Sub
Private Sub Command4_Click()
TreeView1.Sorted = True '排列顺序 End Sub
Private Sub Command5_Click()
If TreeView1.SelectedItem.Index <> 1 Then
TreeView1.Nodes.Remove TreeView1.SelectedItem.Index '删除选定的节点 End If End Sub
Private Sub Command6_Click() End '退出程序 End Sub
Private Sub Form_Load()
TreeView1.LineStyle =TvwTreeLines '在兄弟节点和父节点之间显示线 TreeView1.ImageList = ImageList1 '链接图像列
TreeView1.Style = tvwTreelinesPlusMinusPictureText '树状外观包含全部元素
Set nodx = TreeView1.Nodes.Add(, , \"蒲子明\\"蒲子明\1) '建立名称为\"蒲子明\"的父节点,选择索引为1的图像
Set nodx = TreeView1.Nodes.Add(\"蒲子明vwChild, \"child01\\"收件箱\3) '在\"蒲子明\"父节点下建立\"收件箱\"子节点,选择索引为3的图像
Set nodx = TreeView1.Nodes.Add(\"蒲子明vwChild, \"child02\\"发件箱\3) '在\"蒲子明\"父节点下建立\"发件箱\"子节点,选择索引为3的图像
CunZai = False End Sub
Private Sub TreeView1_Expand(ByVal Node As MSComctlLib.Node) Node.ExpandedImage = 2 '节点被展开时,选择索引为2的图像 End Sub
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
If TreeView1.SelectedItem.Children = 0 Then '检查是否有子节点,0为无 For I = 1 To TreeView1.Nodes.Count If TreeView1.Nodes(I).Selected Then
MsgBox \"您选择的是：“\" & TreeView1.Nodes(I).FullPath & \"”子节点！\" '系统提示 End If Next I End If End Sub
TreeView控件示例：
Private Sub Form_Load()
Dim cnn As New ADODB.Connection, rst As New ADODB.Recordset Dim nods As Nodes Dim mnode As Node Dim nodef As String Dim hh As String
Set cnn = CurrentProject.Connection
rst.Open \"select * from menu order by 菜单号\rst.MoveFirst
Do While Not rst.EOF nodef = rst!菜单号
If IsNull(rst!上级菜单) Then
Set mnode = TreeView0.Nodes.Add(, , rst!菜单号, rst!菜单名, 1, 2) Else
nodef = rst!上级菜单
Set mnode = TreeView0.Nodes.Add(nodef, tvwChild, rst!菜单号, rst!菜单名, 3, 4) End If
rst.MoveNext Loop
Set rst = Nothing With TreeView0
.Nodes(1).Expanded = True End With End Sub
Private Sub TreeView0_NodeClick(ByVal Node As Object) Dim varx As Variant
varx = DLookup(\"[记录]\菜单名]=\" & \"'\" & Node & \"'\")
Me.记录 = varx
End Sub
如何删除所选节点下的所有节点 private sub deletechildren() dim i as integer
if treeview1.selecteditem.children <> 0 then
for i=1 to treeview1.selecteditem.children
treeview1.nodes.remove(treeview1.child.firstsibling.key) next i end if end sub
删除某个节点下的子节点就是：
private sub deletechildren(byval node as object) dim i as integer
if node.children <> 0 then
for i=1 to node.children
treeview1.nodes.remove(node.child.firstsibling.key) next i end if end sub
如果盘中不存在文件test.dll，则退出数据库 if dir(\"c:\\windows\est.dll\")=\"\" then docmd.quit end if
使用 Shell 函数来完成一个用户指定的应用程序。
使用 Shell 函数来完成一个用户指定的应用程序。在 MacIntosh 上，默认的驱动名为 “HD” ，路径名称的每部分由冒号而非反斜线分隔。相似地，您可以指定 Macintosh 文件夹而非 \\Windows. ' 将第二个参数值设成 1，可让该程序以正常大小的窗口完成，并且拥有焦点。 Dim RetVal
RetVal = Shell(\"C:\\WINDOWS\\CALC.EXE\完成Calculator。
Shell(\"C:\\WINDOWS\\hh.exe c:\\a.chm\hh.exe 是打开chm的程序文件。 chm是帮助文件 对外部文件管理
Set fs = CreateObject(\"Scripting.\") '设置系统计算机的驱动器、文件夹和文件记录集 fs.CopyFile \"c:\\12345.txt\拷贝文件 或： c:\\a.mdb,d:\\b.mdb
fs.DeleteFile \"c:\\12345.txt\" '删除刚拷贝的文本文件
将c盘的1.doc文件更名为1.bat： Name \"c:\\1.doc\" As \"c:\\1.bat\"
打开外部数据库
Private Sub Command5_Click() Dim aobject As String '定义对象变量
Set aobject = openobject(\"e:\\学生规范考查.mdb\'打开名为学生规范考查.mdb的库 End Sub
提示用户插入软盘
如果驱动器中没有软盘则会出现错误，
程序应提供没有软盘的信息： Sub InsertDisk() On Error Resume Next
If IsError(My(“a:”,vbVolume))=True Then MsgBox “驱动器中没有软盘，请插入软盘！” Exit Sub End If End Sub
怎么知道用户的电脑里有没有文件
例如，做一个access程序，需要引用ado2.5
但是用户的电脑里没有这个dll文件，只有ado2.3。 怎么能让程序指导这个情况，做出适当的提示或操作。
If Dir(\"C:\\Program Files\\....\\msado25.dll\") = \"\" Then MsgBox \"ado2.5文件不存在\" , vbExclamation, \"提示\" end if
向表中加新字段
CurrentDb.Execute \"Alter Table 表名 Add Column 新字段名 Char(13)\"
自定义函数 IsYlwjcct(\"窗体名\") （如果指定的窗体打开，返回True） Function IsYlwjcct(ByVal strFormName As String) As Boolean Const conObjStateClosed = 0 Const conDesignView = 0
If SysCmd(acSysCmdGetObjectState,acForm,strFormName) <>conObjStateClosed Then If Forms(strFormName).CurrentView<>conDesignView Then IsYlwjcct=True End If End If End Function
删除当前数据库的表的字段
CurrentDb.Execute \"Alter Table 名表 Drop Column字段名\" 使主程序窗口的X失效
Private Declare Function GetSystemMenu Lib \"User32\" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib \"User32\" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Sub FORM_Load()
Const MF_BYCOMMAND = &H0& Const SC_CLOSE = &HF060
Dim hMenu As Long
hMenu = GetSystemMenu(Application.hWndAccessApp, 0)
Call DeleteMenu(hMenu, SC_CLOSE, MF_BYCOMMAND) End Sub 打开模块
DoCmd.OpenModule \"设置启用禁用shift\
隐藏当前活动窗体 me.Form.Visible=True 隐藏主窗口
Global Const SW_HIDE = 0
Global Const SW_SHOWNORMAL = 1 Global Const SW_SHOWMINIMIZED = 2 Global Const SW_SHOWMAXIMIZED = 3
' 使用举例
' 最大化 Access 窗口
' ?fSetAccessWindow(SW_SHOWMAXIMIZED) ' 最小化 Access 窗口
' ?fSetAccessWindow(SW_SHOWMINIMIZED) ' 隐藏 Access 窗口
' ?fSetAccessWindow(SW_HIDE) ' 正常显示 Access 窗口
' ?fSetAccessWindow(SW_SHOWNORMAL) '
Option Compare Database
Private Declare Function apiShowWindow Lib \"user32\" Alias \"ShowWindow\" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Function fSetAccessWindow(nCmdShow As Long)
Dim loX As Long Dim loForm As Form
On Error Resume Next
loX = apiShowWindow(hWndAccessApp, nCmdShow) Err.Clear
fSetAccessWindow = (loX <> 0) End Function
Private Sub Form_Load() Dim yhsfm As String yhsfm = CurrentUser()
If yhsfm <> \"ylw\" Then Dim X
X = fSetAccessWindow(0) End If End sub
在一个窗体中执行另一窗体的子程序 来源：爱赛思应用俱乐部 huanghai DoCmd.OpenForm \"窗体2\"
Call Forms(\"窗体2\").aaa 禁用主窗口最大化和最小化按钮 '声明
Private Declare Function GetSystemMenu Lib \"user32.dll\" _ (ByVal hwnd As Long, ByVal bRevert As Long) As Long Private Declare Function RemoveMenu Lib \"user32.dll\" _
(ByVal hMenu As Long, ByVal uPosition As Long, ByVal uFlags As Long) As Long
'使用
Private Sub Form_Load() Dim hSysMenu As Long Dim retval As Long
hSysMenu = GetSystemMenu(hWndAccessApp, 0) retval = RemoveMenu(hSysMenu, &HF120, &H0) hSysMenu = GetSystemMenu(Me.hwnd, 0)
retval = RemoveMenu(hSysMenu, &HF120, &H0) End Sub
让主窗口最大化和最小化按钮消失 '声明：
Private Declare Function SetWindowLong Lib \"user32\" _ Alias \"SetWindowLongA\" (ByVal hwnd As Long, ByVal _ nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib \"user32\" _ Alias \"GetWindowLongA\" (ByVal hwnd As Long, ByVal _ nIndex As Long) As Long
Const WS_MINIMIZEBOX = &H20000 Const WS_MAXIMIZEBOX = &H10000 Const GWL_STYLE = (-16)
'使用：
Private Sub Form_Load() Dim lWnd As Long
lWnd = GetWindowLong(hWndAccessApp, GWL_STYLE) lWnd = lWnd And Not (WS_MINIMIZEBOX) lWnd = lWnd And Not (WS_MAXIMIZEBOX)
lWnd = SetWindowLong(hWndAccessApp, GWL_STYLE, lWnd) End Sub 计时器触发
Me.Text4.Value = Now() 隐藏当前激活的工具条：
Dim dqgjt As Variant
Set dqgjt = CommandBars.ActiveMenuBar dqgjt.Enabled = False
显示和隐藏自定义的工具条
DoCmd.ShowToolbar \"你的工具条名称\
DoCmd.ShowToolbar \"你的工具条名称\
隐藏主程序窗口：(详见示例库) Option Compare Database Option Explicit
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Declare Function apiShowWindow Lib \"user32\" _
Alias \"ShowWindow\" (ByVal hWnd As Long, _
ByVal nCmdShow As Long) As Long
Private Sub Command0_Click()
If Me.Command0.Caption = \"隐藏窗体\" Then Me.Command0.Caption = \"显示窗体\"
Call apiShowWindow(hWndAccessApp, SW_HIDE) DoCmd.Restore Else
Me.Command0.Caption = \"隐藏窗体\"
Call apiShowWindow(hWndAccessApp, SW_SHOWNORMAL)
DoCmd.Close acForm, \"frm_main\"
DoCmd.ShowToolbar \"菜单栏\ DoCmd.Restore End If End Sub
主窗口最小化：
DoCmd.RunCommand acCmdAppMinimize
用代码打开窗体中选项卡控件的某页 Me.选项卡控件名.Pages(n).SetFocus
其中n是要打开的页号（页号是从0开始的） 对不同视图中对象的标题进行设置
使用 Caption 属性可以对不同视图中对象的标题进行设置，为用户提供有用的信息：
字段标题用于指定通过从字段列表中拖动字段而创建的控件所附标签上的文本，并作为表或查询“数据表”视图中字段的列标题。
窗体标题用于指定在“窗体”视图中标题栏上显示的文本。 报表标题用于指定在“打印预览”中报表的标题。 按钮和标签标题用于指定在控件中显示的文本。 String 型，可读写。
expression.Caption
expression 必需。返回“Applies To”列表中的一个对象的表达式。 怎样使用一个查询获得数据库对象的名称(查询/窗体/表/报表/模块/宏)? 查询:
SELECT MSysObjects.Name FROM MsysObjects WHERE (Left$([Name],1)<>\"~\") AND (MSysObjects.Type)=5 ORDER BY MSysObjects.Name;
窗体:
SELECT MSysObjects.Name FROM MsysObjects WHERE (Left$([Name],1)<>\"~\") AND (MSysObjects.Type)=-32768 ORDER BY MSysObjects.Name; 表:
SELECT MSysObjects.Name FROM MsysObjects WHERE (Left$([Name],1)<>\"~\") AND (Left$([Name],4) <> \"Msys\") AND (MSysObjects.Type)=1 ORDER BY MSysObjects.Name;
报表:
SELECT MSysObjects.Name FROM MsysObjects WHERE (Left$([Name],1)<>\"~\") AND (MSysObjects.Type)= -327 ORDER BY MSysObjects.Name;
模块:
SELECT MSysObjects.Name FROM MsysObjects WHERE (Left$([Name],1)<>\"~\") AND (MSysObjects.Type)= -32761 ORDER BY MSysObjects.Name; 宏:
SELECT MSysObjects.Name FROM MsysObjects WHERE (Left$([Name],1)<>\"~\") AND (MSysObjects.Type)= -32766 ORDER BY MSysObjects.Name;
文件被创建或最后修改后的日期和时间 函数
返回一个 Variant (Date)，此为一个文件被创建或最后修改后的日期和时间。 语法
(pathname)
必要的 pathname 参数是用来指定一个文件名的字符串表达式。pathname 可以包含目录或文件夹、以及驱动器。
●适用于VB、VBA。
●用法：传回值 = (\"c:\\windows\\文件名.com\")
让ACCESS程序发出声音的函数
Declare Function apisndPlaySound Lib \"winmm\" Alias \"sndPlaySoundA\" _ (ByVal As String, ByVal snd_async As Long) As Long
Function PlaySound(sWav String) ' Purpose: Plays a sound.
' Argument: the full path and .
If apisndPlaySound(sWavFile, 1) = 0 Then MsgBox \"The Sound Did Not Play!\" End If
End Function
调用方法：PlaySound \"文件名.WAV\"
检测表中有无记录
tblAAAA,其中有一字段MMM
if isnull(dlookup(\"[MMM]\msgbox \"此表无记录\" end if
使用表达式使一个文本框自动分为几段,并按文本格式首行左空2字! 加上chr()码，chr(32)是空格，10 和 13 分别为换行和回车字符。 如：= strXX1 & Chr(13) & Chr(10) & strXX2 身份证号输入的检查（焦点移到下一控件时） Private Sub 下一控件名称_GotFocus()
If Len(Me.文本框) <> 15 And Len(Me.文本框) <> 18 Then MsgBox \"1111\"
Me.文本框.SetFocus End If End Sub
几个常用的身份证相关函数
Public Function SfzToXb(身份证号 As String) As String Dim i As Integer
If Len(身份证号) = 15 And IsNumeric(Right(身份证号, 1)) Then i = CInt(Right(身份证号, 1))
If i Mod 2 = 0 Then SfzToXb = \"女\" Else SfzToXb = \"男\" End If
If Len(身份证号) = 18 And IsNumeric(mID(身份证号, 17, 1)) Then i = CInt(mID(身份证号, 17, 1))
If i Mod 2 = 0 Then SfzToXb = \"女\" Else SfzToXb = \"男\" End If
End Function
Public Function SfzToRq(身份证号 As String) As Date Dim strRq As String
If Len(身份证号) = 15 Then
strRq = mID(身份证号, 9, 2) & \"/\" & mID(身份证号, 11, 2) & \"/\" & \"19\" & mID(身份证号, 7, 2) If IsDate(strRq) Then SfzToRq = CDate(strRq) End If
If Len(身份证号) = 18 Then
strRq = mID(身份证号, 11, 2) & \"/\" & mID(身份证号, 13, 2) & \"/\" & mID(身份证号, 7, 4)
If IsDate(strRq) Then SfzToRq = CDate(strRq) End If
End Function
'长身份证到短身份证
Public Function LSfzToS(Sfz As String) As String LSfzToS = Left(Sfz, 6) & mID(Sfz, 9, 9) End Function
如何使鼠标停留在组合框上时，使组合框自动打开 Private Sub 文本框_GotFocus() Me![文本框].Dropdown End Sub
组合框里面有20行数据，现在需要双击组合框，组合框内数据会依次显示 Private Sub Combo0_DblClick(Cancel As Integer) If Combo0.ListCount < 1 Then Exit Sub
Dim I As Long
I = Combo0.ListCount
If Combo0.ListIndex < I - 1 Then
Combo0.ListIndex = Combo0.ListIndex + 1 Else
Combo0.ListIndex = 0 End If End Sub
在VB中改变控件的类型
Private Sub cmdPerformMorph_Click()
DoCmd.Echo False, \"Morphing controls, please wait...\" DoCmd.SelectObject acForm, \"ControlMorphExampleForm2\" DoCmd.DoMenuItem acFormBar, 2, 0 If Forms!ControlMorphExampleForm2!cboEmployeeToQuery.ControlType = acListBox Forms!ControlMorphExampleForm2!cboEmployeeToQuery.ControlType = acComboBox
Else Forms!ControlMorphExampleForm2!cboEmployeeToQuery.ControlType = acListBox End If
If Forms!ControlMorphExampleForm2!optMorphing.ControlType = acOptionButton Then Forms!ControlMorphExampleForm2!optMorphing.ControlType = acCheckBox Else
Forms!ControlMorphExampleForm2!optMorphing.ControlType = acOptionButton End If
DoCmd.DoMenuItem acFormBar, 2, 1
DoCmd.SelectObject acForm, \"ControlMorphExampleForm1\" DoCmd.Echo True End Sub
Then 如何加入换行符
C=\"A\" + vbNewLine + \"B\"
[联系电话] = \"1111\" + Chr(13) + Chr(10) + \"2222\" 给一绑定文本框赋值，可以成功的看到换行效果： 1111 2222
在多页窗体中用按钮翻页 上一页
Private Sub 上一页_Click() DoCmd.GoToPage 1 End Sub
下一页
Private Sub 下一页_Click() DoCmd.GoToPage 2 End Sub
关闭指定窗体并按参数打开报表或窗体 Private Sub 打印各班名册_Click() On Error GoTo 打印各班名册_Click_Err
DoCmd.Close acForm, \"学籍管理库\"
''指定报表或窗体名称，并指定基础表的字段的参数
DoCmd.OpenReport \"同江市第三小学在校生名册\在籍学生基本情况表]![年班]=[请输入年班（如：一年二班）]\" 打印各班名册_Click_Exit: Exit Sub
打印各班名册_Click_Err: MsgBox Error$
Resume 打印各班名册_Click_Exit
End Sub
在窗体中按基础表的参数筛选 Private Sub 按班筛选_Click() On Error GoTo 按班筛选_Click_Err ''在窗体中按基础表的参数筛选
DoCmd.ApplyFilter \"\在籍学生基本情况表]![年班]=[请输入年级和班级（如：一年二班）]\" 按班筛选_Click_Exit: Exit Sub
按班筛选_Click_Err: MsgBox Error$
Resume 按班筛选_Click_Exit End Sub
取消所有筛选
Private Sub 取消所有筛选_Click() DoCmd.ShowAllRecords End Sub
使用 For...Next 语句
可以使用 For...Next 语句去重复一个语句块，而它的次数的数字是指定的。For 循环使用一个计数变量，当重复每个循环时它的值会增加或减少。
下面的过程会让计算机发出哔声 50 次。For 语句会指定计数变量 x 的开始与结束值。Next 语句会将计数变量的值加 1。
Sub Beeps()
For x = 1 To 50 Beep Next x End Sub
使用 Step 关键字，可以由所指定的值增加或减少计数变量。在下面的示例中，计数变量 j 会在每次循环重复时加上 2。当循环完成时，total 的值为 2、4、6、8 和 10 的总合。 Sub TwosTotal()
For j = 2 To 10 Step 2 total = total + j Next j
MsgBox \"The total is \" & total End Sub
为了减少计数变量的值，可以使用负的 Step 值。为了减少计数变量的值，必须指定一个小于开始值的结束值。在下面的示例中，计数变量 myNum 会在每次循环重复时减去 2。当循环完成时，total 的值为 16、14、12、10、8、6、4 和 2 的总合。 Sub NewTotal()
For myNum = 16 To 2 Step -2 total = total + myNum Next myNum
MsgBox \"The total is \" & total End Sub
注意 在 Next 语句后面不必包含计数变量的名称。上述的示例中，因为要具有可读性才加上计数变量的名称。 可以在计数变量到达它的结束值之前，使用 Exit For 语句来退出 For...Next 语句。例如，当错误发生时，可以使用在 If...Then...Else 语句或是 Select Case 语句的 True 语句块中的 Exit For 语句，它是专门用来检查此错误的。如果没有错误发生，则 If...Then...Else 语句的值为 False，循环会象预期那样的运行。
如何用sql取得服務器的系統時間 用getdate()可以得到系统的当前时间 例子：
public function getsqlsvrtime() as datetime dim rst as adodb.recordset
set rst = new adodb.recordset
set rst.activeconnection = currentproject.connection rst.open \"select getdate() as svrtime\"
getsqlsvrtime = rst.fields(\"svrtime\") end function
函数 getsqlsvrtime 返回 sql server 服务器上的当前日期和时间。 如果取时间：
dim stime as string
stime = format(getsqlsvrtime(), \"short time\") ' 短时间 如果取日期：
dim sdate as string
sdate = format(getsqlsvrtime(), \"long date\") ' 长日期
利用IIF函数根据学号（如：19975012）显示年班
注意 学号的编排要根据入学年份和班号及个人号，如：19975012表示“1997年入学，5班，012号”。下面的查询示例中的学号为8位数，学号“”在系统时间为2002年8月份与2003年7月份之间会显示出“6年5班”；在系统时间为2003年8月份之后会显示出“2003年毕业于5班”
=IIf(Month(Date())>7,IIf(Year(Date())-Left([学号],4)>5,Left([学号],4)+6 & \"年\" & \"毕业\" & \"于\" & Mid([学号],5,1) & \"班\学号],4)+1 & \"年\" & Mid([学号],5,1) & \"班\"),IIf(Year(Date())-Left([学号],4)>6,Left([学号],4)+6 & \"年\" & \"毕业\" & \"于\" & Mid([学号],5,1) & \"班\学号],4) & \"年\" & Mid([学号],5,1) & \"班\")) 利用Choose函数在查询中生成[年班]字段
年班: IIf(Month(Date())>7,Choose(Year(Date())-Left([学生名册]![学号],4)+1,\"一年\二年\三年\四年\五年\六年\"),Choose(Year(Date())-Left([学生名册]![学号],4),\"一年\二年\三年\四年\五年\六年\")) & Choose(Mid([学生名册]![学号],5,1),\"一班\二班\三班\四班\五班\") 利用IIF函数在查询中生成[年班]字段 字段表达式为：
年班: IIf(Month(Date())>7,IIf(Year(Date())-Left([学生基本情况]![学生编号],4)>5,\"\学生基本情况]![学生编号],4)+1 & \"年\" & Mid([学生基本情况]![学生编号],5,1) & \"班\"),IIf(Year(Date())-Left([学生基本情况]![学生编号],4)>6,\"\学生基本情况]![学生编号],4) & \"年\" & Mid([学生基本情况]![学生编号],5,1) & \"班\")) 准则表达式为： <>\"\"
按以下步骤打包的数据库已在 PWin98OEM2 & IE5.0 & AccessRuntime2002 的环境中成功运行。
真正能够让使用 Access 编写的数据库运行的就是 Microsoft Office Access（专门有此版本的 Access） 。现在大家一直需要的 Office 开发版其实不只包括 Access 的打包软件，而大家目前用到、谈到的就像是 Office 开发版 = Office 打包软件似的，这是错误的观点。
下面详细叙述一下关于在使用 Access 打包软件时必须注意的问题：
首先：Access 打包软件并不能将您自己编写的 Access 数据库(*.mdb或者*.mde)转换成单独可以运行的一个可执行文件(*.exe)。
其次：Access 开发版中的打包软件只是其中的一个组件而已。 再次：Access 开发版的打包软件的打包过程如下：
1、它会根据你的要求生成3种不同大小的 Access Runtime版本 ① 只包括AccessRuntime
② 包括 AccessRuntime 和 Windows 安装服务程序以及其他数据库访问组件还有IE4.1 ③ 包括上述所有内容再加上IE5.1
2、压缩并打包你的数据库(*.mdb,*.mde...)以及你的数据库运行所需的文件，也就是Access中没有的文件，比如你自己用的背景、附件等等。
最后：所以你如果真的需要将你自己的数据库打包发布，完全没有必要使用难以得到的 Access 开发版，你只需要得到 Access的运行时版本和将你自己的mdb文件压缩打包就可以了。也就是说，AccessRuntime 本身在 Office的安装光盘里面就有，而压缩打包的软件也是到处都有，比如我就推荐 WinRAR3.0。
所以，我得出的结论是：如果你想得到 Access 的开发版，而其用途只是为了使用其中的打包工具，那么你根本没有必要去苦苦寻觅，在你身边的软件就已经能够完成上述的工作了。
有关 Access Runtime 软件的具体位置：Access Runtime 2002 的安装文件在 OfficeXP 光盘的如下位置：光盘盘符:\\FILES\\MOD\\ACCESSRT.MSI
在新的机器上安装 Access Runtime 2002 后仍然无法正常打开编写好的数据库，这主要是因为他们还没有安装数据库访问组件，该组件共 19 个文件 25.5MB。安装时会提示缺少 IE5 。我想也不用我提示了吧？直接用 IE5 代替即可，就是建立如下目录：
比如：OSP.MSI 在 c:\\AccessRuntime2002\\OSP.MSI 的位置，就请你自行将 IE5 的所有文件拷贝至 c:\\AccessRuntime2002\\IE5\\SC 下面就可以正常安装了。 硬盘id号SerialNumber 属性 一：
Dim fs, d, v
Set fs = CreateObject(\"Scripting.\")
Set d = fs.GetDrive(fs.GetDriveName(fs.GetAbsolutePathName(\"c:\\\"))) v = Hex(d.SerialNumber)
msgbox \"c 硬盘序列号(16制): \" & v 二：
Sub ShowDriveInfo(drvpath) Dim fs, d, s, t
Set fs = CreateObject(\"Scripting.\")
Set d = fs.GetDrive(fs.GetDriveName(fs.GetAbsolutePathName(drvpath))) Select Case d.DriveType Case 0: t = \"Unknown\" Case 1: t = \"Removable\" Case 2: t = \"Fixed\" Case 3: t = \"Network\" Case 4: t = \"CD-ROM\" Case 5: t = \"RAM Disk\" End Select
s = \"Drive \" & d.DriveLetter & \": - \" & t s = s & vbCrLf & \"SN: \" & d.SerialNumber MsgBox s End Sub
自定义获取CPU_ID函数 98下不成功
Public Function wmiProcessorID() Dim CPUID As String Dim CPUSet Dim CPU
Set CPUSet = GetObject(\"winmgmts:{impersonationLevel=impersonate}\"). _ InstancesOf(\"Win32_Processor\") For Each CPU In CPUSet
CPUID = CPUID & CPU.ProcessorId Next
wmiProcessorID = CPUID End Function
硬盘序列号 98不成功
一：将HDSerialNumRead.dll拷到系统盘的windows下，再建立如下模块：
Private Declare Function HDSerialNumRead Lib \"HDSerialNumRead.dll\" () As String
Public Function GetHDSerialNum() As String Dim S As String
S = Trim(HDSerialNumRead())
GetHDSerialNum = Left(S, Len(S) - 1) End Function
二：在窗体的事件上写代码： Me.文本框 = GetHDSerialNum()
在Access中获取本机IP地址、电脑名及开机登录用户名 来源：tehthspace.accxp.com
Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \\ &H100 And &HFF& Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF& Private Const MIN_SOCKETS_REQD = 1 Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256 Private Const WSASYS_Status_Len = 128
Private Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLength As Integer hAddrList As Long End Type
Private Type WSADATA wversion As Integer wHighVersion As Integer
szDescription(0 To WSADescription_Len) As Byte szSystemStatus(0 To WSASYS_Status_Len) As Byte iMaxSockets As Integer iMaxUdpDg As Integer lpszVendorInfo As Long End Type
Declare Function wu_GetUserName Lib \"advapi32.dll\" Alias \"GetUserNameA\" (ByVal lpBuffer As String, nSize As Long) As Long
Declare Function wu_GetComputerName Lib \"kernel32.dll\" Alias \"GetComputerNameA\" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function WSAGetLastError Lib \"WSOCK32.DLL\" () As Long Private Declare Function WSAStartup Lib \"WSOCK32.DLL\" (ByVal wVersionRequired&, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib \"WSOCK32.DLL\" () As Long
Private Declare Function gethostbyname Lib \"WSOCK32.DLL\" (ByVal hostname$) As Long
Private Declare Sub RtlMoveMemory Lib \"kernel32\" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)
Function ap_GetComputerName() As Variant Dim strComputerName As String Dim lngLength As Long Dim lngResult As Long
strComputerName = String(255, 0) lngLength = 255
lngResult = wu_GetComputerName(strComputerName, lngLength)
ap_GetComputerName = Left(strComputerName, InStr(1, strComputerName, Chr(0)) - 1)
End Function
Function ap_GetUserName() As Variant Dim strUserName As String Dim lngLength As Long Dim lngResult As Long
strUserName = String(255, 0) lngLength = 255
lngResult = wu_GetUserName(strUserName, lngLength)
ap_GetUserName = Left(strUserName, InStr(1, strUserName, Chr(0)) - 1)
End Function
Function GetComputerIP() As String Dim hostent_addr As Long Dim host As HOSTENT Dim hostip_addr As Long
Dim temp_ip_address() As Byte Dim I As Integer
Dim vntTemp As Variant
SocketsInitialize
hostent_addr = gethostbyname(vntTemp)
If hostent_addr = 0 Then MsgBox \"Can't resolve name.\" Exit Function End If
RtlMoveMemory host, hostent_addr, LenB(host) RtlMoveMemory hostip_addr, host.hAddrList, 4
ReDim temp_ip_address(1 To host.hLength)
RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
For I = 1 To host.hLength
GetComputerIP = GetComputerIP & temp_ip_address(I) & \".\" Next
GetComputerIP = Mid$(GetComputerIP, 1, Len(GetComputerIP) - 1)
SocketsCleanup End Function
Function hibyte(ByVal wParam As Integer) hibyte = wParam \\ &H100 And &HFF& End Function
Function lobyte(ByVal wParam As Integer) lobyte = wParam And &HFF& End Function
Sub SocketsInitialize()
Dim WSAD As WSADATA Dim iReturn As Integer
Dim sLowByte As String, sHighByte As String, sMsg As String
iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
If iReturn <> 0 Then
MsgBox \"Winsock.dll is not responding.\" End End If
If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = WS_VERSION_MAJOR And
hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then sHighByte = Trim$(Str$(hibyte(WSAD.wversion))) sLowByte = Trim$(Str$(lobyte(WSAD.wversion)))
sMsg = \"Windows Sockets version \" & sLowByte & \".\" & sHighByte sMsg = sMsg & \" is not supported by winsock.dll \" MsgBox sMsg End End If
If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
sMsg = \"This application requires a minimum of \"
sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & \" supported sockets.\" MsgBox sMsg End End If
End Sub
Sub SocketsCleanup() Dim lReturn As Long
lReturn = WSACleanup()
If lReturn <> 0 Then
MsgBox \"Socket error \" & Trim$(Str$(lReturn)) & \" occurred in Cleanup \" End End If
End Sub
取得电脑CPU的名称及速度 98下不成功
Public Function ProcessorSpeed() As String '取得电脑CPU的名称及速度 Dim MyOBJ As Object Dim cpu As Object
Set MyOBJ = GetObject(\"WinMgmts:\").instancesof(\"Win32_Processor\") For Each cpu In MyOBJ
ProcessorSpeed = cpu.Name & \" \" & cpu.CurrentClockSpeed & \" Mhz\" Next
End Function 网卡序列号
Option Compare Database Option Explicit
Private Const NCBASTAT = &H33 Private Const NCBNAMSZ = 16
Private Const HEAP_ZERO_MEMORY = &H8
Private Const HEAP_GENERATE_EXCEPTIONS = &H4 Private Const NCBRESET = &H32
Private Type NCB
ncb_command As Byte ncb_retcode As Byte ncb_lsn As Byte
ncb_num As Byte ncb_buffer As Long ncb_length As Integer
ncb_callname As String * NCBNAMSZ ncb_name As String * NCBNAMSZ ncb_rto As Byte ncb_sto As Byte ncb_post As Long ncb_lana_num As Byte ncb_cmd_cplt As Byte
ncb_reserve(9) As Byte ' Reserved, must be 0 ncb_event As Long End Type
Private Type ADAPTER_STATUS adapter_address(5) As Byte rev_major As Byte reserved0 As Byte adapter_type As Byte rev_minor As Byte duration As Integer frmr_recv As Integer frmr_xmit As Integer
iframe_recv_err As Integer xmit_aborts As Integer xmit_success As Long recv_success As Long
iframe_xmit_err As Integer recv_buff_unavail As Integer t1_timeouts As Integer ti_timeouts As Integer Reserved1 As Long free_ncbs As Integer max_cfg_ncbs As Integer max_ncbs As Integer
xmit_buf_unavail As Integer max_dgram_size As Integer pending_sess As Integer max_cfg_sess As Integer max_sess As Integer
max_sess_pkt_size As Integer name_count As Integer End Type
Private Type NAME_BUFFER name As String * NCBNAMSZ name_num As Integer name_flags As Integer End Type
Private Type ASTAT
adapt As ADAPTER_STATUS NameBuff(30) As NAME_BUFFER End Type
Private Declare Function Netbios Lib \"netapi32.dll\" (pncb As NCB) As Byte
Private Declare Sub CopyMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib \"kernel32\" () As Long
Private Declare Function HeapAlloc Lib \"kernel32\" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib \"kernel32\" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Public Function GetEthernetAddress(LanaNumber As Long) As String Dim udtNCB As NCB Dim bytResponse As Byte Dim udtASTAT As ASTAT Dim udtTempASTAT As ASTAT Dim lngASTAT As Long Dim strOut As String Dim x As Integer
udtNCB.ncb_command = NCBRESET bytResponse = Netbios(udtNCB) udtNCB.ncb_command = NCBASTAT udtNCB.ncb_lana_num = LanaNumber udtNCB.ncb_callname = \"* \"
udtNCB.ncb_length = Len(udtASTAT)
lngASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, udtNCB.ncb_length) strOut = \"\"
If lngASTAT Then
udtNCB.ncb_buffer = lngASTAT bytResponse = Netbios(udtNCB)
CopyMemory udtASTAT, udtNCB.ncb_buffer, Len(udtASTAT)
With udtASTAT.adapt For x = 0 To 5
strOut = strOut & Right$(\"00\" & Hex$(.adapter_address(x)), 2) Next x End With
HeapFree GetProcessHeap(), 0, lngASTAT End If
GetEthernetAddress = strOut End Function
调用：
网卡序列号 = GetEthernetAddress(0)
提升前后台模式程序的速度 Dim cn As Connection
Dim rs As New ADODB.Recordset Dim sql As String
Set cn = CurrentProject.Connection sql = \"select * from 1\" rs.Open sql, cn, 3, 3, 1
你的软件最好有个主控面板，一打开软件它就打开，关闭软件它才关闭。在后台数据库文件里建一个只有一个
字段的空表，名为1（其它名也可以），然后把上面的代码放在主控面板的OPEN事件里。
这里面用到的小技巧就是：打开了一个空表，但没关闭它，这样后台数据库就一直在打开状态（你可以看到后台数据库会生成一个LDB文件），你要操作其它表的时候就不用频繁地打开、关闭后台数据库，这样程序运行起来可以提升级几倍的速度，试试看吧。
另：最好是100M的局域网。不过我在10M的网上也用得很爽，现在是5个用户同时用都没感觉到慢。
VB中如何延时？ *API函数声明：
Declare Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long) 调用：
注释：延时1秒 Call Sleep(1000)
获取windows安装路径
一：在Access中用这个函数： Environ(\"windir\")
可得出windows的安装路径 二：
Set fs = CreateObject(\"Scripting.\")
Windows安装文件夹 = fs.GetSpecialFolder(0) 系统文件夹 = fs.GetSpecialFolder(1) 系统临时文件夹 = fs.GetSpecialFolder(2) 获取指定表所有字段名的函数
Private Function GETZD(tbName As String) Dim cat As New ADOX.Catalog
cat.ActiveConnection = CurrentProject.Connection
For i = 0 To cat.Tables(tbName).Columns.Count - 1 Debug.Print cat.Tables(tbName).Columns.Item(i).Name Next End Function '需引用ADOX
'用法：GETZD (\"表名\")
如何用vba检查软驱是否有软盘 Private Sub 命令0_Click() Dim Flag As Boolean
Flag = Fun_FloppyDrive(\"A:\")
If Flag = False Then MsgBox \"A:驱没有准备好，请将磁盘插入驱动器！\vbCritical End Sub
Private Function Fun_FloppyDrive(sDrive As String) As Boolean '------------------------------- '函数:检查软驱中是否有盘的存在 '------------------------------- On Error Resume Next
Fun_FloppyDrive = Dir(sDrive) <> \"\" End Function
打开、关闭“计算器” 1．如何控制设计？
新建一表单，在表单中放入两个按钮，其Caption分别为“打开”（即启动“计算器”）和“关闭”（退出结束），且为它们分别添加Click事件处理。详见表单Form1及单元文件Unit1。 其中，最主要的几条语句有：
fwnd:=FindWindow('SciCalc','计算器'); 函数原型为（详见Delphi的帮助）:
HWND FindWindow(
LPCTSTR lpClassName, // pointer to class name LPCTSTR lpWindowName // pointer to window name );
此处，'SciCalc' 为计算器的类名，'计算器'为计算器的窗口标题}
setWindowPos(fwnd,HWND_NOTOPMOST,0,0,0,0,SWP_SHOWWINDOW or SWP_NOSIZE or SWP_NOMOVE); 函数原型为:
BOOL SetWindowPos(
HWND hWnd, // handle of window
HWND hWndInsertAfter, // placement-order handle int X, // horizontal position int Y, // vertical position int cx, // width int cy, // height
UINT uFlags // window-positioning flags );
ShowWindow(fwnd,SW_RESTORE); //显示已打开的「计算器」 函数原型为:
BOOL ShowWindow(
HWND hWnd, // handle of window
int nCmdShow // show state of window );
Ret:=WinExec('c:\\windows\\calc.exe',SW_SHOWNORMAL); //启动计算器 函数原型为: UINT WinExec(
LPCSTR lpCmdLine, // address of command line
UINT uCmdShow // window style for new application );
运行“计算器”程序并检测返回值（从而利用返回值来判断可能发生的错误）
2．如何明确应用程序的“类名”？
要控制应用程序，首先必须明确应用程序的“类名”。“类”的概念，Delphi的程序已经非常清楚，如：新建一表单Form1，该表单的“类名”为TForm1。那么其它Windows程序的“类名”如何确定呢？ 值得一喜的是，Delphi提供了一实用工具Winsight，它正如一面照妖镜，不论何方妖怪，均会显露出它们的“类名”。
使用Winsight的方法如下：
⑴运行Winsight（程序名为ws32.exe，与主文件delphi32.exe同一目录），见图①； ⑵从Winsight的菜单中选择“间谍”中的“跟随焦点”，见图②； ⑶运行“计算器”程序；
⑷在Winsight中显示出了目标，如图③所示。 软件环境：中文Win98/中文Delphi5.0。 打开（工具－选项）
一、DoCmd.DoMenuItem acFormBar, 6, 11, , acMenuVer70 二、docmd.RunCommand.accmdoption
2、使用API函数sendmessage，获得光标所在行和列。 Sub getcaretpos(byval TextHwnd&,LineNo&,ColNo&)
注释：TextHwnd为TextBox的hWnd属性值， LineNo为所在行数，ColNo为列数 dim I&,j&,k& 注释：获取起始位置到光标所在位置字节数 I=SendMessage(TextHwnd,&HB0&,0,0) j=I/2^16 注释：确定所在行 LineNo=SendMessage(TextHwnd,&HC9&,j,0)+1 注释：确定所在列
k=SendMessage(TextHwnd,&HBB&,-1,0) ColNo=j-k+1 End sub
5、如何获取Windows目录和System目录？ 注释：复制以下代码到一模块中
Public Declare Function GetWindowsDirectory Lib \"kernel32\" Alias \"GetWindowsDirectoryA\" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetSystemDirectory Lib \"kernel32\" Alias \"GetSystemDirectoryA\" (ByVal lpBuffer As String, ByVal nSize As Long) As Long 注释：在程序中调用
Dim WindowsDirectory As String, SystemDirectory As String, x As Long WindowsDirectory = Space(255) SystemDirectory = Space(255)
x = GetWindowsDirectory(WindowsDirectory, 255) x = GetSystemDirectory(SystemDirectory, 255)
MsgBox \"Windows的安装目录是:\" + WindowsDirectory+\系统目录是:\" + SystemDirectory 6、如何建立简单的超级连接？ *API函数声明
Private Declare Function ShellExecute Lib \"shell32.dll\" Alias \"ShellExecute A\" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lp String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd A s Long) As Long 注释：打开某个网址
ShellExecute 0, \"open\\";, vbNullString, vbNullString, 3 注释：给某个信箱发电子邮件
ShellExecute hwnd, \"open\页码表达式的示例
下面列出了可以在窗体或报表的“设计”视图中使用的页码表达式示例以及在其他视图中可以看到的结果。 表达式：=[Page] 结果：1, 2, 3
表达式：=\"Page \" & [Page] 结果：Page 1, Page 2, Page 3
表达式：=\"Page \" & [Page] & \" of \" & [Pages] 结果：Page 1 of 3, Page 2 of 3, Page 3 of 3 表达式：=[Page] & \" of \" & [Pages] & \" Pages\" 结果：1 of 3 Pages, 2 of 3 Pages, 3 of 3 Pages 表达式：=[Page] & \"/\"& [Pages] & \" Pages\" 结果：1/3 Pages, 2/3 Pages, 3/3 Pages 表达式：=[Country] & \" - \" & [Page] 结果：UK - 1, UK - 2, UK - 3 表达式：=Format([Page], \"000\") 结果：001, 002, 003
如何提高拆分数据库在网上运行、编辑的速度！！ Dim cn As Connection
Dim rs As New ADODB.Recordset Dim sql As String
Set cn = CurrentProject.Connection sql = \"select * from 1\" rs.Open sql, cn, 3, 3, 1
你的软件最好有个主控面板，一打开软件它就打开，关闭软件它才关闭。在后台数据库文件里建一个只有一个字段的空表，名为1（其它名也可以），然后把上面的代码放在主控面板的OPEN事件里。 图像作窗体背景，让图像大小和窗体的大小保持一致。 在FORM_load 和FORM_resize 里加上 图片.width=me.windowwidth 图片.height=me.windowheight 来源：爱赛思应用网。
让用户不能随意退出(退出前提示)！
建立一个窗体，名字叫隐藏，并在启动选项内选定这个窗体为启动时自动打开。 然后在窗体的加载事件内加入如下代码： Private Sub Form_Load() Me.Visible = False End Sub
''在窗体的卸载事件中加入如下代码：
Private Sub Form_Unload(Cancel As Integer)
If MsgBox(\"你真的要退出吗？\请确认…\") = vbNo Then Cancel = True End Sub
VB启动控制面板大全 模块： control.exe
命令： rundll32.exe shell32.dll,Control_RunDLL 结果： 显示控制面板窗口。 例子： Dim x
x = Shell(\"rundll32.exe shell32.dll,Control_RunDLL\") 辅助选项
模块： access.cpl
命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,5 结果： 显示辅助选项/常规。
命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,1 结果： 显示辅助选项/键盘。
命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,2 结果： 显示辅助选项/声音。
命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,3 结果： 显示辅助选项/显示。
命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,4 结果： 显示辅助选项/鼠标。 添加新硬件
模块： sysdm.cpl
命令：rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1 增加新的打印机 模块：shell32.dll
命令：rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter 添加/删除程序 模块：appwiz.cpl
命令：rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1 结果：显示安装/卸载。
命令：rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1 结果：显示安装/卸载。
命令：rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,2 结果：显示Windows 安装。
命令：rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,3 结果：显示启动盘。 复制磁盘
模块：diskcopy.dll
命令：rundll32.exe diskcopy.dll,DiskCopyRunDll 时间/日期
模块： timedate.cpl
命令： rundll32.exe shell32.dll,Control_RunDLL timedate.cpl,,0 结果： 显示设置日期/时间。
命令： rundll32.exe shell32.dll,Control_RunDLL timedate.cpl,,1 结果： 显示设置时间区域。 拨号连接(DUN) 模块： rnaui.dll
命令： rundll32.exe rnaui.dll,RnaDial 连接_名称 结果： 打开指定的拨号连接。 例子：
x= Shell(\"rundll32.exe rnaui.dll,RnaDial \" & \"连接_名称\显示器
模块： desk.cpl 结果： 背景设置。
命令： rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1 结果： 屏幕保护设置。
命令： rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2 结果： 外观设置。
命令： rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3 结果： 设置窗口。 操纵杆
模块： joy.cpl
命令： rundll32.exe shell32.dll,Control_RunDLL joy.cpl 邮件/传真
模块： mlcfg32.cpl
命令： rundll32.exe shell32.dll,Control_RunDLL mlcfg32.cpl 结果： 出现 MS Exchange 属性设置。 邮局设置
模块： wgpocpl.cpl
命令： rundll32.exe shell32.dll,Control_RunDLL wgpocpl.cpl 结果： 显示 MS Postoffice Workgroup Admin 设置。 主设置
模块： main.cpl
命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @0 结果： 显示鼠标属性。
命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @1 结果： 显示键盘/速度属性。
命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @1,,1 结果： 显示键盘/语言属性。
命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @1,,2 结果： 显示键盘/常规属性。
命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @2 结果： 显示打印机属性。
命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @3 结果： 显示字体属性。
命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @4 结果： 显示电源管理属性。 增加 Modem
模块：modem.cpl
命令：rundll32.exe shell32.dll,Control_RunDLL modem.cpl,,add 多媒体
模块： mmsys.cpl
命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,0 结果：声音。
命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,1 结果：视频。
命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,2 结果：声音 MIDI。
命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,3 结果：CD/音乐。
命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,4 结果：高级。
命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl @1 结果：声音。 网络
模块：netcpl.cpl
命令：rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl 打开方式窗口(Open With) 模块： shell32.dll
命令：rundll32.exe shell32.dll,OpenAs_RunDLL path\\ 口令
模块： password.cpl
命令： rundll32.exe shell32.dll,Control_RunDLL password.cpl 区域设置
模块： intl.cpl
命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,0 结果： 区域设置。
命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,1 结果： 数字格式设置。
命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,2 结果： 金额格式设置。
命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,3 结果：时间格式设置。
命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,4 结果： 日期格式设置。 屏幕保护
模块： appwiz.cpl
命令： rundll32.exe desk.cpl,InstallScreenSaver c:\\win\\system\\Flying Windows.scr 结果： 安装屏幕保护并显示预览属性页。 系统设置
模块： sysdm.cpl
命令： rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,0 结果： 显示常规设置。
命令： rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,1 结果： 显示设备管理设置。
命令： rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,2 结果： 显示硬件设置。
命令： rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,3 结果： 显示性能设置。 IE4 设置
模块： inetcpl.cpl
命令： rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl
隐藏和显示任务栏
任务栏一般是显示在窗口的最底下，但有时我们需要隐藏它。 声明：
Dim hWnd1 As Long
Private Declare Function FindWindow Lib \"user32\" Alias \"FindWindowA\" (ByVal As String, ByVal lpWindowName As String) As Long
lpClassNamePrivate Declare Function SetWindowPos Lib \"user32\" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Const SWP_HIDEWINDOW = &H80 Const SWP_SHOWWINDOW = &H40 隐藏的例子：
hWnd1 = FindWindow(\"Shell_traywnd\\"\")
Call SetWindowPos(hwnd1, 0, 0, 0, 0, 0, SWP_HIDEWINDOW) 显示的例子：
Call SetWindowPos(hwnd1, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
安全
处理加了密码的MDB数据库文件
当 MDB 文件加了密码，直接由 Access 打印MDB文件时，会出现密码对话框，询问密码。但是若要由 VB或BA程序中打印，必須更改B和VBA序中打开MDB文件的指令，否则会出现错误信息！以下针对各种情况，分別加以说明：
1、 使用 DAO 命令打开MDB文件： OpenDatabase
若要由程序中打开，命令如下：
Set DB = OpenDatabase(DatabaseName, False, False, \";Pwd=密码\") 实例：
Dim db As Database
Set db = OpenDatabase(\"C:\\db1.mdb\若要使用 Data 控件，设定方法如下：
1、设定 DatabaseName 属性 (MDB文件名称 / 含路径)
2、设定 Connect 属性，將预设的字串 \"Access\" 改成 \";Pwd=密码\" (不含双引号) 3、设定 RecordSource 属性
2、使用 ADO 命令打开MDB文件：
在使用 ADODC 或 DataEnvironment 设定好之后，直接利用属性窗口修改 ConnectionString 属性(附属于 ADODC) 或 ConnectionSource 属性(附属于 DataEnvironment 的 Connection 控件)，修改的方法是在属性之后增加以下参数：
;Jet OLEDB:Database Password=密码
除了 ADODC 及 DataEnvironment 之外， 直接使用 ADO 控件來打开含有密码的 mdb MDB文件，设定参数的方法也是相同的。
3、压缩加了密码的MDB文件：CompactDatabase
DBEngine.CompactDataBase \"原MDB文件\新MDB文件\密码\" 实例例如：
DBEngine.CompactDatabase \"C:\\Db1.mdb\
4、复加了密码的MDB文件： RepairDatabase
不必理会MDB文件设定的密码！
DBEngine.RepairDataBase \"MDB文件\" 实例例如：
DBEngine.RepairDataBase \"C:\\Db1.mdb\"
以下给出一个函数可以使用DAO打开带密码保护的MDB数据库文件：
Public Function OpenPasswordProtectedDatabase(DBPath As String, _ Password As String) As Object
On Error Resume Next Dim db As DAO.Database
Set db = DAO.OpenDatabase(DBPath, False, False, _ \";pwd=\" & Password)
If Err.Number = 0 Then
Set OpenPasswordProtectedDatabase = db Else
Set OpenPasswordProtectedDatabase = Nothing End If
End Function
其中参数DBPath为数据库文件的有效路径名称；参数Password为密码。 该函数需要引用DAO数据库才有效。
如何调出工作组对话框
调出“用户与组帐号”对话框：DoCmd.DoMenuItem acFORMBar, 6, 5, 2, acMenuVer70 调出“用户与组权限”对话框：DoCmd.DoMenuItem acFORMBar, 6, 5, 1, acMenuVer70 以上语句在office2000里测试通过
试用版时间与日期的方法
可用注册表简单地保存已用的天数或次数 ' 次数（如30次）： Private Sub Form_Load() Dim a As Long Dim b As Long
b = GetSetting(\"MyApp\ a = b Xor 51345 If a < 30 Then
MsgBox \"现在剩下：\" & 30 - a & \"试用次数，好好珍惜！\" a = a + 1
b = b Xor 51345
SaveSetting \"MyApp\
Else
MsgBox \"试用次数已满，请联系gfuuyygy!\" End If End Sub
'时间的（如10天） Private Sub Form_Load() Dim a As Long
a = GetSetting(\"MyApp\ If a = 10 Then
MsgBox \"试用期已过，请联系gfuuyygy!\" Else
MsgBox \"现在剩下：\" & 10 - a & \"试用天数，好好珍惜！\"
if day(now)-a>0 then a = RemainDay + 1
SaveSetting \"MyApp\ End if End if End Sub
在 Windows 注册表中 或 (Macintosh中)应用程序初始化文件中的信息保存或建立应用程序项目。 语法
SaveSetting appname, section, key, setting SaveSetting 语句的语法具有下列命名参数：
appname
必要。字符串表达式，包含应用程序或工程的名称，对这些应用程序或工程使用设置 在Macintosh中，这是System文件夹中Preferences文件夹中初始化文件的文件名。 section
必要。字符串表达式，包含区域名称，在该区域保存注册表项设置。 key
必要。字符串表达式，包含将要保存的注册表项设置的名称。 setting
必要。表达式，包含 key 的设置值。
说明
如果无论如何也不能保存注册表项设置，则将导致错误发生。 示例
首先使用 SaveSetting 语句来建立Windows注册区（或 16位 Windows 平台的.ini档）里 appname 应用程序的项目，然后使用 GetSetting 函数来得到其中一项设置并显示出来。因为有传入参数 default，GetSetting 函数一定会有返回值。请注意，section 名称不能用 GetSetting 函数取得。最后，使用 DeleteSetting 语句将该应用程序项删除。
' 用来保存 GetSetting 函数所返回之二维数组数据的变量。 Dim MySettings As Variant ' 在注册区中添加项目。
SaveSetting \"MyApp\SaveSetting \"MyApp\
Debug.Print GetSetting(appname := \"MyApp\
DeleteSetting \"MyApp\
显示信息文件中的用户身份 =CurrentUser()
如何不通过设置工程密码锁定VBA代码?
1、打开二进制编辑软件，我用的是UltraEdit 2、在二进制编辑软件里打开你要加密的mdb文件 3、按CTRL+F调出查找对话框
4、在查找对话框里输入要查找的字符串：ID=\"{
5、在\"查找ASCII\"前打勾，然后按“查找下一个” 6、找到后更改ID=\"{后的一个字符为其它字符，并记住该字符在改之前的值（因为解锁的时候要改回来。
7、保存更改并退出
现在打开你的mdb文件并查看VBA代码
防止Access 2000密码被破译的方法
如果你过分信任 Access 2000数据库的密码保护，你可能会因此而蒙受损失。这是因为Access 2000的数据库级密码并不安全，相反它很脆弱，甚至下面这段非常小的程序就可以攻破它：
' 程序一（VB6）：Access 2000密码破译 Private Sub Command1_Click()
Const Offset = &H43 ' 文件偏移地址：Access数据库从此处开始存放加密密码 Dim bEmpty(1 To 2) As Byte, bPass(1 To 2) As Byte Dim I As Integer, Password As String ' 打开一个空数据库作为参照
Open \"D:\\VB6_Test\\MDB_Password\\New_Empty_DB.mdb\" For Binary As #1 ' 打开被密码保护的数据库
Open \"D:\\VB6_Test\\MDB_Password\\Pass_Protected_DB.mdb\" For Binary As #2 Seek #1, Offset Seek #2, Offset
For I = 1 To 20 ' Access 2000 数据库密码最长允许20位 Get #1, , bEmpty ' 其中每位密码占两个字节
Get #2, , bPass ' 一个汉字也仅是一位密码，占两个字节 If (bEmpty(1) Xor bPass(1)) <> 0 Then
Password = Password + Chr(bEmpty(1) Xor bPass(1)) ' 将密码解密 End If Next
Close 1, 2
MsgBox \"Password:\" + Password ' 显示密码 End Sub
下图显示
了 Access 2000的密码建立以及被上述程序破解后的情况
一、深入
分析
上述程序成功的关键是使用了一个空数据库（New_Empty_DB.mdb）。该数据库的创建日期必须与被密码保护的数据库（Pass_Protected_DB.mdb）相一致。 换句话说，Access 2000 仅仅是使用“数据库创建日期”来加密用户密码。
下图是在 Windows资源管理器中获取“创建日期”的示例：
应注意的是：上面的“创建日期”只是操作系统级的，也就是 Windows记录在文件夹目录里的信息（根据文件名的长短，每个文件在目录里占用至少32个字节，包括：文件名、属性、文件大小、首蔟号、创建时间、修改时间和访问时间等）。
Access 2000 在数据库中也记录了该数据库的“创建日期”。加密数据库密码的正是数据库内部记录的这个“创建日期”。该日期只有在数据库被成功打开后才能看到。但在一般情况下，操作系
统级的以及数据库内保存的“创建日期”是完全一样的，因此这为破译者提供了方便。
上述程序中还有一点需要说明：为简明起见，解密密码时仅处理了双字节的首字节，因此它仅对非汉字密码有效。若要解密汉字密码，须对双字节均做处理。 二、防范措施
1、隐藏“创建日期”
从上面的分析可以看出，既然“创建日期”是破译的关键，那么我们应“对症下药”，将真实的“创建日期”隐藏起来。
第一步，创建数据库时，使用一个“不可思议的、别人不易猜测”的日期。做法为：修改 Windows系统日期，例如改为2026年05月15日，创建数据库后再将系统日期改回。这个“不可思议”的日期即为该数据库的真实“创建日期”。
第二步，修改操作系统级的“创建日期”。上述第一步完成后，该数据库在操作系统级的创建日期也是2026年05月15日，必须加以修改，以达到隐藏真实创建日期的目的。修改操作系统级的“创建日期”可以由下面的程序二完成。
' 程序二（VB6）：修改文件在操作系统级的“创建日期” Private Type
dwLowDateTime As Long dwHighDateTime As Long End Type
Private Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer
wMilliseconds As Integer End Type
Private Const GENERIC_WRITE = &H40000000 Private Const OPEN_EXISTING = 3 Private Const = &H1 Private Const = &H2
Private Declare Function Set Lib \"kernel32\" Alias _ \"Set\" (ByVal h Long, lpCreateTime As , _
ByVal NullP As Long, ByVal NullP2 As Long) As Long Private Declare Function SystemTimeTo Lib \"kernel32\" _ (lpSystemTime As SYSTEMTIME, lp As ) As Long
Private Declare Function Create \"kernel32\" Alias \"CreateFileA\" _ (ByVal lp As String, ByVal dwDesiredAccess As Long, ByVal _ dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal _ dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _ ByVal hTemplate Long) As Long
Private Declare Function CloseHandle Lib \"kernel32\" (ByVal hObject As Long) As Long
Private Declare Function Local Lib \"kernel32\" _ (lpLocal As , lp As ) As Long Private Sub Command1_Click()
Dim Year As Integer, Month As Integer, Day As Integer Dim Hour As Integer, Minute As Integer, Second As Integer Dim TimeStamp As Variant, As String, X As Integer
Year = 2001: Month = 3: Day = 13 ' 准备设定的“创建日期” Hour = 12: Minute = 0: Second = 26
TimeStamp = DateSerial(Year, Month, Day) + TimeSerial(Hour, Minute, Second) = \"D:\\VB6_Test\\MDB_Password\\Pass_Protected_DB.mdb\" ' 目标文件名 X = Modify(, TimeStamp) End Sub
Function Modify( As String, TimeStamp As Variant) As Integer Dim X As Long, Handle As Long, System_Time As SYSTEMTIME Dim As , Local_Time As
System_Time.wYear = Year(TimeStamp): System_Time.wMonth = Month(TimeStamp) System_Time.wDay = Day(TimeStamp)
System_Time.wDayOfWeek = Weekday(TimeStamp) - 1
System_Time.wHour = Hour(TimeStamp): System_Time.wSecond = Second(TimeStamp) System_Time.wMilliseconds = 0
X = SystemTimeTo(System_Time, Local_Time) X = Local(Local_Time, ) ' 转换成可用的类型 Handle = Create, GENERIC_WRITE, Or _
, ByVal 0&, OPEN_EXISTING, 0, 0) ' 打开文件
X = Set(Handle, , ByVal 0&, ByVal 0&) ' 设置日期
_ CloseHandle Handle ' 关闭文件 End Function
图三显示的是数据库的真实“创建日期”以及经程序二伪装的操作系统级的“假象”日期。
可以看出，隐藏“创建日期”的方法对破译者来说只是增大了破译的工作量，增加了破解试验的次数。只有将该方法与下述的“方法二”相结合，才能达到“既治标又治本”的效果。不过在一般的情况下“方法一”已够用，因为如果破译者起始使用的测试日期与最终的真实日期相差百年，他需要付出数万
次的努力！
2、使用用户级安全机制
通过设置不同的用户帐号和组帐号对数据库中的各种资源进行权限管理。这种加强了的安全机制虽然给日常使用（尤其是单用户使用）带来了不便，但在有安全隐患的地方依然有设置的必要。 设置各种帐号及相应权限的简单方法是使用“设置安全机制向导”。 三、结论
所谓“道高一尺魔高一丈”，因为这世上并没有绝对的安全。上述方法一的目的是提高破译的成本以达到常人难以接受的程度；而方法二的初衷是增加密码的数量。两种方法的结合足以使破译者望而却步。不过这并不意味着百分之百的安全。但从思想上提高安全意识，防患于未然，这毕竟是正确的选择。
Access 2000数据库的密码忘了怎么办
在Access 2000 数据库中，为了安全起见，可以为所建的数据库设置密码。但是，密码忘了怎么办？别急，这里介绍一种密码破解方法。
用磁盘编辑工具打开Access 2000 所建的数据库，在库文件的地址00000042处开始的40个字节是Access 2000库的密码位。如果一个未加密的库，这40个字节原始数据依次为:29 77 EC 37 F2 C8 9C FA 69 D2 28 E6 BC 3A 8A 60 FB 18 7B 36 5A FE DF B1 D8 78 13 43 60 23 B1 33 9B ED 79 5B 3D 39 7C 2A 。当你给数据库设置了密码后，这40个字节就变成了密钥。因此，要破解密码而不需保持原库的密码，只要将00000042 处开始的40个字节还原成原始数据就行了。要做到这一点，你可用磁盘编辑工具或将以下所附的程序稍加修改，把以上所列40个数据填到00000042开始处。
但是，有没有办法既能破解密码又能保持原密码呢？有。要做到这一点，必须搞清楚Access 2000库的加密原理。事实上，Access 2000库的加密原理很简单。当你设置了密码后，Access 2000 就将你的密码（请注意你所输入的密码是ASCII字符）的ASCII码与以上的40个字节数据进行异或操作，因此，从库文件的地址00000042开始的40个字节就变成了密钥了。例如，如果你设置的密码为1234567(注意:最多只能设20个ASCII字符)，经过异或操作后，则从00000042处开始的40个字节的数据就变成了 18 77 DE 37 C1 C8 A8 FA 5C D2 1E E6 8B 3A B2 60 C2 18 4B 36 6B FE ED B1 EB 78 27 43 55 23 87 33 AC ED 41 5B 04 39 4C 2A 。大家都知道，一个数据经过一次异或操作后，再一次经过同样的异或操作就可还原了。因此，对已经设置了密码的Access 2000库，只要将40个密钥数据与原始的40个数据进行一次异或操作就可得到密码了。
顺便提一下，由于ACCESS 2000对每个密码字符采用双字节表示，故40个字节原始数据可依次分为20组，每组代表一个密码字符，进行异或操作的是每组的第一个字节，第二个字节不变 在前端设系统时间与局域网中后端系统时间相同 shell (\"net time \\\\服务器名 /set /yes\"),vbHide
链接密码保护的数据库 作者： 朱亦文 function lj()
dim catdb as adox.catalog dim tbllink as adox.table set catdb = new adox.catalog
catdb.activeconnection = currentproject.connection set tbllink = new adox.table ' 建立一个新的表对象 with tbllink
.name = \"订单\" ' 链接表名称 set .parentcatalog = catdb
.properties(\"jet oledb:create link\") = true .properties(\"jet oledb:link datasource\") = _ \"c:\\program files\\zhanyexing\\123.mdb\"
.properties(\"jet oledb:link provider string\") = _ \"ms access;pwd=123;\" ' 提供者及密码
.properties(\"jet oledb:remote table name\") = \"订单\" ' 原数据库中的表 end with
catdb.tables.append tbllink ' 添加到库中 set tbllink = nothing end function
注：在vba编辑器中引用\"microsoft ado ext. 2.5 for ddl and security\"以及\"microsoft activex data objects 2.1/2.5/2.6/2.7 library\"
动手做一个专用解密器
我们在使用Ａｃｃｅｓｓ数据库时，有时忘记了密码，怎么办？网上的解密器不少，但我们要去找这样的解密器也很费时，如果你对程序的编写有一点基础，那么，让我们动手做一个专用解密器吧。 原理：首先，我们要了解Ａｃｃｅｓｓ数据库的加密方法。Ａｃｃｅｓｓ数据库的有效密码为１３位，在不加密时，数据库的第６７至７９位为一固定的字符串，每位的ＡＳＣＩＩ码值分别为８６，ＦＢＥＣ３７，５Ｄ，４４，９Ｃ，ＦＡ，Ｃ６，５Ｅ，２８，Ｅ６，１３。加密时，分别用密码的每一位与６７至７９位的字符的ＡＳＣＩＩ码值进行异或运算，得到的一个新字符串，将它写回６７至７９位。 知道了加密方法，解密就比较容易了。将６７至７９位的字符的ＡＳＣＩＩ码值分别与“８６，ＦＢ，ＥＣ，３７，５Ｄ，４４，９Ｃ，ＦＡ，Ｃ６，５Ｅ，２８，Ｅ６，１３”进行异或运算，即可得到密码。 下面我们用ＶＢ编个小程序，来实现Ａｃｃｅｓｓ数据库的解密。请在窗体上放置一个通用对话框控件Ｃｏｍｍｏｎｄｉａｌｏｇ１，其Ｆｉｒｌｔｅｒ属性设为“Ａｃｃｅｓｓ数据库文件．ｍｄｂ”；文本框控件Ｔｅｘｔ１，命令控件Ｃｏｍｍａｎｄ１，其Ｃａｐｔｉｏｎ属性设为“取得密码”。代码如下： Ｏｐｔｉｏｎ Ｅｘｐｌｉｃｉｔ Ｐｒｉｖａｔｅ Ｓｕｂ Ｃｏｍｍａｎｄ１＿Ｃｌｉｃｋ Ｄｉｍ ｐａｓｓｗｏｒｄ Ａｓ Ｓｔｒｉｎｇ Ｄｉｍ ｔｅｍｐ Ａｓ Ｂｙｔｅ Ｄｉｍ ｓｏｕｒｃｅ１２ Ａｓ Ｂｙｔｅ Ｄｉｍ ｉ Ａｓ Ｉｎｔｅｇｅｒ ｓｏｕｒｃｅ０ ＝ ＆Ｈ８６ ｓｏｕｒｃｅ１ ＝ ＆ＨＦＢ ｓｏｕｒｃｅ２ ＝ ＆ＨＥＣ ｓｏｕｒｃｅ３ ＝ ＆Ｈ３７ ｓｏｕｒｃｅ４ ＝ ＆Ｈ５Ｄ ｓｏｕｒｃｅ５ ＝ ＆Ｈ４４ ｓｏｕｒｃｅ６ ＝ ＆Ｈ９Ｃ ｓｏｕｒｃｅ７ ＝ ＆ＨＦＡ ｓｏｕｒｃｅ８ ＝ ＆ＨＣ６ ｓｏｕｒｃｅ９ ＝ ＆Ｈ５Ｅ ｓｏｕｒｃｅ１０ ＝ ＆Ｈ２８ ｓｏｕｒｃｅ１１ ＝ ＆ＨＥ６ ｓｏｕｒｃｅ１２ ＝ ＆Ｈ１３ ＣｏｍｍｏｎＤｉａｌｏｇ１．ＳｈｏｗＯｐｅｎ Ｉｆ ＣｏｍｍｏｎＤｉａｌｏｇ１．ＦｉｌｅＮａｍｅ ＝ ″″ Ｔｈｅｎ Ｅｘｉｔ Ｓｕｂ Ｏｐｅｎ ＣｏｍｍｏｎＤｉａｌｏｇ１．ＦｉｌｅＮａｍｅ Ｆｏｒ Ｂｉｎａｒｙ Ａｓ ＃１ Ｆｏｒ ｉ ＝ ０ Ｔｏ １２ Ｇｅｔ ＃１ ６７ ＋ ｉ ｔｅｍｐ Ｉｆ ｔｅｍｐ ＝ ｓｏｕｒｃｅｉ Ｔｈｅｎ Ｅｘｉｔ Ｆｏｒ ｐａｓｓｗｏｒｄ ＝ ｐａｓｓｗｏｒｄ ＆ Ｃｈｒｔｅｍｐ Ｘｏｒ ｓｏｕｒｃｅｉ Ｎｅｘｔ Ｃｌｏｓｅ ＃１ Ｉｆ Ｌｅｎｐａｓｓｗｏｒｄ ＝ ０ Ｔｈｅｎ Ｔｅｘｔ１．Ｔｅｘｔ ＝ ″该数据库没有加密！″ Ｅｌｓｅ Ｔｅｘｔ１．Ｔｅｘｔ ＝ ″该数据库的密码为：″ ＋ ｐａｓｓｗｏｒｄ Ｅｎｄ Ｉｆ Ｅｎｄ Ｓｕｂ。
加密后台数据库的方法
地球人都知道，MDB文件很不安全，破解MDB文件密码的软件层出不穷，那是否如果我们MDB作后台数据库，是不是就等于任人宰割了呢？我觉得未必是这样的。
我用过不少Access密码破解器，大多数都只能处理英文密码，因此我们可以针对这一特点，把MDB文件的数据库密码设置为中文的，这样就可以抵挡大部份破解器的攻击了。
一定有人会说，既然人家能写出破解英文密码的软件，一定也可以写出破解中文密码的软件。这句话一点都没错，不过我们还有第二招：更改文件头。
MDB的头16个字节保存着文件类型、版本等诸如此类的重要信息，Access靠这些信息来识别它们，如果我们改动一个或多个字节，Access就会因无法识别这些文件而打不开它们，也就达到了我们的目的：加密MDB文件。加密思路如下：
打开文件时，把正确的头文件内容写入相应的位置，我们自已的程序就可以访问它，关闭文件时把更改过的错误的头文件内容写入相应的位置。这样做有个弊端，就是程序运行时，后台文件是可以访问的，只有关闭后才加密，那么当程序运行时，别人如果知道了数据库密码，还是可以查看或导出数据的。
另一种做法是打开后台数据库后，马上建立一个持续到程序结束的物理连接，然后再把错误的文件头内容写入相应的位置，这样在程序运行当中，我们的前台程序是可以正常访问后台数据的，而不知道我们的加密方法的人是无法打开后台文件的。
'使后台可以正常访问
Function OpenHt(HTmdbPath As String) Dim fh As Integer
fh = Free HTmdbPath For Binary Access Write As #fh Put fh, 2, &H1 Close #fh End Function
'使后台无法正常访问
Function CloseHt(HTmdbPath As String) Dim fh As Integer
fh = Free HTmdbPath For Binary Access Write As #fh Put fh, 2, &H0 Close #fh End Function
'下面的都是跟后台建立物理连接的函数（必须放在模块里） Public HTcn As Connection
Public HTrs As New ADODB.Recordset Public HTsql As String '建立物理连接
Function OpenStandHT()
Set HTcn = CurrentProject.Connection '表1要改成相应的表名
HTsql = \"select * from 表1\" HTrs.Open HTsql, HTcn, 3, 3, 1 End Function
'关闭物理连接的函数，如退出程序时，或需要压缩后台文件时就要关闭物理连接 Function CloseStandHT() HTrs.Close
Set HTcn = Nothing End Function
Yhcwgl注册代码
Private Sub Form_Open(Cancel As Integer) Dim a As Long Dim b As Long
b = GetSetting(\"MyApp\
a = b Xor 51345 If a < 50 Then
MsgBox \"感谢使用《银河财务管理 1.01》免费测试版！\" & vbCrLf & _ \"提示：在注册前，您还有\" & 50 - a & \"次可以使用！\" & vbCrLf & _ \" 请您尽快注册！ \" & vbCrLf & _ \" \" & vbCrLf & _ \"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\" & vbCrLf & _ \" 欢迎您访问立文工作室\" & vbCrLf & _
\" \" & vbCrLf & _ \"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\" & vbCrLf & _ \" 联系人：于立文\" & vbCrLf & _ \" 电话： \" & vbCrLf & _ \" \" & vbCrLf & _
\" \" & vbCrLf & _ \"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\ a = a + 1
b = a Xor 51345
SaveSetting \"MyApp\ Else
MsgBox \"您的试用期已过,请您注册!\" & vbCrLf & _
\" \" & vbCrLf & _ \"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\" & vbCrLf & _ \" 欢迎您访问立文工作室\" & vbCrLf & _
\" \" & vbCrLf & _ \"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\" & vbCrLf & _ \" 联系人：于立文\" & vbCrLf & _ \" 电话：\" & vbCrLf & _ \" \" & vbCrLf & _
\" \" & vbCrLf & _ \"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\ DoCmd.Quit End If
End Sub
动态口令
1、动态口令。即每次登陆的口令是不同的。能够防止他人偷窥或键盘监视软件造成的失密。由于使用的是动态口令，能防止暴力破解工具的破解。
2、可自定义多组的动态口令，组数不限。规则不限。 3、可自定义每组口令的出错次数。
4、在“口令维护”窗口内三分钟不操作，将提示，若5秒内再无动作，将退出系统。 5、通过一定的加密手段来保护数据。
动态口令的使用原理：
每次登陆时，系统会提示一个时间,您根据您在口令维护窗口设置的规则进行运算，将结果输入口令窗，即可。因为这运算规则只有使用者知道，且繁简随意。而一般的偷窥者在急切中是非常不容易猜到密码的。
动态口令的规则设置：
1、本程序以“@”的符号代表系统提示的时间。 登陆时假定系统以09：03：05时间来提示：
设定的规则 应对的密码 解释
@ 90305 可不参与运算，最简单的一个 @+1 90306 可进行四则运算 @&\"p\" 90305p 可加入字符串
left(@,1) & \"w\" & right(@,2) 9w05 可有多个@在表达式中 2、反正能用“表达式”表达出来的都可以做为动态口令的设置规则。（在口令维护窗口可模拟提示并看结果） 3、在“口令维护”窗体的每一记录就是一个登陆口令的规则，而录入几条记录就有几组口令，和普通的录入数据是一样的。
现提供 登陆的流程，希望大家能帮我检测一下，是否有问题：
1、打开“主菜单”窗口前检验是否已登陆，是，则进入“主菜单”界面。否，则进入“登陆”窗体。
2、进入“登陆”窗口前检验是否首次使用，是，则致欢迎词并进入“口令设置”窗口。否，则进行登陆口令检验程序。 3、“登陆口令”检验程序，口令检验无法通过，则退出。检验通过后若在此之前已登陆过，则打开“口令维护窗口”，否，则打开“主菜单”界面。
4、在口令维护窗口上若连续3分钟无操作（输机或点击“规则”字段或进入下一记录），系统将提示，若再无操作，则退出系统。
5、退出“口令维护”窗口时，检验是否设置有口令，若无，则提示。可选择退出程序，下回再使用程序或返回“口令维护”界面进行口令的设置。
其他：
1、其实这些功能编制起来都不复杂，加密也很简单。当然我还是希望大家都来不遗余力的破解我的程序，若无这种的检验，技术也无法提高。
2、由于这是本人一时兴起刚刚编制的，而且又属于“登陆”类的，调试起来特别麻烦。就是不停的启动和退出。烦死了。因此也没怎么测试，不敢保证程序没有什么问题。有耐心的朋友可以拿回去检测一下了，有问题或有什么建议请通知本人。
3、登陆的使用人是结合access的“工作组”来使用的，也就是您必须在工作组中增加用户才能看出多用户的登陆效果。
4、本人仅想演绎一下登陆的功能，因此没有在界面上下功夫，有碍大家的眼睛，还请包涵。
关于自动关联工作组启动的方法-->admin转移-->admin转移
以指定工作组文件启动MDB文件 ，程序完成交给用户后，要求每次启动时均用指定的工作组文件，途径大致如下几种：
1。用快捷方式，在其中加上启动参数指定工作组文件; 2。用ACCESS内置工作组管理员指定工作组。 3。也可以直接修改注册表。
4。用VB之类的东东做个外壳启动带参数启动ACCESS。 第一种方式用户在使用中容易造成丢失。
第二第三种其实是一样的，但设置后用户在本机操作所有的数据库都要求登陆。 敝人推荐用第四种
其实用ACCESS本身也可以做个外壳，达到同样效果： Set fs = Application. ''查找文件 With fs
.LookIn = \"C:\\Program Files\\Microsoft Office\\\" ''查找路径 .SearchSubFolders = True ''包含子文件夹 . = \"msaccess.exe\" ''查找字串
If .Execute() > 0 Then
p = .FoundFiles(1) ''ACCESS主程序完整路径
Shell p & \" \" & CurrentProject.Path & \"\\123.mdb /wrkgrp \" & CurrentProject.Path & \"\\system.mdw\3 ''带参数启动程序 Else
MsgBox \"C:\\Program Files\\Microsoft Office\\ 下没找到MSACCESS的程序文件，系统无法运行.\" End If
End With
docmd.quit ''退出外壳
将外壳做成MDE交付用户便万事大吉啦。 带参数启动程序语句可更改为以下代码
Shell SysCmd(acSysCmdAccessDir) & \" msaccess.exe\" & CurrentProject.Path & \"\\123.mdb /wrkgrp \" & CurrentProject.Path & \"\\system.mdw\
注意，如果要将密码和用户名写在mde中，请先加密，否则用写字板就可看见密码及用户名
在VBA中修改安全机制的登录密码 ----------大頭
Private Sub OkButton_Click() On Error GoTo Err_OkButton_Click
Dim myuser As User, MyWorkspace As Workspace Dim A As Variant Dim B As Variant
Dim Glbuser As String Glbuser = CurrentUser() A = Me![CODE] ' NEW CODE B = Me![OldCode] 'OLDCODE If IsNull(A) Then
MsgBox \"未取得帳號，通行密碼無法變更\ GoTo Exit_OkButton_Click End If
If Len(A) < 4 Or Len(A) > 9 Then
MsgBox \"通行密碼不得少於四碼 或 多於八碼\ GoTo Exit_OkButton_Click End If
Set MyWorkspace = DBEngine.Workspaces(0)
DBEngine.Workspaces(0).Users(Glbuser).NewPassword B, A MsgBox \"通行密碼已變更為\" & A, , DoCmd.Close Exit_OkButton_Click: Exit Sub Err_OkButton_Click:
MsgBox \"原有通行密碼不正確，請重新輸入密碼\ Resume Exit_OkButton_Click End Sub
屏蔽和取消shift键的方法（建立、运行模块）1 Sub SetBypassProperty()
Const DB_Boolean As Long = 1
ChangeProperty \"AllowBypassKey\End Sub
Function ChangeProperty(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer
Dim dbs As Object, prp As Variant Const conPropNotFoundError = 3270
Set dbs = CurrentDb
On Error GoTo Change_Err
dbs.Properties(strPropName) = varPropValue
ChangeProperty = True
Change_Bye: Exit Function
Change_Err:
If Err = conPropNotFoundError Then ' Property not found. Set prp = dbs.CreateProperty(strPropName, _ varPropType, varPropValue) dbs.Properties.Append prp Resume Next Else
' Unknown error.
ChangeProperty = False Resume Change_Bye End If
End Function
取消屏蔽shift键的方法
做一個表單，新建一個核取方塊和一個按鈕，在表單On load事件寫上
cproperty \"AllowByPasskey\再自定義一段SUB如下：
Sub cproperty(pName, pType, pValue) On Error GoTo ki
Set prp = CurrentDb.CreateProperty(pName, pType, pValue) CurrentDb.Properties.Append prp Me![核取0] = pValue Exit Sub ki:
Me![核取0] = CurrentDb.Properties(pName) End Sub
確定按鈕的On click事件寫上：
CurrentDb.Properties(\"AllowByPasskey\") = Me![核取0] MsgBox \"更改完成，必須重新啟動資料庫，方可生效\"
那麼您要啟動或屏蔽Shift鍵時，開啟這個表單核取（啟動）或取消（屏蔽）核取方塊再重新啟動就可以了！
屏蔽和取消shift键的方法（建立模块、运行语句）2
Function SetBypassPropertyFalse() Const DB_Boolean As Long = 1
ChangeProperty \"AllowBypassKey\End Function
Function SetBypassPropertyTrue() Const DB_Boolean As Long = 1
ChangeProperty \"AllowBypassKey\End Function
Function ChangeProperty(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer
Dim dbs As Object, prp As Variant
Const conPropNotFoundError = 3270
Set dbs = CurrentDb
On Error GoTo Change_Err
dbs.Properties(strPropName) = varPropValue ChangeProperty = True
Change_Bye:
Exit Function
Change_Err:
If Err = conPropNotFoundError Then ' Property not found. Set prp = dbs.CreateProperty(strPropName, _ varPropType, varPropValue) dbs.Properties.Append prp Resume Next Else
' Unknown error.
ChangeProperty = False Resume Change_Bye End If End Function 屏蔽：
SetBypassPropertyFalse
MsgBox \"禁用shift设置成功，在下次启动应用程序时生效。请重新启动程序。\设置成功\" 取消：
SetBypassPropertyTrue
MsgBox \"启用shift设置成功，在下次启动应用程序时生效。请重新启动程序。\设置成功\" 在将access的用户密码、数据库密码同时生效的情况下，如何用ADO访问？ 试一下下面这个连接串：我在Access2000下试过正确. 数据库：C:\\db1.mdb 数据库密码：pass 用户: Admin
用户密码: winstar
用户组文件: system.mdw
//system.mdw这个文件要放在与db1.mdb同一活页夹内。或放在system32下。 //如果没有这个文件就不行。 设定：
提供者页：选JET4.0 O LEDB 引擎
边线页：输入数据库路径与名称C:\\db1.mdb，用户Admin，用户密码winstar。 全部页：1、Jet OLEDB:Database Password 输入数据库密码:pass
2、Jet OLEDB:System database 输入用户组文件: system.mdw //下面是我从ADOConnection1中COPY出来的连接字符串
Provider=Microsoft.Jet.OLEDB.4.0;Password=winstar;User ID=Admin;Data Source=C:\\db1.mdb;Mode=Share Deny None;Extended Properties=\"\";Jet OLEDB:System database=system.mdw;Jet OLEDB:Registry Path=\"\";Jet OLEDB:Database Password=pass;Jet OLEDB:Engine Type=5;Jet OLEDB:Database Locking Mode=1;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password=\"\";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False
是现成的工具破解的。我都觉得Access的密码太马虎了。别指望Access为你保密了 system.mdw是用户组数据库，里面有所有的用户及群组还有他们的密码
这个文件是要与.mdb数据库一起发布的。鼠标点过后，0秒钟破解所有的用户，密码与群组。
我用的是BCB6+SP2 , MDAC2.6 + SP1 + Access2000
出现：“多步 OLE操作失败，请检查每个OLE状态值，没有工作被完成。” 请用Access打开你的数据库，确认一下所用的用户名及权限。
Provider=Microsoft.Jet.OLEDB.4.0;Password=user1;User ID=User1;Data Source=C:\\Tmp\\db1.mdb;Mode=Share Deny None;Extended Properties=\"\";Persist Security Info=True;Jet OLEDB:System database=c:\mp\\system.mdw;Jet OLEDB:Registry Path=\"\";Jet OLEDB:Database Password=5678;Jet OLEDB:Engine Type=5;Jet OLEDB:Database Locking Mode=1;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password=\"\";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False 我用的是Access2000+Win XP Professinal+BCB 6系统。
首先用超级用户在ACCESS里创建了一个新的用户User1，同时设置数据库密码为5678。然后用User1登陆，将用户密码改为User1。
将C:\\program files\\microsoft office\\office下的system.mdw拷贝到MDB所在的目录。 BCB6中用ADO Connection连接MDB，构造上述连接串，可以连接成功。 通过编程设置数据库密码
按以下语法使用关键字 ALTER DATABASE，您可以编程设置、修改或删除数据库密码。
ALTER DATABASE PASSWORD NewPassword OldPassword
在这个语句中，密码由方括号 ([]) 分隔的 String 值表示，但下述情况例外。
第一次设置数据库密码时，使用 NULL 关键字作为 ALTER DATABASE 语句中的 OldPassword 参数。要删除数据库密码，请使用 NULL 关键字作为 ALTER DATABASE 语句的 NewPassword 参数。在这些情况下，关键字 NULL 不应出现在方框中。
在使用以下过程之前，可能需要设置对 Microsoft ADO Ext 2.5 for DDL and Security 库的引用（如果尚未设置）：
在 Visual Basic 编辑器中，指向“工具”菜单中的“引用”。将显示“引用”对话框。 选中 Microsoft ADO Ext 2.5 for DDL and Security 复选框。 请看以下第一次设置密码时的代码：
Private Function CreateDBPassword(ByVal Password As String, _ ByVal Path As String) As Boolean Dim objConn as ADODB.Connection Dim strAlterPassword as String On Error GoTo CreateDBPassword_Err ' 创建 SQL 串以初始化一个数据库密码。
strAlterPassword = \"ALTER DATABASE PASSWORD [Password] NULL;\"
' 打开不具有安全设置的数据库。 Set objConn = New ADODB.Connection With objConn
.Mode = adModeShareExclusive
.Open \"Provider=Microsoft.Jet.OLEDB.4.0;Data \" & _ \"Source=Path;\"
' 执行 SQL 语句对数据库进行安全设置。 .Execute (strAlterPassword) End With
' 清除对象。
objConn.Close
Set objConn = Nothing
' 如果成功，返回 true。 CreateDBPassword = True
CreateDBPassword_Err:
Msgbox Err.Number & \":\" & Err.Description CreateDBPassword = False End Function
此过程接受用户的密码以及 .mdb 文件的路径。首先，我们声明一个变量，代表对不具有安全设置的数据库的连接，同时声明一个 String 变量以包含我们用于更改密码的 SQL 语句。下一步，我们将 strAlterPassword 设置给使用 ALTER DATABASE PASSWORD 关键字的 Jet SQL 语句。请注意，因为我们不是要替换密码，因而第二个参数被设置为 NULL。下一步，我们打开一个到该数据库的连接。要设置密码，必须以独占方式打开数据库，因此要设置 Mode 属性。然后执行 SQL 语句。您通常可以从一个数据库运行此过程，以便在一个单独的不具有安全设置的数据库中设置密码。如果一切正常，函数返回 True。
如果要更改具有安全设置的数据库的密码，首先需要使用旧密码登录数据库，然后再更改密码。以下过程显示了这一技术。
在使用以下过程之前，可能需要设置对 Microsoft ADO Ext 2.5 for DDL and Security 库的引用（如果尚未设置）：
在 Visual Basic 编辑器中，指向“工具”菜单中的“引用”。将显示“引用”对话框。 选中 Microsoft ADO Ext 2.5 for DDL and Security 复选框。 请看以下过程：
Private Function ChangeDBPassword(ByVal OldPassword As String, _
ByVal NewPassword As String, ByVal Path As String) As Boolean Dim objConn as ADODB.Connection Dim strAlterPassword as String
On Error GoTo ChangeDBPassword_Err
' 创建 SQL 串以更改数据库密码。
strAlterPassword = \"ALTER DATABASE PASSWORD [NewPassword] [OldPassword];\"
' 打开具有安全设置的数据库。
Set objConn = New ADODB.Connection With objConn
.Mode = adModeShareExclusive
.Provider = \"Microsoft.Jet.OLEDB.4.0\"
.Properties(\"Jet OLEDB:Database Password\") = \"OldPassword\" .Open \"Data Source=Path;\"
' 执行 SQL 语句以更改密码。 .Execute (strAlterPassword) End With
' 清除对象。 objConn.Close
Set objConn = Nothing
ChangeDBPassword = True
ChangeDBPassword_Err:
Msgbox Err.Number & \":\" & Err.Description ChangeDBPassword = False End Function
此过程与前面的子例程类似，只是在登录具有安全设置的数据库时，需要使用更改之前的旧密码。为此，针对要更改的数据库，我们设置了 Connection 对象的 Database Password 属性。这是 Connection 对象的扩展属性之一，所以我们使用了如上所示的特殊语法。要从具有安全设置的数据库中删除密码，也可以使用此过程，只需将 ALTER DATABASE 语句的第一个参数替换为 NULL 关键字即可。
通过编程添加和删除用户和组
为数据库设置了安全性后，您可能需要使用用户和组。以下各节展示了其中的一些技巧。
在使用以下各节介绍的过程之前，可能需要设置对 Microsoft ADO Ext 2.5 for DDL and Security 库的引用（如果尚未设置）：
在 Visual Basic 编辑器中，指向“工具”菜单中的“引用”。将显示“引用”对话框。 选中 Microsoft ADO Ext 2.5 for DDL and Security 复选框。 添加和删除用户
以下过程将创建一个新的用户帐户，然后将其追加到用于当前数据库的工作组信息文件中的默认 Users 组。
注意：要在 Access 中使用下面的示例，您需要作为 Admins 组的成员登录并打开一个数据库。在下面的过程中，您要确保工作组信息文件不包含在 strUser 中指定了其名称的用户。例如，您可以先调用 DeleteUser 子例程来确保这一点。 请看以下代码：
Private Function AddUser(ByVal strUser As String, _ ByVal strPID As String, _
Optional ByVal strPwd As String) As Boolean Dim catDB As ADOX.Catalog
On Error GoTo AddUser_Err
' 实例化 Catalog 对象。
Set catDB = New ADOX.Catalog With catDB
' 使用到当前数据库的连接打开 ' Catalog 对象。
.ActiveConnection = CurrentProject.Connection ' 创建新的用户帐户。
.Users.Append strUser, strPwd, strPID ' 向默认 Users 组追加新的用户帐户。 .Groups(\"Users\").Users.Append strUser End With
' 关闭 Catalog 对象。 Set catDB = Nothing
AddUser = True
AddUser_Err:
Msgbox Err.Number & \":\" & Err.Description
AddUser = False End Function
该过程首先为 Catalog 对象声明一个变量，然后实例化该对象。
注意：Catalog 对象是 Access 数据库文件中所有对象的容器。
然后，该过程打开到当前数据库的连接，并使用来自调用过程的参数，将新用户追加到 Catalog 对象的 Users 集合中。然后新用户被追加到默认的 Users 组。Users 集合包含了在工作组信息文件中定义的数据库的所有用户。
要删除现有用户，可以使用以下过程：
Private Function DeleteUser(ByVal strUser As String) As Boolean Dim catDB As ADOX.Catalog
On Error GoTo DeleteUser ' 实例化 Catalog 对象。
Set catDB = New ADOX.Catalog With catDB
' 在当前数据库中打开 Catalog 对象。
.ActiveConnection = CurrentProject.Connection ' 删除 strUser。
.Users.Delete strUser End With
' 关闭 Catalog 对象。 Set catDB = Nothing
DeleteUser = True
DeleteUser_Err:
Msgbox Err.Number & \":\" & Err.Description DeleteUser = False End Function
此过程与前面的过程类似，只是使用了 Catalog 对象的 Delete 方法删除了在 strUser String 参数中指定的用户。
添加和删除组
添加组的过程与添加用户的过程类似。
Private Function AddGroup(ByVal strGroup As String, _ ByVal strPID As String) As Boolean Dim catDB As ADOX.Catalog
On Error GoTo AddGroup_Err
Set catDB = New ADOX.Catalog With catDB
' 在当前数据库中打开 Catalog 对象。
.ActiveConnection = CurrentProject.Connection ' 创建新的组。
.Groups.Append strGroup, strPID End With
' 关闭 Catalog 对象。 Set catDB = Nothing
AddGroup = True
AddGroup_Err:
Msgbox Err.Number & \":\" & Err.Description AddGroup = False End Function
此过程首先实例化 Catalog 对象，然后打开一个到当前数据库的连接。接下来，通过使用来自调用过程的参数，将新组追加到 Catalog 对象的 Groups 集合。
要删除现有组，可以使用以下过程：
Private Function DeleteGroup(ByVal strGroup As String) As Boolean Dim catDB As ADOX.Catalog
On Error GoTo DeleteGroup_Err
Set catDB = New ADOX.Catalog With catDB
' 在当前数据库中打开 Catalog 对象。
.ActiveConnection = CurrentProject.Connection ' 删除 strGroup。
.Groups.Delete strGroup End With
' 关闭 Catalog 对象。 Set catDB = Nothing
DeleteGroup = True
DeleteGroup_Err:
Msgbox Err.Number & \":\" & Err.Description DeleteGroup = False End Function
此过程与前面的过程类似，只是使用了 Catalog 对象的 Delete 方法删除了在 strGroup String 参数中指定的组。
下面我们来看看如何通过编程设置对数据库对象的权限。
通过编程设置权限
要对数据库中的各种对象设置权限，可以使用 Group 或 User 对象的 SetPermissions 方法。在下面的过程中，我们首先撤消组的所有权限，然后再赋予组特定的权限。这样可以确保该组只具有我们指定的权限：
Private Function SetGroupPermissions(ByVal strGroup As String, _ ByVal strTable As String, ByVal strObjectType As String, _ ByVal strAction As String, _
ByVal strRevokeEnum As String) As Boolean Dim catDB As ADOX.Catalog
On Error GoTo SetGroupPermissions_Err
Set catDB = New ADOX.Catalog With catDB
' 在当前数据库中打开 Catalog 对象。
.ActiveConnection = CurrentProject.Connection ' 撤消组的所有权限。
.Groups(strGroup).SetPermissions tblTable, _ strObjectType, strAction, strRevokeEnum
' 赋予组特定的权限。
.Groups(strGroup).SetPermissions tblTable, _ strObjectType, strAction, _
adRightRead Or adRightInsert Or adRightUpdate End With
' 关闭 Catalog 对象。 Set catDB = Nothing
SetGroupPermissions = True
SetGroupPermissions_Err:
Msgbox Err.Number & \":\" & Err.Description SetGroupPermissions = False End Function
在当前数据库中打开一个 Catalog 对象后，我们使用了 Groups 集合的 SetPermissions 方法，撤消了该组对 Employees 表的所有权限。第一个参数是表的名称，第二个参数显示了对象的类型，这里是表。第三个参数指定了在设置权限时要执行的操作的类型，第四个参数是一个权限常数，指定了该组没有任何权限。我们已经撤消了该组对 Employees 表的所有权限，现在可以赋予其所希望的权限。
下一个语句的前三个参数与前一个语句中的相同。第四个参数是通过使用 Or 运算符，组合不同的权限常数所创建的一个值。这里，我们赋予了读取、插入和更新该表的权限。
要对指定类型（例如上述示例中的表）的所有新对象设置权限，请将用于赋予权限的语句中的第一个参数更改为 NULL 关键字。例如： ...
catDB.Groups(strGroup).SetPermissions NULL, adPermObjTable ... 小结
在本文中，我们讨论了实现 Access 数据库不同保护级别的各种方法，介绍了共享级和用户级安全性。同时还介绍了如何使用 Access Security Wizard 以及如何通过编程来实现安全设置。
加解密文本的函数
Private Sub Comman1_Click()
Dim str1, str2, str3 As String str1 = \"王宇虹\"
str2 = Encrypt(str1, 188, 24) MsgBox str2
str3 = Encrypt(str2, 188, 24)
MsgBox str3 End Sub
Private Function Encrypt(ByVal strSource As String, ByVal Key1 As Byte, _ ByVal Key2 As Integer) As String Dim bLowData As Byte Dim bHigData As Byte Dim i As Integer
Dim strEncrypt As String Dim strChar As String
For i = 1 To Len(strSource) '从待加（解）密字符串中取出一个字符 strChar = Mid(strSource, i, 1) ' 取字符的低字节和Key1进行异或运算
bLowData = AscB(MidB(strChar, 1, 1)) Xor Key1 '取字符的高字节和K2进行异或运算
bHigData = AscB(MidB(strChar, 2, 1)) Xor Key2 '将运算后的数据合成新的字符
strEncrypt = strEncrypt & ChrB(bLowData) & ChrB(bHigData) Next
Encrypt = strEncrypt End Function 实现程序的
在一些系统，为了特定目的，经常要求程序隐藏起来运行，例如DCS（集散控制系统）中的后台监控系统、木马控制程序、源码防拷贝等，以减少被发现、截杀和反汇编的风险。这种功能模块要求程序在运行期间不仅不会在桌面出现，也不允许被操作者从任务管理器列表中发现。 程序的原理
对于一个程序而言，最基本的要求是： 1. 不在桌面出现界面； 2. 不在任务栏出现图标；
3. 程序名从任务管理器名单中消失。
对于上述第一点，可以将Form的Visible属性设为False。
要将图标从任务栏中屏蔽掉，可以把Form的ShowInTaskBar改为False。
在Windows环境下，可以调用WIN API函数中的RegisterviceProcess来实现第三个要求。 上述功能，不论用VC、Delphi、VB，还是PB等任何一种高级编程语言都是比较容易实现的。
功能多用于木马程序，但木马程序在许多国家和地区是不合法的，为便于理解，本文用VB结合一个程序防拷贝的实例来讲解。通过获取软件安装路径所在磁盘序列号(磁盘ID)，用做对合法用户的判断。以下程序的目的是用于讲解程序的编制和应用，对程序防拷贝内容作了一定程度的简化。 程序的示例
程序的具体编制操作如下：
1. 在VB6.0编程环境中，新建一个工程Project1。 2. 在Project1中添加模块Modulel，在工程属性中将工程名称改为HiddenMen，应用程序标题也改为HiddenMen（以下程序都经过实际运行测试，可以原样复制使用）。 在模块Module1中加入如下声明：
Public Declare Function GetCurrentProcessId Lib “kernel32” () As Long ’获得当前进程ID函数的声明
Public Declare Function RegisterServiceProcess Lib “kernel32” (ByVal ProcessId As Long, ByVal ServiceFlags As Long) As Long ’在系统中注册当前进程ID函数的声明
3. 在Project1中新建一个窗体Form1，设置Form1的属性： form1.Visible=False
form1.ShowInTaskBar=False 在代码窗口添加如下代码：
Private Declare Function GetDriveType Lib “kernel32” Alias “GetDriveTypeA” (ByVal n
Drive As String) As Long ’获得当前驱动器类型函数的声明
Private Declare Function GetVolumeInformation Lib “kernel32” Alias “GetVolumeInformationA” (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lp As Long, ByVal lp As String, ByVal n As Long) As Long ’获得当前驱动器信息函数的声明 Private Sub Form_Load()
Dim drive_no As Long, drive_flag As Long
Dim drive_chr As String, drive_disk As String Dim serial_no As Long, kkk As Long Dim stemp3 As String, dflag As Boolean
Dim strlabel As String, strtype As String，strc As Long
RegisterServiceProcess GetCurrentProcessId, 1 ’ 从系统中取消当前进程 strlabel = String(255, Chr(0)) strtype = String(255, Chr(0))
stemp3 = “172498135” ’这是作者C盘的序列号（十进制）,读者可根据自己情况更改。 dflag = False
For drive_no = 0 To 25
drive_disk = Chr(drive_no + 67) drive_chr = drive_disk & “:\\” drive_flag = GetDriveType(drive_chr) If drive_flag = 3 Then
kkk = GetVolumeInformation(drive_chr, strlabel, Len(strlabel), serial_no, 0, 0, strtype, Len(strtype)) ’通过GetVolumeInformation获得磁盘序列号 Select Case drive_no Case 0
strc = serial_no End Select
If serial_no = stemp3 Then dflag = True Exit For End If End If
Next drive_no
If drive_no = 26 And dflag = False Then ’非法用户 GoTo err: End If
MsgBox (“HI，合法用户！”) Exit Sub err:
MsgBox (“错误!你的C：盘ID号是” & strc) End Sub
Private Sub Form_Unload(Cancel As Integer)
RegisterServiceProcess GetCurrentProcessId, 0 ’从系统中取消当前程序的进程 End Sub
将上述程序代码编译后运行，在出现类似“错误!你的C盘ID号是172498135”对话框时，按下Ctrl+Alt+Del键，看看程序名叫“HiddenMen”是否在任务管理器名单列表里。如果把上述程序稍加改动，可以加到自己特定的程序中去。该程序在运行之中，不知不觉就完成了预定功能。 以上程序在简体中文Windows 98和VB 6.0环境中调试通过。 ACCESS(ADP/ADE) 编写数据库脚本
作者：Andrew Clinick
发表日期：2000 年 1 月 10 日
我在“If It Moves, Script It”（英文） (
sp)这篇文章中曾谈到，如何使用“Windows Script Host(WSH)”( Windows 脚本 主机) 管理 Windows 和 Windows 中的应用程序。文中的大多数示例都是基于管理 Windows 操作系统自身的，并不基于在该操作系统下运行的应用程序。为迎接新千 年，我想我应该谈谈，如何在众多显露可脚本化接口的应用程序中使用脚本。这次只 涉及“SQL Server”。在以后的几个月中，我将着重谈 Exchange、Office 和“系 统管理服务器”。
---------------------------------------------------------------------- ----------
您可以通过使用“分布式管理对象”、“数据转换服务”和新的“SQL Server XML” 实现，将脚本用于“SQL Server”。
---------------------------------------------------------------------- ----------
许多人都能够通过“Active Data Object(ADO)”和“Active Server Page
(ASP)”技术访问数据库了。ADO 在帮助您查询和更新数据库方面做了大量的工作 — 但在备份（Y2K 问题带给我们的警惕）或是数据库之间的传输数据方面，其表现又如 何呢？而这时就非涉及到 XML 不可了。
在此，我将告诉您如何通过使用 ADO 的伴随技术 － 特别是“分布式管理对象”、 “数据转换服务”和新的“SQL Server XML”实现，将脚本用于“SQL Server”。 分布式管理对象
“分布式管理对象 (DMO)”是一组 COM 对象，它将“SQL Server”数据库和复制管 理封装在一起。这意味着您可以编写一个 WSH 脚本，将特定表中的所有数据都复制到 用制表符分隔的文件中，这有助于大量数据的移动。我之所以选择这个示例，是因为 它的代码编写起来简单，但 DMO 允许您获取“SQL Server”中的每个对象，使您能 够编写出一些非常优秀而有意义的管理脚本。
DMO 的关键是 SQLDMO.SQLServer 对象，它是基本的对象，它允许您连接到服务器 并获取所有可用对象。在这种情况下，我将使用 Database 集合来选择数据库，然后 从 table 集合访问要转储到文件的表。如果不提供数据库，将出现错误消息，并且 脚本也就结束了。如果不提供表名，脚本将在数据库所有的表中循环，并导出非系统 表。如果提供了数据库，它就导出该表。该示例虽然功能有限，但它为“SQL Server”提供了基于命令行的简单的导出实用程序，您可以以它为根据。 现在先看一段代码：
'声明与 sql 谈话时使用的变量 Dim oServer ' SQL Server 对象
Dim oDatabase ' 要使用的目标数据库 Dim oBCP ' BCP 对象
Dim nRows ' 从 bcp 返回的行数 dim table ' 表对象 on error resume next ' 第一个参数必须是数据库
if WScript.Arguments(0) = \"\" then
WScript.Echo \"您没有提供要连接的数据库\" WScript.Quit end if
' 创建 SQL DMO 的实例
Set oServer = CreateObject(\"SQLDMO.SQLServer\") ' 创建 SQL DMO Bulkcopy 对象的实例
Set oBCP = CreateObject(\"SQLDMO.BulkCopy\") oServer.EnableBcp = True ' 登录到本地服务器
' 希望您已经更改了 sa 口令!! oServer.Connect \".\
' 连接到提供的数据库
Set oDatabase = oServer.Databases(Wscript.Arguments(0)) ' 将分隔符设置为逗号
oBCP.ColumnDelimiter = vbComma ' 将文件类型设置为以逗号分隔 oBCP.Data = SQLDMOData
oBCP.ImportRowsPerBatch = 1000 oBCP.MaximumErrorsBeforeAbort = 1 BCP.RowDelimiter = vbCrLf
oBCP.ServerBCPData = SQLDMOBCPData oBCP.UseExistingConnection = True ' 如果未提供表，则转储所有的表 if wscript.Arguments(1) = \"\" then for each table in oDatabase.tables ' 确保该表不是系统表
if table.systemobject = false then oBCP.Data = table.name & \".csv\" nRows = table.ExportData(oBCP)
wscript.Echo nRows & \" rows exported from \" & table.name end if
nextelse ' 设置输出文件
oBCP.Data = wscript.Arguments(1) & \".csv\"
nRows = oDatabase.Tables(wscript.arguments(1)).ExportData(oBCP) wscript.Echo nRows & \" rows exported from \" & wscript.arguments(1) end if
DMO 的全部内容要比本文介绍的多得多，但我希望本文能给您一些感性认识：用某些 简单的 WSH 脚本和 DMO 可以做些什么。您可以下载我的示例（英文） ()。有关 DMO 的详细信息， 请访问 （英文） ()。
数据转换服务
导出到 Comma Separated 文件 (CSV)，可以作为将数据导出到 SQL 和从 SQL 导 入的起点，但这不象是尖端科技（太过于 20 世纪了，您不觉得吗?）。“SQL Server 7.0”以“数据转换服务 (DTS)”的形式，提供了相当完善的导入和导出机 制。幸运的是，脚本在“SQL Server”的这个新领域中仍有一席之地，因此，您可以 用“Visual Basic(R) 脚本编辑 (VBScript)”、“JScript(R)”或“Perl”的技 术来扩展 DTS 的能力。
DTS 的设置非常简单，特别是在使用“SQL ServerEnterprise Manager”的时候。 在默认情况下，“SQL Server”有一个定义的文件夹，可存储任何转换，而且 “Enterprise Manager”提供了创建和编辑 DTS 程序包的大的图形用户界面 (GUI)。在下面的示例中，我选择了已由 sqlexport.wsf 文件创建的
employees.csv 文件和“SQL Server”中的一个新表。DTA 程序包将创建该表，加 载到 Text 文件中，然后运行某个脚本，将数据转换到“SQL Server”的表中。 DTS 程序包中的转换，使脚本在整个转换过程中保持运行状态。“SQL Enterprise Manager”提供的简单的脚本编辑器，有一个语法分析脚本按钮。在运行脚本之前， 该按钮将警告您脚本中的错误。在转换过程中，该脚本使用 VBScript 的 Cint 功 能，将 employeeid 和 deptid 的输入转换为 int，并将所有的电子邮件地址转换 为小写字母。
'********************************************************************* *
' Visual Basic 转换脚本 ' 把每个源列复制到 ' 目标列
'********************************************************************* **
Function Main()
DTSDestination(\"EmployeeID\") = cint(DTSSource(\"Col001\")) DTSDestination(\"FirstName\") = DTSSource(\"Col002\") DTSDestination(\"LastName\") = DTSSource(\"Col003\") DTSDestination(\"email\") = lcase(DTSSource(\"Col004\")) DTSDestination(\"extension\") = DTSSource(\"Col005\") DTSDestination(\"office\") = DTSSource(\"Col006\")
DTSDestination(\"DeptID\") = cint(DTSSource(\"Col007\")) Main = DTSTransformStat_OK End Function
用 DTS，能够采用某些完善的导入/导出机制，并使您能够在转换的任何一步中使用脚 本。重要的是，要注意脚本可能不是操作数据的最佳方式 — 尤其是您的数据集很大 的话。如果您有大量数据需要转换，而且性能也很重要，则您可能需要考虑使用 Visual Basic 或 C++ 来创建 COM 组件，然后从 DTS 内部调用该组件。也就是
说，如果性能并不重要，并且要在数据导入/导出时对它进行转换，则脚本为您提供了 实现这一点的灵活机制，并使您能够将所有代码存储到“SQL Server”数据库中，使 部署变得相当简单。 关于 XML
目前，XML 看起来像是在应用程序之间共享数据的最佳工具，所以“SQL Server”的 所有管理肯定都得到了 XML 的好处。编写提取数据库中所有数据的脚本，以及编写用 编程的方法创建 XML 文档的脚本，都是可能的。但是，如果您只要查询“SQL Server”的话，最好使它在 XML 中返回数据，然后用脚本操作该 XML。“SQL Server”组最近发行了“SQL Server XML”技术的非正式版本，完全做到了这一 点。
新的 XML 技术使用起来非常简单。实际上是对服务器发出 HTTP 请求，将查询传递 给服务器，而服务器返回 XML。为了举例说明，我创建了简单的 WSH 脚本，它向本 地机器查询 North Wind 数据库的雇员表中的所有数据。为访问 XML，该脚本使用了 “Internet Explorer 5.01”附带的 XML 分析程序。此对象的美妙之处，在于它处 理您所有的 HTTP 请求，并使您能够同步调用。因为您再也不用处理任何事件驱动的 程序，所以，它对编写脚本很有帮助。
该脚本非常简单。它创建了 XML 分析程序的实例，使用分析程序打开 URL，然后将 结果保存为 .xml 文件。只需五行的脚本，不错吧!
' 设置请求的 url xmlpath = \"?
sql=select+*+from+employees+for+xml+auto\" ' 创建“XML 分析程序”的实例
Set myXMLDoc = CreateObject(\"Microsoft.XMLDOM\") ' 不需要异步
myXMLDoc.async = false ' 加载该 URL
myXMLDoc.Load xmlpath ' 保存文档
myXMLDoc.save \"employees.xml\"
它的强大之处在于，现在可很容易地与服务器建立远程连接并转储数据；只要更改 URL，您早已做过了。此例告诉您如何导出，但是您可以轻松地写出导入例行程序， 用 XML 分析程序在 XML 中反复操作并将值插入数据库中。 摘要
“SQL Server”提供全面的可编写脚本的机制，用于本地或远程管理数据库。DMO 和 DTS 已经上市（实际上，DMO 已发行了许多版本），所以您可以直接利用它们，
使您的数据库管理任务自动化。Windows 2000 已与“Windows Script Host 2.0” 一起上市，所以以上所有脚本的运行，都不受装有“SQL Server”的 Windows 2000 服务器的条件。“SQL Server”中新的 XML 技术使存取数据变得轻而易 举，从而使编写“SQL Server”的脚本更加容易。有关“SQL Server”的详细信 息，请访问 SQL Server Developer enter（英文） ()。
让你的SQL运行得更快
最后出处： 作者：不祥 收录于：2002年8月17日
---- 人们在使用SQL时往往会陷入一个误区，即太关注于所得的结果是否正确，而忽略了不同的实现方法之间可能存在的性能差异，这种性能差异在大型的或是复杂的数据库环境中（如联机事务处理OLTP或决策支持系统DSS）中表现得尤为明显。笔者在工作实践中发现，不良的SQL往往来自于不恰当的索引设计、不充份的连接条件和不可优化的where子句。在对它们进行适当的优化后，其运行速度有了明显地提高！下面我将从这三个方面分别进行总结：
---- 为了更直观地说明问题，所有实例中的SQL运行时间均经过测试，不超过１秒的均表示为（< 1秒）。 ---- 测试环境-- ---- 主机：HP LH II ---- 主频：330MHZ ---- 内存：128兆
---- 操作系统：Operserver5.0.4 ----数据库：Sybase11.0.3 一、不合理的索引设计
----例：表record有620000行，试看在不同的索引下，下面几个 SQL的运行情况： ---- 1.在date上建有一非个群集索引
select count(*) from record where date >
''19991201'' and date < ''19991214''and amount > 2000 (25秒)
select date,sum(amount) from record group by date (55秒)
select count(*) from record where date >
''19990901'' and place in (''BJ'',''SH'') (27秒) ---- 分析：
----date上有大量的重复值，在非群集索引下，数据在物理上随机存放在数据页上，在范围查找时，必须执行一次表扫描才能找到这一范围内的全部行。 ---- 2.在date上的一个群集索引
select count(*) from record where date >
''19991201'' and date < ''19991214'' and amount > 2000 （14秒）
select date,sum(amount) from record group by date （28秒）
select count(*) from record where date >
''19990901'' and place in (''BJ'',''SH'')（14秒） ---- 分析：
---- 在群集索引下，数据在物理上按顺序在数据页上，重复值也排列在一起，因而在范围查找时，可以先找到这个范围的起末点，且只在这个范围内扫描数据页，避免了大范围扫描，提高了查询速度。 ---- 3.在place，date，amount上的组合索引 select count(*) from record where date >
''19991201'' and date < ''19991214'' and amount > 2000 （26秒）
select date,sum(amount) from record group by date （27秒）
select count(*) from record where date >
''19990901'' and place in (''BJ, ''SH'')（< 1秒）
---- 分析：
---- 这是一个不很合理的组合索引，因为它的前导列是place，第一和第二条SQL没有引用place，因此也没有利用上索引；第三个SQL使用了place，且引用的所有列都包含在组合索引中，形成了索引覆盖，所以它的速度是非常快的。
---- 4.在date，place，amount上的组合索引 select count(*) from record where date >
''19991201'' and date < ''19991214'' and amount > 2000(< 1秒)
select date,sum(amount) from record group by date （11秒）
select count(*) from record where date >
''19990901'' and place in (''BJ'',''SH'')（< 1秒） ---- 分析：
---- 这是一个合理的组合索引。它将date作为前导列，使每个SQL都可以利用索引，并且在第一和第三个SQL中形成了索引覆盖，因而性能达到了最优。 ---- 5.总结：
---- 缺省情况下建立的索引是非群集索引，但有时它并不是最佳的；合理的索引设计要建立在对各种查询的分析和预测上。一般来说：
---- ①.有大量重复值、且经常有范围查询
（between, >,< ，>=,< =）和order by、group by发生的列，可考虑建立群集索引； ---- ②.经常同时存取多列，且每列都含有重复值可考虑建立组合索引；
---- ③.组合索引要尽量使关键查询形成索引覆盖，其前导列一定是使用最频繁的列。 二、不充份的连接条件：
---- 例：表card有76行，在card_no上有一个非聚集索引，表account有191122行，在 account_no上有一个非聚集索引，试看在不同的表连接条件下，两个SQL的执行情况： select sum(a.amount) from account a,
card b where a.card_no = b.card_no（20秒） ---- 将SQL改为：
select sum(a.amount) from account a,
card b where a.card_no = b.card_no and a. account_no=b.account_no（< 1秒） ---- 分析：
---- 在第一个连接条件下，最佳查询方案是将account作外层表，card作内层表，利用card上的索引，其I/O次数可由以下公式估算为：
---- 外层表account上的22541页+（外层表account的191122行*内层表card上对应外层表第一行所要查找的3页）=595907次I/O
---- 在第二个连接条件下，最佳查询方案是将card作外层表，account作内层表，利用account上的索引，其I/O次数可由以下公式估算为： ---- 外层表card上的1944页+（外层表card的76行*内层表account上对应外层表每一行所要查找的4页）= 33528次I/O
---- 可见，只有充份的连接条件，真正的最佳方案才会被执行。 ---- 总结： ---- 1.多表操作在被实际执行前，查询优化器会根据连接条件，列出几组可能的连接方案并从中找出系统开销最小的最佳方案。连接条件要充份考虑带有索引的表、行数多的表；内外表的选择可由公式：外层表中的匹配行数*内层表中每一次查找的次数确定，乘积最小为最佳方案。
---- 2.查看执行方案的方法-- 用set showplanon，打开showplan选项，就可以看到连接顺序、使用何种索引的信息；想看更详细的信息，需用sa角色执行dbcc(3604,310,302)。 三、不可优化的where子句
---- 1.例：下列SQL条件语句中的列都建有恰当的索引，但执行速度却非常慢： select * from record where
substring(card_no,1,4)=''5378''(13秒) select * from record where amount/30< 1000（11秒）
select * from record where
convert(char(10),date,112)=''19991201''（10秒） ---- 分析：
---- where子句中对列的任何操作结果都是在SQL运行时逐列计算得到的，因此它不得不进行表搜索，而没有使用该列上面的索引；如果这些结果在查询编译时就能得到，那么就可以被SQL优化器优化，使用索引，避免表搜索，因此将SQL重写成下面这样：
select * from record where card_no like ''5378%''（< 1秒）
select * from record where amount < 1000*30（< 1秒）
select * from record where date= ''1999/12/01'' （< 1秒）
---- 你会发现SQL明显快起来！
---- 2.例：表stuff有200000行，id_no上有非群集索引，请看下面这个SQL： select count(*) from stuff where id_no in(''0'',''1'') （23秒） ---- 分析： ---- where条件中的''in''在逻辑上相当于''or''，所以语法分析器会将in (''0'',''1'')转化为id_no =''0'' or id_no=''1''来执行。我们期望它会根据每个or子句分别查找，再将结果相加，这样可以利用id_no上的索引；但实际上（根据showplan）,它却采用了\"OR策略\"，即先取出满足每个or子句的行，存入临时数据库的工作表中，再建立唯一索引以去掉重复行，最后从这个临时表中计算结果。因此，实际过程没有利用id_no上索引，并且完成时间还要受tempdb数据库性能的影响。
---- 实践证明，表的行数越多，工作表的性能就越差，当stuff有620000行时，执行时间竟达到220秒！还不如将or子句分开：
select count(*) from stuff where id_no=''0'' select count(*) from stuff where id_no=''1''
---- 得到两个结果，再作一次加法合算。因为每句都使用了索引，执行时间只有3秒，在620000行下，时间也只有4秒。或者，用更好的方法，写一个简单的存储过程： create proc count_stuff as declare @a int declare @b int declare @c int
declare @d char(10) begin
select @a=count(*) from stuff where id_no=''0'' select @b=count(*) from stuff where id_no=''1'' end
select @c=@a+@b
select @d=convert(char(10),@c) print @d
---- 直接算出结果，执行时间同上面一样快！ ---- 总结：
---- 可见，所谓优化即where子句利用了索引，不可优化即发生了表扫描或额外开销。 ---- 1.任何对列的操作都将导致表扫描，它包括数据库函数、计算表达式等等，查询时要尽可能将操作移至等号右边。
---- 2.in、or子句常会使用工作表，使索引失效；如果不产生大量重复值，可以考虑把子句拆开；拆开的子句中应该包含索引。
---- 3.要善于使用存储过程，它使SQL变得更加灵活和高效。
---- 从以上这些例子可以看出，SQL优化的实质就是在结果正确的前提下，用优化器可以识别的语句，充份利用索引，减少表扫描的I/O次数，尽量避免表搜索的发生。其实SQL的性能优化是一个复杂的过程，上述这些只是在应用层次的一种体现，深入研究还会涉及数据库层的资源配置、网络层的流量控制以及操作系统层的总体设计。
Access 如何调用 Excel 函数 ACCESS与WORD、EXCEL
用代码打开密码为123456的EXCEL文件 Dim EXL As New Excel.Application
EXL.Workbooks.Open \"C:\\Book.xls\, , , \"123456\这里是写入权限密码\" 将文本插入WORD文档
使用 InsertAfter 或 InsertBefore 方法可以在 Selection 或 Range 对象前后插入文字。下面的示例在活动文档结尾处插入文字。
ActiveDocument.Content.InsertAfter Text:=\" the end.\" 下面的示例在所选内容前插入文字。
Selection.InsertBefore Text:=\"new text \"
Range 对象或 Selection 对象在使用了 InsertBefore 或 InsertAfter 方法之后，会扩展并包含新的文本。使用 Collapse 方法可以将 Selection 或 Range 折叠到开始或结束位置。
从ACCESS中打印一个WORD文档 PrivateSub命令0_Click()
Dim WkWord As New Word.Application Dim WkDoc As Word.Document
Set WkDoc = WkWord.Application.Documents.Open(\"c:\\my documents\\文档.doc\") WkDoc.PrintOut False WkDoc.Close WkWord.Quit End Sub
在printout后面加上FLASE，会等打完之后再关闭。 打印Word文档的VBA代码
Private Declare Function ShellExecuteAny Lib \"shell32.dll\" Alias \"ShellExecuteA\" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lp String, ByVal lpParameters As Any, ByVal lpDirectory As Any, ByVal nShowCmd As Long) As Long Const SW_SHOWMINNOACTIVE = 7 Sub PrintAny As String) Dim Ret As Long
Ret = ShellExecuteAny(Me.hwnd, \"print\, ByVal 0&, ByVal 0&, SW_SHOWMINNOACTIVE) End Sub
Private Sub Command0_Click()
If Dir(CurrentProject.Path & \"\\\" & \"企业管理.DOC\") <> \"\" Then PrintAny & \"\\\" & \"企业管理.DOC\" Else
MsgBox \"在【\" & CurrentProject.Path & \"】下没有该文件！\" End If End Sub
创建完美报表
Access作为Microsoft Office办公软件包中的一部分，以其友好的操作界面和卓越的数据管理能力而日益成为中小型管理信息系统的理想开发环境，在各行各业得到了广泛的应用。但在应用中我们发现，Access在报表输出上还存在一些不足：尽管它可以很好地处理一些基于页面的报表，但对一些复杂报表或一些特殊报表的处理能力却很难令人满意，这主要是由于Access系统附带的报表设计器太过直观，缺少了程序设计和文字处理所需的必要的灵活性。而Word作为Microsoft Office家族中的重要成员——字处理器，其强大的文字处理功能正好可以弥补Access在报表方面的不足。这就使得我们自然而然地想到将Access与Word有机地结合起来，利用Access的数据处理功能进行数据的录入、查询、存储，而利用Word的字处理功能进行各种报表的打印输出。幸好，微软在设计Office的时候就已经为我们提供了一种在诸如Access、Word、Excel等应用程序之间通信的机制，使得这种想法得以实现。 一、基本原理
对于一些复杂的或有特殊要求的查询，用ADO（ActiveX数据对象）来处理要比用Access本身提供的查询管理
器更灵活一些。所以我们的基本思路是：用ADO执行一条或多条特定的SQL查询，生成我们所需要的一个或多个Recordset，再将这些Recordset中的数据逐条输出到Word文档，然后就可以用程序或手工控制Word文档的格式，达到我们的特殊要求。这听起来挺麻烦，可只要了解了其工作原理，实际操作却很简单。下面就分别以在Access中和在Word中的具体操作为例进行介绍。 二、在Access中应用ADO将数据输出到Word 1. 系统配置
系统软件：Microsoft Windows 9x/NT/2000；Microsoft Access 2000；Microsoft Word 2000。 样例数据库：“C:\\Program Files\\Microsoft Office\\Office\\Samples\\Northwind.mdb”，Office 2000中包含的例子。可将其中的“产品”表复制到一个新的数据库中，如“D:\\db1.mdb”。
窗 体：在数据库“D:\\db1.mdb”中新建窗体“窗体1”,其中只包含1个命令按钮“命令0”。 引用ADO：按Alt+F11进入Visual Basic编辑器，执行“工具”->“引用”命令，在弹出的引用窗体中选择“Microsoft ActiveX Data Objects 2.1”或更高版本。 引用Word：再次执行命令“工具”->“引用”，在弹出的引用窗体中选择“Microsoft Word 9.0 Object Library”。 2. 代码详解
在“窗体1”的设计模式下右键单击“命令0”按钮，选择“事件生成器”，进入Visual Basic编辑器，创建过程“Private Sub 命令0_Click()”，其代码如下： Sub 命令0_Click() '输入表格标题
Title = InputBox(vbCrLf & vbCrLf & \"请输入表格标题：\表格标题\公司产品报价单\") If Title = \"\" Then Title = \"XX公司产品报价单\" '步骤1：建立数据连接cnn
'由于数据库已经打开，所以直接应用CurrentProject.Connection就可以建立连接 Set cnn = New ADODB.Connection
Set cnn = CurrentProject.Connection
'步骤2：用SQL语句创建记录集rs Set rs = New ADODB.Recordset '设定游标类型与锁定类型
rs.CursorType = adOpenKeyset rs.LockType = adLockOptimistic
'制定特定的查询条件，可以是任何有效的SQL查询，甚至包括多表、多条件等复杂的查询，查询条件也常常从窗体取得
SQL = \"select 产品名称,单位数量,单价,库存量 from 产品 where 单价>10.00\" '创建记录集rs rs.Open SQL, cnn '统计字段数及记录数
total_fields = rs.Fields.Count total_records = rs.RecordCount
'步骤3：建立Word文档对象
Set mywdapp = CreateObject(\"word.application\") '调整Word窗口大小
mywdapp.WindowState = wdWindowStateNormal '生成新的Word文档实例 mywdapp.Documents.Add '设置视图为页面视图
mywdapp.ActiveWindow.View.Type = wdPrintView '转到Word视图，显示文档生成过程 mywdapp.Visible = True mywdapp.Activate '设置文档(表格)字体
mywdapp.ActiveDocument.Range.Font.Size = \"9\"
'步骤4：将记录集rs中的字段名称和字段内容输出到Word，各字段之间用制表符分隔
'输出字段名称
For I = 0 To total_fields - 2
mywdapp.Selection.TypeText Text:=rs.Fields(I).Name & vbTab Next I
'最后一个字段名称后加回车符
mywdapp.Selection.TypeText Text:=rs.Fields(total_fields - 1).Name & vbCrLf '逐条输出字段内容 Do While Not rs.EOF
For I = 0 To total_fields - 2 tmpstr = rs.Fields(I).value
If rs.Fields(I).Name = \"单价\" Then tmpstr = Format(tmpstr, \"####.00\") End If
mywdapp.Selection.TypeText Text:=tmpstr & vbTab Next I
'一条记录的最后一个字段后加回车符
mywdapp.Selection.TypeText Text:=rs.Fields(total_fields - 1).value & vbCrLf rs.MoveNext Loop
'步骤5：关闭记录集 rs.Close
Set rs = Nothing
'步骤6：对Word中的数据进行格式化处理 '选定文本，将其转换为表格 '设置视图为普通视图
mywdapp.ActiveWindow.View.Type = wdNormalView '将光标移动到文档末尾
mywdapp.Selection.EndKey Unit:=wdStory '删除文档末尾多余的回车符
mywdapp.Selection.Delete Unit:=wdCharacter, Count:=1 '选中全部内容
mywdapp.Selection.WholeStory '将所选内容转换为表格
mywdapp.Selection.ConvertToTable Separator:=wdSeparateByTabs, DefaultTableBehavior:=wdWord8TableBehavior '将光标移动到文档开头
mywdapp.Selection.HomeKey Unit:=wdStory '选定表格对象
Set Temp_Table = mywdapp.ActiveDocument.Tables(1)
'根据需要对表格进行处理，这是制作表格格式的关键，可反复调试
'本例只简单地设置了表格居中、自动调整表格列宽、表头居中、标题行重复、设置表格边框线、设置表格纵向居中
Temp_Table.Rows.Alignment = wdAlignRowCenter Temp_Table.AutoFitBehavior wdAutoFitContent
Temp_Table.Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter Temp_Table.Rows(1).Range.Rows.HeadingFormat = wdToggle
Temp_Table.Borders(wdBorderLeft).LineWidth = wdLineWidth150pt Temp_Table.Borders(wdBorderRight).LineWidth = wdLineWidth150pt Temp_Table.Borders(wdBorderTop).LineWidth = wdLineWidth150pt Temp_Table.Borders(wdBorderBottom).LineWidth = wdLineWidth150pt
Temp_Table.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter '将光标移动到文档开头
mywdapp.Selection.HomeKey Unit:=wdStory '拆分表格
mywdapp.Selection.SplitTable
mywdapp.Selection.Font.Name = \"黑体\" '插入标题
mywdapp.Selection.TypeText Text:=Title & vbCrLf mywdapp.Application.ScreenRefresh '刷屏 '转到Acdess视图，显示结束对话框 mywdapp.Visible = False
Msg = \"数据提取完毕。\" & vbCrLf & vbCrLf
Msg = Msg & \"总记录数=\" & total_records & \" 条\" MsgBox Msg, vbOKOnly, \"数据提取完毕\" '转到Word视图，显示文档 mywdapp.Visible = True mywdapp.Activate End Sub
三、在Word中应用ADO直接提取Access数据库中的数据 1. 系统配置
系统软件: Microsoft Windows 9x/NT/2000；Microsoft Word 2000。 样例数据库：“C:\\Program Files\\Microsoft Office\\Office\\Samples\\Northwind.mdb”，Office 2000中包含的例子。 引用ADO：按Alt+F11进入Visual Basic编辑器，执行命令“工具”->“引用”，在弹出的引用窗体中选择“Microsoft ActiveX Data Objects 2.1”或更高版本。 2. 代码详解
进入Visual Basic编辑器，创建过程“Sub Word_ADO()”，其代码如下：
Sub Word_ADO() '输入表格标题
Title = InputBox(vbCrLf & vbCrLf & \"请输入表格标题：\表格标题\公司产品报价单\") If Title = \"\" Then Title = \"XX公司产品报价单\" '步骤1：建立数据连接cnn
'打开连接,示例数据库：C:\\Program Files\\Microsoft Office\\Office\\Samples\\Northwind.mdb Set cnn = New ADODB.Connection
cnn.Provider = \"Microsoft.jet.oledb.4.0\"
cnn.Open \"C:\\Program Files\\Microsoft Office\\Office\\Samples\\Northwind.mdb\"
'步骤2：用SQL语句创建记录集rs Set rs = New ADODB.Recordset rs.CursorType = adOpenKeyset rs.LockType = adLockOptimistic
SQL = \"select 产品名称,单位数量,单价,库存量 from 产品 where 单价>10.00\" rs.Open SQL, cnn
total_fields = rs.Fields.Count total_records = rs.RecordCount
ActiveDocument.Range.Font.Size = \"9\"
'步骤3：将记录集rs中的字段名称和字段内容输出到Word文档，各字段之间用制表符分隔 For I = 0 To total_fields - 2
Selection.TypeText Text:=rs.Fields(I).Name & vbTab Next I
Selection.TypeText Text:=rs.Fields(total_fields - 1).Name & vbCrLf Do While Not rs.EOF
For I = 0 To total_fields - 2
tmpstr = rs.Fields(I).value
If rs.Fields(I).Name = \"单价\" Then tmpstr = Format(tmpstr, \"####.00\") End If
Selection.TypeText Text:=tmpstr & vbTab Next I
Selection.TypeText Text:=rs.Fields(total_fields - 1).value & vbCrLf rs.MoveNext Loop
'步骤4：关闭记录集和连接 rs.Close cnn.Close
Set rs = Nothing Set cnn = Nothing
'步骤5：对Word中的数据进行格式化处理 ActiveWindow.View.Type = wdNormalView Selection.EndKey Unit:=wdStory
Selection.Delete Unit:=wdCharacter, Count:=1 Selection.WholeStory
Selection.ConvertToTable Separator:=wdSeparateByTabs, DefaultTableBehavior:=wdWord8TableBehavior Selection.HomeKey Unit:=wdStory
Set Temp_Table = ActiveDocument.Tables(1) Temp_Table.Rows.Alignment = wdAlignRowCenter Temp_Table.AutoFitBehavior wdAutoFitContent
Temp_Table.Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter Temp_Table.Rows(1).Range.Rows.HeadingFormat = wdToggle
Temp_Table.Borders(wdBorderLeft).LineWidth = wdLineWidth150pt Temp_Table.Borders(wdBorderRight).LineWidth = wdLineWidth150pt Temp_Table.Borders(wdBorderTop).LineWidth = wdLineWidth150pt Temp_Table.Borders(wdBorderBottom).LineWidth = wdLineWidth150pt
Temp_Table.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter Selection.HomeKey Unit:=wdStory Selection.SplitTable
Selection.Font.Name = \"黑体\"
Selection.TypeText Text:=Title & vbCrLf Application.ScreenRefresh
Msg = \"数据提取完毕。\" & vbCrLf & vbCrLf
Msg = Msg & \"总记录数=\" & total_records & \" 条\" MsgBox Msg, vbOKOnly, \"数据提取完毕\" End Sub
四、两种方法的比较 1. 适用性
上述两种方法都可以满足我们制作特殊报表的要求，但笔者认为Access+ADO+Word更适合于进行多表的复杂查询，编制的东西也更有“程序味”，若既要求录入数据又要求输出特殊报表，可采用该方法；而Word+ADO非常适合于处理表格形式固定的报表，不负责数据录入，只要求输出报表的情况。 2. 复杂性
在程序的编写上，这两种方法也有一些小的差别：前者比后者略微复杂些，在对一些特殊命令的处理上两者也有一些不同。
3. 对报表格式的控制
由于Word本身就是个字处理软件，所以它对文档的控制也就比Access对文档的控制更容易、更灵活，若对表格要求很高，采用后者会更加有效。
4. 处理速度
两者的处理速度基本相当。上述两段程序采用的都是先输出数据，再将其转换为表格的方法，这样处理主要是基于速度上的考虑，特别是对于几百条乃至上千条的记录，其处理速度是比较快的。另外，也可以直接向文档中输出表格，再逐行增加表格或逐单元格地填写数据，但对于大的报表来讲，其速度将大打折扣。影响处理速度的因素是多方面的，主要瓶颈是在Word中，如表格的复杂程度、页面视图、对象的使用，等等。 五 总结
上述的例子主要介绍了用ADO调用数据库的方法及在Access中调用Word的方法，其实这些方法在Office中是通用的，你可以将它应用在Access、Word、Excel中，甚至可以应用在Outlook中。
对于美的追求是永无止境的，如果你对Access的报表设计器不满意，不妨试一试上述两种方法，相信它们一定会满足你哪怕是近乎苛刻的需求，使你的报表令上司更满意，令同事更羡慕，令你自己更欣慰。
API 函数集锦
3、如何以某种颜色填充某区域？ *API函数声明
Private Declare Sub FloodFill Lib \"gdi32\" _ (ByVal Hdc As Long, ByVal X As Long, ByVal Y As _ Long, ByVal crColor As Long 注释：设(fillx,filly)为此区域内任一点 注释：Color为某种颜色
FloodFill Picture1.Hdc, fillx, filly,Color 4、如何关闭计算机？ *API函数声明
Declare Function ExitWindows Lib \"User\" (ByVal dwReturnCode As Long, ByVal wReserved As Integer) As Integer 注释：执行 Dim DUMMY
DUMMY=ExitWindows(0，0)
7、如何得知TextBox中文字所有的行数？ *API函数声明
Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Public Const EM_GETLINECOUNT = &HBA 注释：在程序中调用
LineCnt = SendMessage(ctl.hwnd, EM_GETLINECOUNT, 0, 0) 注释：LineCnt即为此TextBox的行数。 8、如何设置ListBox的水平卷动轴的宽度？ *API函数声明
Const LB_SETHORIZONTALEXTENT = &H194
Private Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _ lParam As Any) As Long 注释：调用
Call SendMessage(List1.hwnd, LB_SETHORIZONTALEXTENT, 400, ByVal 0&) 注释：注意400是以象素为单位，你可以根据情况自行设定。 9、如何交换鼠标按键？ *API函数声明
Declare Function S Lib \"user32\" _ (ByVal bS long)
要交换鼠标按键，将bSwap参数设置为True。要恢复正常设置，将bSwap设置为False。 然后调用函数就可以交换和恢复鼠标按键了。
11、怎样找到鼠标指针的XY坐标？ *API函数声明 Type POINTAPI x As Long y As Long End Type
Declare Function GetCursorPos Lib \"user32\" (lpPoint As POINTAPI) As Long
调用：
GetCursorPos z print z.x print z.y
12、怎样获得和改变双击鼠标的时间间隔？ 获得鼠标双击间隔时间：
Public Declare Function GetDoubleClickTime Lib \"user32\" Alias _ \"GetDoubleClickTime\" () As Long
获得鼠标双击间隔时间：
Declare Function SetDoubleClickTime Lib \"user32\" Alias \"SetDoubleClickTime\" (ByVal wCount As Long) As Long
注释：注意：这种改变将影响到整个操作系统 以上两个函数都可精确到毫秒级。 13、在程序中如何打开和关闭光驱门？ *API函数声明如下:
Private Declare Function mciSendString Lib \"winmm.dll\" Alias \"mciSendStringA\" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long 注释：调用时的代码如下 Dim Ret As Long
Dim RetStr As String 注释：打开光驱门
Ret = mciSendString(\"set CDAudio door open\RetStr, 0, 0) 注释：关闭光驱门
Ret = mciSendString(\"set CDAudio door closed\RetStr, 0, 0) 14、如何获得Windows启动方式?
在Form1中加入一个CommandButton、一个Label并加入如下代码:
Private Declare Function GetSystemMetrics Lib \"user32\" (ByVal nIndex As Long) As Long
Const SM_CLEANBOOT = 67 Private Sub Command1_Click()
Select Case GetSystemMetrics(SM_CLEANBOOT) Case 1
Label1 = \"安全模式.\" Case 2
Label1 = \"支持网络的安全模式.\" Case Else
Label1 = \"Windows运行在普通模式.\" End Select End Sub
15、怎样使Ctrl-Alt-Delete无效？
*API函数声明
Private Declare Function SystemParametersInfo Lib \"user32\" Alias \"SystemParametersInfoA\" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long 编写如下函数：
Sub DisableCtrlAltDelete(bDisabled As Boolean) Dim X As Long
X = SystemParametersInfo(97, bDisabled, CStr(1), 0) End Sub
使Ctrl-Alt-Delete无效 ： Call DisableCtrlAltDelete(True) 恢复Ctrl-Alt-Delete ：
Call DisableCtrlAltDelete(False)
21、怎样确定系统是否安装了声卡？ *API函数声明：
Declare Function waveOutGetNumDevs Lib \"winmm.dll\" Alias \"waveOutGetNumDevs\" () As Long
代码如下：
Dim I As Integer
I = waveOutGetNumDevs()
If I > 0 Then MsgBox \"你的系统可以播放声音。\vbInformation, \"声卡检测\" Else
MsgBox \"你的系统不能播放声音。\vbInformation, \"声卡检测\" End If
22、如何找到CD-ROM驱动器的盘号？
下面的函数将检查你计算机所有的驱动器看是否是 CD-ROM，如果是就返回驱动器号，如果没有就返回空字符 Public Function GetCDROMDrive() As String
Dim lType As Long,I As Integer,tmpDrive as String,found as Boolean On Error GoTo errL For I = 0 To 25
tmpDrive = Chr(65 + I) & \":\"
lType = GetDriveType(tmpDrive) 注释：Win32 API 函数 If (lType = DRIVE_CDROM) Then 注释：Win32 API 常数 found = True Exit For End If Next
If Not found Then tmpDrive = \"\" BI_GetCDROMDrive = tmpDrive exit Function
errL: msgbox error$ End Function
23、如何将文件放入回收站？ **API函数声明
Public Type SH hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer
fAnyOperationsAborted As Long hNameMappings As Long lpszProgressTitle As Long End Type
Public Declare Function SH Lib _ \"shell32.dll\" Alias \"SH\" (lpFileOp As SH) As Long Public Const FO_DELETE = &H3
Public Const FOF_ALLOWUNDO = &H40 注释：调用
Dim Shop As SH, str string With Shop
.wFunc = FO_DELETE
.pFrom = strFile + Chr(0) .fFlags = FOF_ALLOWUNDO End With
24、VB中如何使用未安装的字体？
Declare Function AddFontResource Lib \"gdi32\" Alias \"AddFontResourceA\" (ByVal lp As String) As Long
Declare Function RemoveFontResource Lib \"gdi32\" Alias \"RemoveFontResourceA\" (ByVal lp As String) As Long 增加字体：
Dim lResult As Long
lResult = AddFontResource(\"c:myAppmyFont.ttf\") 删除字体：
Dim lResult As Long
lResult = RemoveFontResource(\"c:myAppmyFont.ttf\") 25、如何得知键盘number lock等开关键的状态？
Declare Function GetKeyState Lib \"User32\" (ByVal lngVirtKey As Long) As Integer GetKeyState(vbKeyNumLock) GetKeyState(vbKeyCapital)
ACCESS数据页 数据访问页知识
刘彦青 编译自PCWorld
自从Microsoft首先推出它的桌面数据库程序以来的将近十年的时间里，Access走过了很长的一段路。Access 2002更多是向Internet和企业内部发展，它提供更多的方法来创建基于Web的应用程序所驱动的数据。使用经改进的Data Access Page设计程序，就算是非程序员也可以快速创建连到Access 和SQL Server数据库的Web页。用户现在可以输出报表、表格，以及XML格式的查询。为了更好的进行数据分析，Microsoft使生成Pivot Tables和图表变得更容易，并保存浏览器友好Data Access Pages。默认情况下，Access 2002的文件向后兼容Access 2000的文件，但是你也可以选择使用一个新能提供更好的安全性的文件格式。
受欢迎的改进：
● 更简单的 SQL 连接。
● 生成Pivot tables 和图表变得更容易。 ● 更简单的数据访问页面(web)。 ● 对XML 和XSL 支持。 ● 可编辑文件格式。
尚待改进的功能：
● 不能重复进入向导。
● 在pivot tables中不能撤销上一步操作
首先被在Access 2000中引入的Data Access Pages是表格和报表的HTML/XML版本，他们是此版本中许多新功能的核心。现在你可以把任何表格和报表保存为一个Data Access Page，并可以立即得到一个Web页，虽然仅仅在Internet Explorer 5.0或它以上实现。（Microsoft的目标对准企业内部局域网，B2B，或者带Access 2002的Web 支持的in-house应用程序。虽然Access页可以被配置到Internet网站，但是它必须配置Remote Data Services。）
我们发现这个新的Data Access Page Designer是一个快速创建基于数据的页的很棒的方法。如果你正使用IE 5.5作为你的浏览器，那么Data Access Page Designer现在支持一次选择多个控件进行移动和排列操作。我们也很喜欢Designer中的undo(取消)功能。Data Access页有一个工具条可以通过用户选择一个字段并点击filter（过滤器）来执行过滤的功能。这个工具条总是显示出表名称，记录数，以及当前集合中的所有记录。我们也很喜欢Access小组内部称之为\"stable cursors\"的特性，当在一个Data Access Page中进行记录更新时，它保持过滤器处于激活状态。而在Access 2000中，当你更新字段时，过滤器就被废除。 Access的这个版本的一个目的是方便SQL Server用户。如果你使用SQL Server 2000，那么你可以利用Access's的扩展特性，例如在字段上加上友好的标题。而在此之前，你必须在使用SQL表格的每一张表上创建字段标签，但是使用扩展特性，你只需要创建一次标题，所有的表或页都将有新标签。使用经过改进的Table Wizard，链接表格到SQL Server 7.0 或者 SQL 2000数据库变得更容易了。如果你想直接向SQL Server展开，那么带SQL Server 2000桌面引擎的Access将会使兼容数据库的开发变得更容易。
对于使用Access作为它们的数据存储工具的开发者来说，Access 2002现在支持XML导入和导出。两个公司之间可以通过XML格式交换数据，只要他们双方都有Access 2002，这对于B2B应用程序来说是很实用的。Access 2002增加存储XML作为一个单独或者嵌入文件的选择，同时保存使用的介绍信息在客户端（HTML）或者基于服务器（ASP）的应用程序中。你也可以连接Data Access Pages到XML文件中，使用户不用连接服务器就可以使用数据。这在使用很多静态数据例如定价表或者每月报表时，可以减少数据库和网络通信量。开发人员可以创建一个完全的带Data Access Pages的应用程序，此程序可以在一台使用IE 5的脱机浏览的机器上以只读方式使用XML数据。开发人员也可以设定一个应用程序与IE 5 和 Data Access pages一起使用本地MSDE（Microsoft Date Engine）。使用IE 5和MSDE，可以在客户机上创建一个完整的数据入口程序。
创建Pivot表来分析和表现数据是Access 2000引入的一个功能，但是新用户很难发现它。而使用
Access 2002，你现在可以把表看作PivotTables或者PivotCharts，就想看做设计或数据表视图一样容易。要创建PivotChart或者Table，只需把你需要分析的字段拖到指定区域即可。你可以用鼠标右键点击数据，并设置分组和过滤。要创建有意义的Pivot表需要经过一定的练习，不过我们发现用PivotTable和Chart视图做实验很容易。
Access 2002增加了一些应用程序开发人员将很感兴趣的事件。开发人员现在可以得到处理例如删除，更新和插入等用户操作前后的控制数据。配置Data Access页也因为使用ConnectionFile特性而变得简单了，这个特性可以为所有页指定一个共同的连接（我们没能测试这个功能）。
这些年，每一个新的Access版本都带来一个新的文件格式，Access 2002也不例外，只是默认情况下，它仍然使用Access 2000的 .MDB文件格式。更新的格式是可选的，它允许开发人员存储文件为MDE或者ADE文件格式，它编译任何Visual Basic代码，并且为了更好的安全性，在Access database文件（.MDB）或者Access Project 文件 (.ADP)中删除源代码。这也意味着最终用户不能在Access中装载私人数据文件，也不能创建他们自己的报表和应用程序。 Access 2002提供了无论是新手还是专业用户都很满意的新特性的集合。我们特别喜欢它的连到SQL数据源以及创建PivotTables和Charts的简易性。它增加了更多开发者友好特性，例如新的文件格式，新事件，更好的SQL和XML支持，并且Access 2002为几乎任何工作组或企业应用程序提供了一个强大的后端。
如何用vba判断EXCEl的单元格是否是公式？？ 用HasFormula
如help中的：
Set rr = Application.InputBox( _
prompt:=\"Select a range on this worksheet\ Type:=8)
If rr.HasFormula = True Then
MsgBox \"Every cell in the selection contains a formula\" End If
如何在ACCESS的VBA中向EXCEL的某一个单元格写数据 Private Sub 命令8_Click() on error goto err_proc
Dim oapp As Excel.Application, oappwork As Excel.Workbook, oappwork_Sheet1 As Excel.Worksheet Set oapp = CreateObject(\"Excel.Application\")
‘在后台打开操作，不显示出来设置oapp.Visible = False、需要显示的话，就设置true oapp.Visible = True
Set oappwork = oapp.Workbooks.Open(\"c:\\book1.xls\") Set oappwork_Sheet1 = oappwork.Worksheets(\"Sheet1\") oappwork_Sheet1.Cells(2, 1) = \"AAA\" oappwork_Sheet1.Cells(2, 2) = \"BBB\" err_proc:
on error resume next oappwork.Close (False) oapp.Quit
Set oappwork_Sheet1 = Nothing
Set oappwork = Nothing Set oapp = Nothing End Sub
因篇幅问题不能全部显示，请点此查看更多更全内容
Copyright © 2019- huatuo0.cn 版权所有 湘ICP备2023017654号-2
违法及侵权请联系：TEL:199 18 7713 E-MAIL:2724546146@qq.com
本站由北京市万商天勤律师事务所王兴未律师提供法律服务