感谢CSDN的版主允许我重新回到这里来,一年来我以平均81分的成绩考取了北京某高校的博士,并因博士英语考试前10名而免修免考,所有博士课程学完并每门课程达到80分以上,同世界500强打了一场官司(已获胜),参加了12年未见面的大学同学聚会,编写了应用程序2套,培训了两个VB培训班,最近就要进行开题报告了,所以可能很忙,不过有时间我会同大家在这里交流的,下面是我以前写的一些小文章,希望大家能喜欢,真诚地希望同大家成为朋友,尽管我很菜,但我是无私的。下面还需要帮我,否则这里不允许我发贴超过3次。用VB制作软键盘 青岛德固萨化学有限公司 杜运庆 看见微软智能拼音输入法的小键盘了吗?那东东可以在输入的时候用代替键盘。
当不希望操作员使用键盘的时候,那么你就要考虑为她或他提供软键盘了。下面我们就用VB来做这
个软键盘。
准备工作:
先画两个窗体Form1和Form2,Form2是作为接收按键测试用的,在上面放一个文本框Text1,把
Text1的MultiLine属性设为True,ScrollBars设为3-Both,然后写入如下代码:
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal
fEnable As Long) As Long
Private Sub Form_Load()
'调整大小
Me.Width = Screen.Width * 0.9
Me.Height = Screen.Height * 0.9
Form1.Show
'禁止鼠标和键盘输入
EnableWindow Text1.hwnd, False
End Sub
Private Sub Form_Resize()
'调整文本框大小
Text1.Top = 0
Text1.Left = 0
Text1.Width = Me.ScaleWidth
Text1.Height = Me.ScaleHeight
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Form1作为小键盘用,把它的BorderStyle设为3-Fixed Dialog,把ControlBox属性设
为False,这样小键盘就没有标题栏了。Form1得跟微软智能拼音输入法的小键盘完全一样的大小
的窗体,经笔者的计算长×高是5310×2130。然后放上10个按扭,其中九个的Caption分别是
Tab、Caps、↑Shift、Ins、Del、(空格)、Esc、Enter和←(退格)。它们的位置和大小如下设
置: Caption Top Left Height Width Name ↑Shift 1230 0 400 840 Command1
Caps 828 0 400 560 Command2
Tab 410 0 400 480 Command3
Ins 1640 0 400 570 Command4
Del 1640 870 400 550 Command5
(空格) 1640 1400 400 2565 Command6
Esc 1640 4670 400 550 Command7
Enter 820 4590 400 630 Command9
←(退格) 820 4590 400 630 Command10 接下来做一个Height为400、Width为360的按扭Command8,Caption为A a(注意中间是两个空
格,这一点非常重要!),由于按扭太小,系统会自动换行,看上去A在a的上面。复制该按扭,然
后在窗体上粘贴,程序会提示你是否产生控件数组,选择是,Command8变成了Command8(0),新产
生的按扭为Command8(1),一直粘贴,直到Command8(46),修改它们的Caption使之与键盘上的其
它键一样。这里要注意几点:
1、按扭的字体为“小五”,有几个键显示的结果是纵向并排,可把字体设为“六号”,使之横向
并排,字体使用宋体,否则↑和←显示的不漂亮。
2、&符号要使用两个,即 && 7(&&与7之间只有一个空格),确保每个按扭的Caption的长度为四
个字母。
3、把窗体的MousePointer设为15 - Size All,以便在运行的时候移动小键盘。
4、把所有按键的MousePointer都设为99 - Custom,而MouseIcon设为手形指针。
5、由于要指示Shift是否按下,Command1的Style属性设置为1-Graphical。
6、Form2的StartUpPosition属性设置为2-屏幕中心。
我们把Command8(x)的这些键暂时叫做“普通键”。由于前面已经定位了9个特殊键,所以可以通
过菜单栏的“格式”里面的“顶端对齐”、“相同水平间距”等选项很容易地把47个普通键放到与
键盘对应的位置上。另外,为了显示CAPS LOCK的状态,我们在窗体上加一个标签Label1,把它的
AutoSize属性设为True,Caption属性设为●,它的Top、Left、Height和With分别为1340、
4800、180和180。
接下来是写代码了,这里主要用了SendMessage发送消息的API函数,由于按扭CAPTION设置的巧
妙,所以47个普通键的代码就用的很少。所有代码如下:
'API声明
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal
hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private 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)
Private Declare Sub GetKeyboardStateByString Lib "user32"
Alias "GetKeyboardState" (ByVal pbKeyState As String)
Private Declare Sub SetKeyboardStateByString Lib "user32"
Alias "SetKeyboardState" (ByVal lppbKeyState As String)
'常数
Const VK_CAPITAL = &H14
Const WM_CHAR = &H102
Const HTCAPTION = 2
Const WM_NCLBUTTONDOWN = &HA1
Const WM_KEYDOWN = &H100
Const VK_DELETE = &H2E
Const VK_INSERT = &H2D
'定义变量
Dim rc as Long Private Sub Command1_Click()
'Shift键
If Command1.BackColor = &H8000000B Then
Command1.BackColor = &H80000005
Else
Command1.BackColor = &H8000000B
End If
End Sub '退格键
Private Sub Command10_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_CHAR, 8, 1)
End Sub '大小写转换键
Private Sub Command2_MouseDown(Button As Integer, Shift As Integer, X As
Single, Y As Single)
Dim CAPITALKey As String * 256
CAPITALKey = Space$(256)
GetKeyboardStateByString (CAPITALKey)
If Label1.ForeColor = vbBlack Then
Label1.ForeColor = vbGreen
Mid$(CAPITALKey, VK_CAPITAL + 1, 1) = Chr$(1)
Else
Label1.ForeColor = vbBlack
Mid$(CAPITALKey, VK_CAPITAL + 1, 1) = Chr$(0)
End If
Call SetKeyboardStateByString(CAPITALKey)
End Sub 'TAB键
Private Sub Command3_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_CHAR, 9, 1)
End Sub 'Ins键
Private Sub Command4_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_KEYDOWN, VK_INSERT, &H510001)
End Sub 'Del键
Private Sub Command5_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_KEYDOWN, VK_DELETE, 1)
End Sub '空格键
Private Sub Command6_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_CHAR, 32, 1)
End Sub 'Esc键
Private Sub Command7_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_CHAR, 27, 1)
End Sub '普通键
Private Sub Command8_Click(Index As Integer)
Dim keyx As Integer
If Command1.BackColor = &H80000005 Xor Label1.ForeColor = vbGreen Then
keyx = Asc(Mid(Command8(Index).Caption, 1, 1))
Else
keyx = Asc(Mid(Command8(Index).Caption, 4, 1))
End If
rc = SendMessage(Form2.Text1.hwnd, WM_CHAR, keyx, 1)
Command1.BackColor = &H8000000B
End Sub '回车键
Private Sub Command9_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_CHAR, 13, 1)
End Sub '让小键盘在最前面
Private Sub Form_Load()
rtn = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3)
End Sub '移动没有标题的小键盘
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y
As Single)
If Button = 1 Then
Dim ReturnVal As Long
X = ReleaseCapture()
ReturnVal = SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If
End Sub
最后要提醒您的是:如果你要用于多个Text要做如下两步:
1、把FORM2中的EnableWindow Text1.hwnd, False去掉。
2、把软键盘代码中所有的Form2.Text1.Hwnd换成如下代码:Form2.ActiveControl.hwnd
瞧,超酷的小键盘就这样做成了!该程序在VB6+WIN98下运行通过,如果你需要本事例的源代码,
请在本文见报后到第一VB论坛的首页下载吧!网址是http://www.vbgood.com
当不希望操作员使用键盘的时候,那么你就要考虑为她或他提供软键盘了。下面我们就用VB来做这
个软键盘。
准备工作:
先画两个窗体Form1和Form2,Form2是作为接收按键测试用的,在上面放一个文本框Text1,把
Text1的MultiLine属性设为True,ScrollBars设为3-Both,然后写入如下代码:
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal
fEnable As Long) As Long
Private Sub Form_Load()
'调整大小
Me.Width = Screen.Width * 0.9
Me.Height = Screen.Height * 0.9
Form1.Show
'禁止鼠标和键盘输入
EnableWindow Text1.hwnd, False
End Sub
Private Sub Form_Resize()
'调整文本框大小
Text1.Top = 0
Text1.Left = 0
Text1.Width = Me.ScaleWidth
Text1.Height = Me.ScaleHeight
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Form1作为小键盘用,把它的BorderStyle设为3-Fixed Dialog,把ControlBox属性设
为False,这样小键盘就没有标题栏了。Form1得跟微软智能拼音输入法的小键盘完全一样的大小
的窗体,经笔者的计算长×高是5310×2130。然后放上10个按扭,其中九个的Caption分别是
Tab、Caps、↑Shift、Ins、Del、(空格)、Esc、Enter和←(退格)。它们的位置和大小如下设
置: Caption Top Left Height Width Name ↑Shift 1230 0 400 840 Command1
Caps 828 0 400 560 Command2
Tab 410 0 400 480 Command3
Ins 1640 0 400 570 Command4
Del 1640 870 400 550 Command5
(空格) 1640 1400 400 2565 Command6
Esc 1640 4670 400 550 Command7
Enter 820 4590 400 630 Command9
←(退格) 820 4590 400 630 Command10 接下来做一个Height为400、Width为360的按扭Command8,Caption为A a(注意中间是两个空
格,这一点非常重要!),由于按扭太小,系统会自动换行,看上去A在a的上面。复制该按扭,然
后在窗体上粘贴,程序会提示你是否产生控件数组,选择是,Command8变成了Command8(0),新产
生的按扭为Command8(1),一直粘贴,直到Command8(46),修改它们的Caption使之与键盘上的其
它键一样。这里要注意几点:
1、按扭的字体为“小五”,有几个键显示的结果是纵向并排,可把字体设为“六号”,使之横向
并排,字体使用宋体,否则↑和←显示的不漂亮。
2、&符号要使用两个,即 && 7(&&与7之间只有一个空格),确保每个按扭的Caption的长度为四
个字母。
3、把窗体的MousePointer设为15 - Size All,以便在运行的时候移动小键盘。
4、把所有按键的MousePointer都设为99 - Custom,而MouseIcon设为手形指针。
5、由于要指示Shift是否按下,Command1的Style属性设置为1-Graphical。
6、Form2的StartUpPosition属性设置为2-屏幕中心。
我们把Command8(x)的这些键暂时叫做“普通键”。由于前面已经定位了9个特殊键,所以可以通
过菜单栏的“格式”里面的“顶端对齐”、“相同水平间距”等选项很容易地把47个普通键放到与
键盘对应的位置上。另外,为了显示CAPS LOCK的状态,我们在窗体上加一个标签Label1,把它的
AutoSize属性设为True,Caption属性设为●,它的Top、Left、Height和With分别为1340、
4800、180和180。
接下来是写代码了,这里主要用了SendMessage发送消息的API函数,由于按扭CAPTION设置的巧
妙,所以47个普通键的代码就用的很少。所有代码如下:
'API声明
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal
hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private 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)
Private Declare Sub GetKeyboardStateByString Lib "user32"
Alias "GetKeyboardState" (ByVal pbKeyState As String)
Private Declare Sub SetKeyboardStateByString Lib "user32"
Alias "SetKeyboardState" (ByVal lppbKeyState As String)
'常数
Const VK_CAPITAL = &H14
Const WM_CHAR = &H102
Const HTCAPTION = 2
Const WM_NCLBUTTONDOWN = &HA1
Const WM_KEYDOWN = &H100
Const VK_DELETE = &H2E
Const VK_INSERT = &H2D
'定义变量
Dim rc as Long Private Sub Command1_Click()
'Shift键
If Command1.BackColor = &H8000000B Then
Command1.BackColor = &H80000005
Else
Command1.BackColor = &H8000000B
End If
End Sub '退格键
Private Sub Command10_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_CHAR, 8, 1)
End Sub '大小写转换键
Private Sub Command2_MouseDown(Button As Integer, Shift As Integer, X As
Single, Y As Single)
Dim CAPITALKey As String * 256
CAPITALKey = Space$(256)
GetKeyboardStateByString (CAPITALKey)
If Label1.ForeColor = vbBlack Then
Label1.ForeColor = vbGreen
Mid$(CAPITALKey, VK_CAPITAL + 1, 1) = Chr$(1)
Else
Label1.ForeColor = vbBlack
Mid$(CAPITALKey, VK_CAPITAL + 1, 1) = Chr$(0)
End If
Call SetKeyboardStateByString(CAPITALKey)
End Sub 'TAB键
Private Sub Command3_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_CHAR, 9, 1)
End Sub 'Ins键
Private Sub Command4_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_KEYDOWN, VK_INSERT, &H510001)
End Sub 'Del键
Private Sub Command5_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_KEYDOWN, VK_DELETE, 1)
End Sub '空格键
Private Sub Command6_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_CHAR, 32, 1)
End Sub 'Esc键
Private Sub Command7_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_CHAR, 27, 1)
End Sub '普通键
Private Sub Command8_Click(Index As Integer)
Dim keyx As Integer
If Command1.BackColor = &H80000005 Xor Label1.ForeColor = vbGreen Then
keyx = Asc(Mid(Command8(Index).Caption, 1, 1))
Else
keyx = Asc(Mid(Command8(Index).Caption, 4, 1))
End If
rc = SendMessage(Form2.Text1.hwnd, WM_CHAR, keyx, 1)
Command1.BackColor = &H8000000B
End Sub '回车键
Private Sub Command9_Click()
rc = SendMessage(Form2.Text1.hwnd, WM_CHAR, 13, 1)
End Sub '让小键盘在最前面
Private Sub Form_Load()
rtn = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3)
End Sub '移动没有标题的小键盘
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y
As Single)
If Button = 1 Then
Dim ReturnVal As Long
X = ReleaseCapture()
ReturnVal = SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If
End Sub
最后要提醒您的是:如果你要用于多个Text要做如下两步:
1、把FORM2中的EnableWindow Text1.hwnd, False去掉。
2、把软键盘代码中所有的Form2.Text1.Hwnd换成如下代码:Form2.ActiveControl.hwnd
瞧,超酷的小键盘就这样做成了!该程序在VB6+WIN98下运行通过,如果你需要本事例的源代码,
请在本文见报后到第一VB论坛的首页下载吧!网址是http://www.vbgood.com
解决方案 »
- 请问用MMCONTROL控件录音时,怎样指定录音的WAV的取样格式?
- 送分100分:VB6如何判断一个变量或对象是否已经存在
- 感谢CSO,这次问题彻底解决了
- vb编写的标准dll 调用C++编写dll,急!!!!!!
- webbrowser 控件打开网页时弹出 Microsoft Internet Explorer 的确定窗口,如何实现它自动确定
- VB中如何实现:程序启动时, 在任务栏右下角添加小图标?谢谢。
- 帮帮忙,告诉我为什么要这样写!^-^!我已经等好长时间了.
- 我用winsock编写smtp邮件发送程序,为什么有一步总是过不去?
- 水晶报表的这个小功能我不懂,请提示?
- 如何在VB中实现多线程的程序,请各们赐教
- 轻松获得20分,提供一个vb对对象里的mtxas.dll文件。
- 高分请教,有没有 物资管理系统(VB)的方案,请帮忙啊!!急,急
青岛 杜运庆
许多朋友把EXCEL作为报表的工具,把数据写入EXCEL并不困难,但存在一些问题,如:客户
修改了报表的格式,或者把设计好的报表文件删除了,如何解决这些问题呢?搜遍了国内外的站
点,亦未发现有什么好的办法。
有的朋友给EXCEL文件加密码,这种办法只防止了客户修改报表格式,如果客户移动或删除了
这个报表文件,仍然会出问题。现在我们来手绝的:把设计好的空白报表加到资源文件里面,每次
报表的时候先把资源文件里面的EXCEL报表写到当前目录下,然后由程序填写数据,或显示或打
印!
开始吧!先做一些准备工作,在这里假设已准备了以下东东:
在当前目录下有一access2000数据库db1.mdb,打开密码是7281322,内有一张表MonRep存放着
要报表的数据;设计好的空白EXCEL2000报表rp.xls,打开密码也是7281322。
打开VB,新建一个工程,在"工程"→"引用"里面选取Microsoft ActiveX Data Object 2.1
Library和Microsoft Excel 9.0 Object Library;
在"外接程序"→"外接程序管理器"里面加载"VB 6 资源编辑器",在"工程资源管理器"里面点击鼠
标右键,选取"添加资源文件",随便给资源文件起个名字,出现"VB资源编辑器"后,点"添加自定
义资源"按钮,选取你设计好的报表rp.xls,点击"保存"按钮,注意:这里使用了默认的类
型"CUSTOM"和默认的标识号101,实际应用中你可做修改。
按下Ctrl-t,选取Microsoft DataGrid Control 6.0(OLEDB)在默认窗体Form1上画一个
DataGrid,默认名称DataGrid1。
在窗体里添加如下代码:
Private Sub Form_Load()
Dim rst As Recordset
Set Cnn1 = New ADODB.Connection
CnnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path
& "\db1.mdb" _
& ";Mode=Read|Write;Persist Security Info=False;Jet OLEDB:Database
Password=7281322"
Cnn1.Open CnnStr
Sql = "SELECT * FROM MonRep"
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.Open Sql, Cnn1, adOpenKeyset, adLockOptimistic, adCmdText
Set DataGrid1.DataSource = rst
End Sub
Private Sub Form_Resize()
DataGrid1.Width = 0.95 * Me.Width
DataGrid1.Height = 0.75 * Me.Height
End Sub
在窗体的"通用"里面添加以下代码:(注意API函数的声明一定要写在一行里)
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
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal
lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long,
lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As
Long, ByVal lpOverlapped As Any) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal
lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long,
ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal
dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As
Long
Const WM_CLOSE = &H10
Const GENERIC_WRITE = &H40000000
Const CREATE_ALWAYS = 2
Const FILE_ATTRIBUTE_NORMAL = &H80
Public Sub CopyExcel()
Dim hNewFile As Long, bBytes() As Byte
Dim nSize As Long
Dim hwnd
hwnd = FindWindow("XLMAIN", "Microsoft Excel - rp.xls")
If hwnd <> 0 Then
SendMessage hwnd, WM_CLOSE, 0, 0'如果客户没有关闭该报表,提示他关闭它
Exit Sub
End If
If Dir(App.Path & "\rp.xls") = "rp.xls" Then
Kill App.Path & "\rp.xls"
End If
bBytes = LoadResData(101, "CUSTOM")
hNewFile = CreateFile(App.Path & "\rp.xls", GENERIC_WRITE, 0, 0,
CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
nSize = UBound(bBytes) - LBound(bBytes) + 1
WriteFile hNewFile, bBytes(0), nSize, nSize, ByVal 0&
CloseHandle hNewFile
End Sub
在窗体上画一按钮,添加以下代码:
Private Sub Command1_Click()
Me.MousePointer = 11
CopyExcel
Dim ex As Object
Dim i As Integer
Dim j As Integer
Dim XlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set XlApp = CreateObject("Excel.Application")
XlApp.Visible = True
Set xlBook = XlApp.Workbooks.Open(App.Path & "\rp.xls", , , , 7281322)
Set xlSheet = xlBook.Worksheets(1)
Dim rst As Recordset
Set Cnn1 = New ADODB.Connection
CnnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path
& "\db1.mdb" _
& ";Mode=Read|Write;Persist Security Info=False;Jet OLEDB:Database
Password=7281322"
Cnn1.Open CnnStr
Sql = "SELECT * FROM MonRep"
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.Open Sql, Cnn1, adOpenKeyset, adLockOptimistic, adCmdText
rst.MoveFirst
For j = 0 To rst.RecordCount - 1
For i = 3 To rst.Fields.Count
xlSheet.Cells(i + 2, j + 3) = rst.Fields(i - 1).Value
Next i
rst.MoveNext
Next j
For i = 3 To rst.Fields.Count
zzz = 0
For j = 0 To rst.RecordCount - 1
zzz = zzz + xlSheet.Cells(i + 2, j + 3)
Next j
xlSheet.Cells(i + 2, 16) = zzz
Next i
xlSheet.Cells(3, 15) = Date
' ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
' xlBook.Close
' XlApp.Quit
Me.MousePointer = 0
End Sub
释的三行命令。
搞定了!按下F5运行后点击按钮,你会看到生成的报表。利用这种方法,你再也不用担心客户破坏
你的报表了,爽吗?如果你懒得自己做一遍,到第一VB论坛http://www.vbgood.com去下载我的示
例源代码看看吧。该示例代码在以下环境下通过:
Win98+VB6SP3+Excl2000+Access2000
杜运庆
速度是程序的命,如果您的软件再好,但运行速度很慢,那么您将失去用户耐心。VB6在操纵数据
库方面做的很出色,但操纵表的还是用SQL语句快,好在VB6的DAO对象、ADO对象和数据环境、ADO
控件都可以使用SQL语句,但怎么提高数据操纵速度呢?建立索引当然是最基本的要求,除此之外
呢?有没有其他的方法?第一VB论坛(http://www.d1vb.com)的网友经常提出这个问题,这里我
告诉您几种优化的方法:
一、表的设计
当在表中添加字段的时候,应该选择长度最小的数据类型,这样表在内存中每页可以存储更多的记
录。如:“姓名”字段一般设置为TEXT类型,长度为10一般就够用,则比默认的255要好的多。整
型Integer的长度是2,在使用整型Integer就可以解决问题的地方不要使用Single、Long、
Double、Currency,因为它们的长度分别为4、4、8、8,都比2大。在建立表后一定要建立
索引,这可以大大提高查询速度,是提高速度最基本的要求。
二、压缩数据库
JET数据库的查询优化是有代价的,随着数据库的不断扩大,优化将不再起作用。压缩数据库会改
变数据库的状态,并重新优化所有查询。同时,随着数据库的增大,会产生很多碎片。而压缩数据
库可以把一个表中的数据数据写到硬盘中连续的页里,提高了顺序搜索的速度。
压缩数据库使用CompactDatabase命令,下面的语句压缩数据库并产生一个数据库备份:
DBEngine.CompactDatabase “C:\VB\BIBLIO.MDB”, “C:\VB\BIBLIO2.MDB”
Kill “C:\VB\BIBLIO.BAK” Name “C:\VB\BIBLIO.MDB” As “C:\VB\BIBLIO.BAK”
Name “C:\VB\BIBLIO2.MDB” As “C:\VB\BIBLIO.MDB”
注意,如果数据库很大的话,可能需要整夜的时间来压缩数据库。
三、避免查询输出里面多余的计算
当查询的结果作为另外一个查询的数据源的时候,可能引起查询优化问题。在这个时候第一次查询
里面尽量避免大量的计算。在如下示例中,Query1是第一个查询的结果,然后它作为第二个查询
的数据源。
Dim DB As Database
Dim RS As RecordSet
Set DB = DBEngine.Workspaces(0).Opendatabase(“Biblio.MDB”)
DB.CreateQueryDef(“Query1”, _
“SELECT IIF(Au_ID=1,’Hello’,’Goodbye’) AS X FROM Authors”)
Set RS = DB.OpenRecordSet(“SELECT * FROM Query1 WHERE X=’Hello’”)
由于在第一个查询Query1中的IIF()表达式不能被优化,,所以在第二个查询中的WHERE子句也不
能被优化。如果一个表达式在一个查询树中埋藏的很深的话,则这个查询不可被使用,它是不可优
化的。
如果可能的话,把这个SQL语句合并为一个没有嵌套的SQL语句:
Set RS = DB.OpenRecordSet(“SELECT * FROM Authors WHERE Au_ID=1”)
对于更灵活的嵌套查询,尽量在SQL语句中使用字段名,如:
DB.CreateQueryDef(“Query1”, _
“SELECT IIF(Au_ID=1,’Hello’,’Goodbye’) AS X, Au_ID, FROM Authors”)
Set RS = DB.OpenRecordSet(“SELECT * FROM Query1 WHERE Au_ID=1”)
如果在查询输出中实在无法避免计算式的话,尽量把计算式放在最外层,不要放在最内层。
四、只输出需要的字段
在建立查询的时候,仅返回需要的字段,这样可以节省不必要的开支。如果某个字段不是你需要
的,不要在查询语句中出现。上面的事例正说明了这个问题。
五、分组、合并及汇总
这里要说明的主要是合并,当你需要把两个表合并,就是说:当你要根据“Customer Name”对两
个表进行合并,要肯定GROUP BY field (Customer Name)和汇总(Sum, Count, and 等)的字段
是来自同一张表。
例如:下列语句优化性较差,因为SUM子句来自Ord表,而GROUP BY子句来自Cust表:
SELECT Cust.CustID,
FIRST(Cust.CustName) AS CustName,
SUM(Ord.Price) AS Total
FROM Cust INNER JOIN Ord ON Cust.CustID = Ord.CustID
GROUP BY Cust.CustID
如果按照Ord.CustID分组,查询性能就好的多了:
SELECT Ord.CustID,
FIRST(Cust.CustName) AS CustName,
SUM(Ord.Price) AS Total
FROM Cust INNER JOIN Ord ON Cust.CustID = Ord.CustID
GROUP BY Ord.CustID
六、尽量减少分组的字段
SQL语句中分组(GROUP BY)的字段越多,执行查询的时间越长。在GROUP BY子句中尽量用
aggregate函数来减少字段的数量。
如:
GROUP BY As Few Fields As Possible
SELECT Cust.CustID,
Cust.CustName,
Cust.Phone,
SUM(Ord.Price) AS Total
FROM Cust INNER JOIN Ord ON Cust.CustID = Ord.CustID
GROUP BY Cust.CustID, Cust.CustName, Cust.Phone
可以改为::
SELECT Ord.CustID,
FIRST(Cust.CustName) AS CustName,
FIRST(Cust.Phone) AS Phone,
SUM(Ord.Price) AS Total
FROM Cust INNER JOIN Ord ON Cust.CustID = Ord.CustID
GROUP BY Ord.CustID
七、在合并之前嵌套GROUP BY子句
如果要合并两张表,而且只在一张表中分组,把查询分为两个SELECT语句要快的多。
如:
SELECT Ord.CustID,
FIRST(Cust.CustName) AS CustName,
FIRST(Cust.Phone) AS Phone,
SUM(Ord.Price) AS Total
FROM Cust INNER JOIN Ord ON Cust.CustID = Ord.CustID
GROUP BY Ord.CustID
可改为:
查询1:
SELECT CustID, SUM(Price) AS Total
FROM Ord
GROUP BY CustID
查询2:
SELECT Query1.CustID, Cust.CustName, Cust.Phone, Query1.Total
FROM Cust INNER JOIN Ord ON Cust.CustID = Ord.CustID
八、在合并的时候两边的字段都设置索引
在合并表的时候,尽量使两边的字段都设置索引。这在执行查询的时候查询优化器可以更多的使用
sophisticated 内部合并策略。
当然,在关系型数据库中,表要设计的尽量小,(最好1-2K页),这样删除表的索引的时候要快
的多,这是因为内存中读入了很少的页。这需要根据实际情况多次测试。
九、添加索引来提高查询和排序的速度
为合并或查询条件中的所有使用字段建立索引。Microsoft Jet 2.0极其以后版本的数据库引擎
使用使用了Rushmore查询优化技术,因此支持一张表的复合索引。
要尽量避免在查询条件中进行计算或在查询条件中使用未索引的字段。排序更是如此,绝对要避免
计算或使用未索引的字段。
十、使用可优化的表达式
重新构造查询语句,以便于Rushmore技术可以对其进行优化。Rushmore是一种数据访问技术,使
用它可以提高记录集的查询速度。使用Rushmore的时候,若在查询条件中使用具体类型的表达
式,查询速度将非常快。Rushmore不会自动为你的查询提高速度,你必须按照具体的方法修改查
询语句,以便于Rushmore可以优化它们。
十一、用COUNT(*)代替 COUNT([Column Name])
Microsoft Jet数据库引擎有特别的优化方法,它在使用COUNT(*)要比用COUNT([Column Name])
快得多。
注意,这两个运算符是有差别的:
Count(*) 计算所有的行。
Count([Column Name])计算所有Column Name非空的行。
十二、在变量中避免使用LIKE
由于在查询完成的时候变量的值不确定,所以无法使用索引,这样,建立的索引就失去了意义,这
就严重制约着查询速度。
十三、避免LIKE和统配符同时使用
如果要把LIKE运算符同统配符一起使用,为了使用索引,必须把统配符放在后面。
如,下列语句利用了索引。
Like "Smith"
Like "Sm*"
而下列语句根本没有使用索引:
Like "*sen"
Like "*sen*"
十四、测试合并约束
如果要在合并中使用表达式约束一个字段的数值,需要测试表达式放在合并的一侧,还是其他地
方,看哪种查询的速度较快。在一些查询中,表达式放在合并关键词join一侧反而比较快。
十五、使用中间结果表
用SELECT INTO建立工作表,尤其是结果集用于几个查询的时候,尽量使用中间结果表。在查询前
做的准备工作越多,查询速度越快。
十六、避免子SELECT语句和NOT IN同时使用
子SELECT语句和NOT IN同时使用很难优化,取反嵌套的查询或OUTER JOINs影响很大。
下列事例查询不在orders表中的用户:
优化前:
SELECT Customers.*
FROM Customers
WHERE Customers.[Customer ID]
NOT IN (SELECT [Customer ID] FROM Orders);
优化后:
SELECT Customers.*
FROM Customers LEFT JOIN Orders
ON Customers.[Customer ID] = Orders.[Customer ID]
WHERE ((Orders.[Customer ID] Is Null));
杜运庆
在客户运行您的应用程序的时候自动更换墙纸,显然是广告宣传的一个好机会。但无论是
MSDN还是网络上的免费资源代码,更换墙纸几乎都是同一个API函数SystemParametersInfo和同
一段代码,国外站点提供的免费代码也是如此。从VB4.0开始就这样。这段代码是: 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
Const SPI_SETDESKWALLPAPER = 20
Const SPIF_SENDWININICHANGE = &H2
Const SPIF_UPDATEINIFILE = &H1 Private Sub Form_Load()
ChangeWP = SystemParametersInfo(SPI_SETDESKWALLPAPER,
0, "Path+BmpFile", 0)
End Sub 使用这个例程确实能够切换墙纸,但存在以下问题: 1、用鼠标右键点击桌面,会看到【背景】→【墙纸】里面的文件名是空的。 2、重新启动后桌面墙纸消失。 3、没告诉您怎么切换"居中"或"平铺"。 怎么解决这些问题呢? 1、Windows的墙纸必须以BMP格式的文件存放在Windows目录下面,如果您的图片不在该目录
或不是BMP文件,那么就会出现第一个问题。因此必须把您的图片转换成BMP文件并复制到Windows
目录下面。 2、要使重新启动后需要在注册表里面修改相应的键值,具体位置是
HKEY_CURRENT_USER\Control Panel\desktop中的Wallpaper键,让它的键值等于您的全路径文
件名。 3、在更换墙纸以前首先设置是否"居中",需要修改注册表中HKEY_CURRENT_USER\Control
Panel\desktop中的TileWallpaper键,键值"0"表示"居中","1"表示"平铺"。 本例把一个JPG格式的图片成功地设置为墙纸,全部代码如下: Private Declare Function GetWindowsDirectory Lib "kernel32"
Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As
Long 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 Const SPI_SETDESKWALLPAPER = 20
Const SPIF_SENDWININICHANGE = &H2
Const SPIF_UPDATEINIFILE = &H1
Const REG_SZ As Long = 1
Const HKEY_CURRENT_USER = &H80000001 Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As
Long Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA"
(ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal
samDesired As Long, phkResult As Long) As Long Private Declare Function RegSetValueExString Lib "advapi32.dll"
Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal
Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData
As Long) As Long Private Declare Function RegSetValueExLong Lib "advapi32.dll"
Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal
Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long)
As Long Private Sub SetKeyValue(sKeyName As String, sValueName As String, vValueSetting
As Variant, lValueType As Long, lPredefinedKey As Long) lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0,
KEY_ALL_ACCESS, hKey)
lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
RegCloseKey (hKey)
End Sub Private Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As
Long, vValue As Variant) As Long
Dim lValue As Long
Dim sValue As String
Select Case lType
Case REG_SZ
sValue = vValue & Chr$(0)
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType,
sValue, Len(sValue))
Case REG_DWORD, REG_BINARY
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&,
lType, lValue, 4)
End Select
End Function Private Sub Form_Load()
'取得windows目录
Dim Path As String, strSave As String
strSave = String(50, Chr$(0))
Path = Left$(strSave, GetWindowsDirectory(strSave, Len(strSave)))
'转换图片并保存到Windows目录下面
Image1.Picture = LoadPicture(App.Path & "\MyFlower.Jpg")
SavePicture Image1, Path & "\MyFlower.bmp"
Dim aa As String
'写入注册表
'设定居中
SetKeyValue "Control Panel\desktop", "TileWallpaper",
"0", REG_SZ, HKEY_CURRENT_USER
'设定平铺
' SetKeyValue "Control Panel\desktop",
"TileWallpaper", "1", REG_SZ, HKEY_CURRENT_USER
'更换墙纸
aa = Path & "\MyFlower.bmp"
ChangeWP = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, aa, 0)
'在注册表中记录图片位置
SetKeyValue "Control Panel\desktop", "Wallpaper", aa,
REG_SZ, HKEY_CURRENT_USER
End Sub 使用本例要注意:必须先设置是否"居中",然后再更换墙纸。本例在Windows95+VB6下调试通
过。
杜运庆
制作一个本企业的屏幕保护,在客户运行本企业的应用软件的时候,为客户更改屏幕保护,是个
广告宣传的好办法。在第一VB论坛(http://www.vbgood.com)上有很多朋友提出这个问题,现解答如
下: 要更换屏幕保护,首先得做好一个屏幕保护(scr文件),本例以 工程1.scr 这个文件为例。
由于windows是把屏幕保护文件存放在system下,但记录屏幕保护文件位置的文件却是windows目
录下的system.ini,所以,首先需要找出系统的windows和system目录的确切安装位置。因此,
可以分如下几步进行: 1、找到windows和system目录的安装位置 2、把屏幕保护文件复制到system目录下 3、在system.ini中的[boot]中写入: SCRNSAVE.EXE=C:\WINDOWS\SYSTEM\工程1.SCR 4、告诉系统切换屏幕保护。 下面的例子成功地改变了屏幕保护,全部源代码如下: '得到windows目录 Private Declare Function GetWindowsDirectory Lib "kernel32"
Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As
Long '修改system.ini
Private Declare Function WritePrivateProfileString Lib "kernel32"
Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal
lpKeyName As Any, ByVal lpString As Any, ByVal lplFileName As String) As Long '得到system目录
Private Declare Function GetSystemDirectory Lib "kernel32"
Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As
Long '设置屏幕保护
Private Const SPI_SETSCREENSAVETIMEOUT = 15
Private Const SPI_SETSCREENSAVEACTIVE = 17
Private Const SPIF_UPDATEINIFILE = &H1
Private Const SPIF_SENDWININICHANGE = &H2 Private Declare Function SystemParametersInfo Lib "user32"
Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long,
ByVal lpvParam As Long, ByVal fuWinIni As Long) As Long '启动屏幕保护
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 Private Const WM_SYSCOMMAND = &H112
Private Const SC_SCREENSAVE = &HF140 Private Sub Form_Load()
'得到system目录
Dim sSave As String, Ret As Long
sSave = Space(255)
Ret = GetSystemDirectory(sSave, 255)
sSave = Left$(sSave, Ret)
'把屏保复制到系统目录
FileCopy App.Path & "\工程1.scr", sSave & "\工程1.SCR"
'得到windows目录
Dim Path As String, strSave As String
strSave = String(250, Chr$(0))
Path = Left$(strSave, GetWindowsDirectory(strSave, Len(strSave)))
'修改system.ini
Dim r As Long
Dim iniPath As String
iniPath$ = Path + "\system.ini"
r = WritePrivateProfileString("boot", "SCRNSAVE.EXE", sSave & "\工程1.SCR",
iniPath)
'设置时间间隔为1分钟=60秒
lRet = SystemParametersInfo(SPI_SETSCREENSAVETIMEOUT, 60, ByVal 0&,
SPIF_UPDATEINIFILE + SPIF_SENDWININICHANGE)
'设置屏幕保护
retval = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, True, 0, 0)
'启动屏幕保护
Dim result As Long
result = SendMessage(Form1.hwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
End Sub 本例在vb6.0+win95下运行通过。