VB期末综合练习_百度文库
两大类热门资源免费畅读
续费一年阅读会员，立省24元！
VB期末综合练习
上传于||文档简介
&&V​B​期​末​综​合​练​习
阅读已结束，如果下载本文需要使用0下载券
想免费下载更多文档？
定制HR最喜欢的简历
下载文档到电脑，查找使用更方便
还剩9页未读，继续阅读
定制HR最喜欢的简历
你可能喜欢--&&防止将重复项目添加到列表框中防止将重复项目添加到列表框中:(当然用循环也可以实现)
Option ExplicitPrivate Declare Function SendMessageFind Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As String) As LongConst WM_USER = &H400Const LB_ERR = (-1)Const LB_FINDSTRING = &H18FPrivate Sub Form_Load()&&&&List1.AddItem "Item1"&&&&List1.AddItem "Item2"&&&&List1.AddItem "Item3"End SubPrivate Sub Command1_Click()&&&&CheckForDupesEnd SubSub CheckForDupes()&&&&Dim Ret As Long&&&&&&&&\'检查Text1.Text的值是否已出现过&&&&Ret = SendMessageFind(List1.hwnd, LB_FINDSTRING, 0, Text1.Text)&&&&If Ret = LB_ERR Then&&&&&&&&List1.AddItem Text1.Text&&&&Else&&&&&&&&List1.ListIndex = Ret&&&&&&&&MsgBox "重复啦!!!", 32, "BSoft提示"&&&&End IfEnd Sub
--&&自动选定TextBox中原有字符当窗体上的TextBox得到输入焦点时，自动选定TextBox中原有字符的技巧：在标准模块中申明过程SelectAllTxt
Public Sub SelectAllTxt()&&&&With Screen.ActiveForm&&&&&&\'桌面当前窗体&&&&&&&&If (TypeOf .ActiveControl Is TextBox) Then&&&&\'如果当前选定的控件为TextBox&&&&&&&&&&&&.ActiveControl.SelStart = 0&&&&&&&&&&&&&&&&\'那么从TextBox中字符的开头选择&&&&&&&&&&&&.ActiveControl.SelLength = Len(.ActiveControl)&& \'选择长度为TextBox中字符的长度&&&&&&&&End If&&&&End WithEnd SubPrivate Sub Text1_GotFocus()&&&&SelectAllTxt&& \'调用过程End Sub
--&&截屏代码(可截屏整个Screen/当前活动界面)
Option ExplicitPrivate Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)Const theScreen = 0&&\'整个ScreenConst theForm = 1&&&&\'当前活动界面Private Sub Command1_Click()&&&&Call keybd_event(vbKeySnapshot, theForm, 0, 0)&&&&\'若theForm改成theScreen则Copy整个Screen&&&&DoEvents&&&&Picture1.Picture = Clipboard.GetData(vbCFBitmap)End Sub
--&&VB中控制光驱弹出和关闭的方法VB中控制光驱弹出和关闭的方法使用MCI命令实现：使用API函数mciSendString,设有窗体Form1,上面有一个按钮Command1，Command1.Caption="弹出"。下面为代码：
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&&&&\'函数申明Private Sub Command1_Click()&&&&If Command1.Caption = "弹出" Then&&&&&&&&Command1.Caption = "关闭"&&&&&&&&mciSendString "Set CDAudio Door Open Wait", 0&, 0, 0 \' 弹出&&&&Else&&&&&&&&Command1.Caption = "弹出"&&&&&&&&mciSendString "Set CDAudio Door Closed Wait", 0&, 0, 0 \' 关闭&&&&End IfEnd Sub
--&&显示和隐藏鼠标
声明：Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long显示鼠标：lReturned = ShowCursor (1)隐藏鼠标：lReturned = ShowCursor (0)
--&&延时函数
Public Sub Wait(ByVal WaitTime As Single, Optional ByVal vDoEvents As Boolean = True)\'llp 延时函数\'vDoEvents =True 可中断&&&&Dim StartTime As Double&&&&StartTime = Timer&&&&&&&&Do While Timer & StartTime + WaitTime&&&&&&&&If Timer & 86395 Or Timer = 0 Then Exit Do&&&&&&&&If vDoEvents Then&&&&&&&&&&DoEvents&&&&&&&&End If&&&&Loop&&&&End Sub
--&&增强型Len&Left&Right&Mid&函数(可对中英字串)
\'字符长度（中英） llp Public Function Len_CnE(ByVal vStr As String) As Long&& &&Len_CnE = LenB(StrConv(vStr, vbFromUnicode))&&End FunctionPublic Function Left_CnE(ByVal vStr As String, ByVal vInt As Long) As String\'取字符（中英）llp &&Dim iStr As String&&If vInt & 1 Then&&&&Left_CnE = vStr&&&&Exit Function&&End If&&iStr = StrConv(LeftB(StrConv(vStr, vbFromUnicode), vInt), vbUnicode)&&&&If Not Left(vStr, Len(iStr)) = iStr Then&&&&iStr = Left(iStr, Len(iStr) - 1) & " "&&End If&&&&Left_CnE = iStr&&End FunctionPublic Function Right_CnE(ByVal vStr As String, ByVal vInt As Long) As String\'取字符（中英）对应 Right\'llp &&Dim iStr As String&&Dim lngLen As Long&&&&If vInt & 1 Then&&&&Right_CnE = vStr&&&&Exit Function&&End If&&lngLen = Len_CnE(vStr)&&&&If lngLen &= vInt Then&&&&Right_CnE = vStr&&&&Exit Function&&End If&&&&iStr = Right(vStr, Len(vStr) - Len(Left_CnE(vStr, lngLen - vInt)))&&&&If Len_CnE(iStr) & vInt Then&&&&iStr = " " & iStr&&End If&&&&Right_CnE = iStr&&End FunctionPublic Function Mid_CnE(ByVal tStr As String, Start As Integer, Optional Leng As Variant) As String\'取字符（中英）对应 Mid\'llp Dim TmpStr As StringDim TmpStr1 As StringIf Start & 1 And Start & Len_CnE(tStr) Then&&TmpStr1 = Left_CnE(tStr, Start - 1)&&&&If Not Left(tStr, Len(TmpStr1)) = TmpStr1 Or Len_CnE(Right(TmpStr1, 1)) & 1 Then&&&&tStr = Left_CnE(TmpStr1, Start - 1) & " " & Right(tStr, Len(tStr) - Len(TmpStr1))&&End IfEnd IfIf IsMissing(Leng) Then&&TmpStr = StrConv(MidB(StrConv(tStr, vbFromUnicode), Start), vbUnicode)Else&&TmpStr = StrConv(MidB(StrConv(tStr, vbFromUnicode), Start, Leng), vbUnicode)End IfMid_CnE = TmpStrEnd Function
--&&取得SQL服务器的当前时间
Public Function GetServerTime_ForDate() As String\'取得SQL服务器的当前时间\'成功返回服务器的日期时间格式：yy-MM-dd hh:ss:mm&&是日期型\'失败返回本机的日期时间格式：yy-MM-dd hh:ss:mm&&是日期型&&Dim Rst As New ADODB.Recordset&&&&Set Rst = Cnn.Execute("SELECT GETDATE()")&&If Not Rst.Eof Then&&&& GetServerTime_ForDate = Format(Rst(0), "yyyy-mm-dd hh:mm:ss")&&&& Set Rst = Nothing&&Else&&&& GetServerTime_ForDate = Format(Now, "yyyy-mm-dd hh:mm:ss")&&End If&&End Function
--&&在Visual&Basic使用帮助文件(*.chm&*.hlp)
Option Explicit\' 在Visual Basic使用帮助文件(*.chm *.hlp)\'当按下"F1"时将自动打开App.HelpFile所设置的帮助文件Private Sub Command1_Click()&&SendKeys "{F1}"End SubPrivate Sub Form_Load()&& App.HelpFile = app.path & "help.CHM"End Sub
--&&如何判断剪贴板有无数据
&&&& lLen = LenB(Clipboard.GetText) + Clipboard.GetData&&&&&& iF lLen=0 Then&&&&&&&&&&&&\'无内容&&&& Else&&&&&&&&&&&&\'有内容&&&& End If&&\'注GetData方法返回的是一个句柄，比如图象的句柄，如果只检测是否有文本内容，应去掉这一项。
--&&动态生成“关于”对话框(API应用)
Private Declare Function ShellAbout& Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long)Private Sub Command1_Click()&&&&&& ShellAbout Me.hwnd, "我的作品", "版本号:1.0", Me.IconEnd Sub
--&&快速选择List全部项目
\'我们在使用 List 控件时，经常需要全部选择其中的项目，在项目较少时，我们可以逐项设置 Selected 来选择全部的项目，但当项目较多时，这样做就比较费时，其实，我们可以用 API 函数来简单实现此功能： Dim nRet As Long Dim bState as Boolean bState=True nRet = SendMessage(lstList.hWnd, LB_SETSEL, bState, -1) \'函数声明： Public Declare Function SendMessage Lib "User32" Alias "SendMessageA" ( ByVal hWnd As Long, ByVal wMsg As Integer, ByVal wParam As Long, ByVal lParam As Long) As Long Public Const WM_USER = &H400 Public Const LB_SETSEL = (WM_USER + 6)
--&&保存Image/PIC为图片本例使用 SavePicture 语句保存画在 Form 对象的 Picture 属性中的图形。要试用此例，可将以下代码粘贴到 Form 对象的声明部分，然后运行此例，单击 Form 对象。
Private Sub Form_Click ()&& \' 声明变量。&& Dim CX, CY, Limit, Radius&& as Integer, Msg as String&& ScaleMode = vbPixels&& \' 设置比例模型为像素。&& AutoRedraw = True \' 打开 AutoRedraw。&& Width = Height&& \' 改变宽度以便和高度匹配。&& CX = ScaleWidth / 2&& \' 设置 X 位置。&& CY = ScaleHeight / 2&& \' 设置 Y 位置。&& Limit = CX&& \' 圆的尺寸限制。&& For Radius = 0 To Limit&& \' 设置半径。&&&&&&Circle (CX, CY), Radius, RGB(Rnd * 255, Rnd * 255, Rnd * 255)&&&&&&DoEvents&& \' 转移到其它操作。&& Next Radius&& Msg = "Choose OK to save the graphics from this form "&& Msg = Msg & "to a bitmap file."&& MsgBox Msg&& SavePicture Image, "TEST.BMP"&& \' 将图片保存到文件。End Sub
--&&防止退出EXCEL时"询问是否要保存所作修改有时在打开EXCEL文件操作后,退出EXCEL时系统会提示"询问是否要保存所作修改" 为防止这一情况出现有两种方法可实现:1.在使用 Quit 方法前保存所有的工作簿2.将 DisplayAlerts 属性设置为 False。如果该属性为 False，则 Microsoft Excel 退出时，即使存在未保存的工作簿退出，也不会显示对话框，而且不保存就退出。代码如下:
1.Dim objExecl As Object&&Set objExecl = CreateObject("EXCEL.Application")&&objExecl.workbooKs.Open FileName:=App.Path & "\\1.xls", ReadOnly:=True&&&&&&:&&&&&&:&&objExecl.ActiveWorkbook.SaveAs&&....&&objExecl.quit2.Dim objExecl As Object&&Set objExecl = CreateObject("EXCEL.Application")&&objExecl.workbooKs.Open FileName:=App.Path & "\\1.xls", ReadOnly:=True&&objExecl.DisplayAlerts = False&&objExecl.workbooKs(1).Activate&&objExecl.Sheets(objExecl.Sheets(1).Name).Select&&objExecl.Visible = True&&objExecl.quit第二种方法一般用于临时打开Execl ,操作后不用保存,如打开后写入数据只为了打印预览之类的操作
--&&StrConv&函数的应用
\'将字符串由 Unicode 转成系统的缺省码页&&\'应用:可得到中英混合的字串的字节数&&Debug.Print LenB(StrConv(<FONT color=#3中国456", vbFromUnicode))&&\'10&&&&\'根据系统的缺省码页将字符串转成 Unicode&&Debug.Print StrConv(StrConv(<FONT color=#3中国", vbFromUnicode), vbUnicode)&&\'123中国&&\'将字符串文字转成小写&&\'应用:与LCase功能一致&&Debug.Print StrConv("DDDＤＤＤ", vbLowerCase)&&\'dddｄｄｄ&&\'将字符串中单字节字符转成双字节字符&&\'应用:将半角字串转成全角字串&&Debug.Print StrConv("aA123456", vbWide)&&\'ａＡ１２３４５６&&\'将字符串中双字节字符转成单字节字符&&\'应用:将全角字串转成半角字串&&Debug.Print StrConv("ＡＳＤＦＧ！＠", vbNarrow)&&\'ASDFG!@&&\'将字符串中每个字的开头字母转成大写&&\'应用:英文单词的每个单词第一个字母转成大写&&Debug.Print StrConv("i love you", vbProperCase)&&\'I Love You&&\'将字符串文字转成大写&&\'应用:与UCase功能一致&&Debug.Print StrConv("aaaaa", vbUpperCase)&&\'AAAAA
--&&控件与界面大小等比变化下面代码将实现界面上的控件与界面大小等比变化:
Option ExplicitPrivate ObjOldWidth As Long&&\'保存窗体的原始宽度Private ObjOldHeight As Long \'保存窗体的原始高度Private ObjOldFont As Single \'保存窗体的原始字体比\'在调用ResizeForm前先调用本函数Public Sub ResizeInit(FormName As Form)&&Dim Obj As Control&&&&ObjOldWidth = FormName.ScaleWidth&&ObjOldHeight = FormName.ScaleHeight&&ObjOldFont = FormName.Font.Size / ObjOldHeight&&On Error Resume Next&&For Each Obj In FormName&&&&Obj.Tag = Obj.Left & " " & Obj.Top & " " & Obj.Width & " " & Obj.Height & " "&&Next Obj&&&&On Error GoTo 0End Sub\'按比例改变表单内各元件的大小，\'在调用ReSizeForm前先调用ReSizeInit函数Public Sub ResizeForm(FormName As Form)&&Dim Pos(4) As Double&&Dim i As Long, TempPos As Long, StartPos As Long&&Dim Obj As Control&&Dim ScaleX As Double, ScaleY As Double&&&&ScaleX = FormName.ScaleWidth / ObjOldWidth&&\'保存窗体宽度缩放比例&&ScaleY = FormName.ScaleHeight / ObjOldHeight&&\'保存窗体高度缩放比例&&On Error Resume Next&&&&For Each Obj In FormName&&&&StartPos = 1&&&&For i = 0 To 4&&&&&&\'读取控件的原始位置与大小&&&&&&TempPos = InStr(StartPos, Obj.Tag, " ", vbTextCompare)&&&&&&If TempPos & 0 Then&&&&&&&&Pos(i) = Mid(Obj.Tag, StartPos, TempPos - StartPos)&&&&&&&&StartPos = TempPos + 1&&&&&&Else&&&&&&&&Pos(i) = 0&&&&&&End If&&&&&&&&&&&&\'根据控件的原始位置及窗体改变大&&&&&&\'小的比例对控件重新定位与改变大小&&&&&&Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY, Pos(2) * ScaleX, Pos(3) * ScaleY&&&&&&Obj.Font.Size = ObjOldFont * FormName.ScaleHeight&&&&Next i&&&&Next Obj&&&&On Error GoTo 0End SubPrivate Sub Form_Resize()&&\'确保窗体改变时控件随之改变&&Call ResizeForm(Me)End SubPrivate Sub Form_Load()&&\'在程序装入时必须加入&&Call ResizeInit(Me)End Sub
--&&向外部程序发出按键消息
\'1.你可以使用API函数SendMessage来发送WM_KEYDOWN消息。例如： &&&&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 &&&&Const WM_KEYDOWN = &H100 &&&& &&&&Private Sub Command1_Click() &&&& SendMessage hwndFormB, WM_KEYDOWN, Asc("B"), 0& &&&&End Sub &&&&这里的hwndFormB是FormB的窗口句柄\'2.可以用VB的SendKeys来实现:Dim ReturnValue, IReturnValue = Shell("Calc.EXE", 1)&& \' 运行计算器。AppActivate ReturnValue&&&&\' 激活计算器。For I = 1 To 100&& \' 设置计数循环。&& SendKeys I & "{+}", True&& \' 按下按键给计算器Next I&& \' 将所有 I 值相加。SendKeys "=", True&& \' 取得总合。SendKeys "%{F4}", True&& \' 按 ALT+F4 关闭计算器。
--&&启动可执行并等待该文件执行结束用于启动可执行文件或用关联程序打开文档，并等待该文件执行结束。用法：新建一个类模块RunExe，贴上这段代码。
Option ExplicitPrivate Declare Function ShellExecuteEx Lib "shell32.dll" Alias "ShellExecuteExA" (lpExecInfo As SHELLEXECUTEINFO) As LongPrivate Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongPrivate Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As LongPrivate Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)Private Declare Function GetDesktopWindow Lib "user32" () As LongPrivate Type SHELLEXECUTEINFO&&&&&&&&cbSize As Long&&&&&&&&fMask As Long&&&&&&&&hwnd As Long&&&&&&&&lpVerb As String&&&&&&&&lpFile As String&&&&&&&&lpParameters As String&&&&&&&&lpDirectory As String&&&&&&&&nShow As Long&&&&&&&&hInstApp As Long&&&&&&&&\'&&Optional fields&&&&&&&&lpIDList As Long&&&&&&&&lpClass As String&&&&&&&&hkeyClass As Long&&&&&&&&dwHotKey As Long&&&&&&&&hIcon As Long&&&&&&&&hProcess As LongEnd TypePublic Function RunProc(CommandLine As String) As Boolean&&&&Dim ShellInfo As SHELLEXECUTEINFO&&&&With ShellInfo&&&&&&&&.cbSize = Len(ShellInfo)&&&&&&&&.hwnd = GetDesktopWindow&&&&&&&&.lpVerb = "open"&&&&&&&&.lpFile = CommandLine&&&&&&&&.nShow = vbNormalFocus&&&&&&&&.fMask = 64&&&&End With&&&&ShellExecuteEx ShellInfo&&&&If ShellInfo.hInstApp &= 32 Then&&&&&&&&MsgBox "无法打开" & CommandLine & "！", vbOKCancel + vbExclamation, "运行错误"&&&&&&&&RunProc = False&&&&Else&&&&&&&&Sleep 1000&&&&&&&&WaitForSingleObject ShellInfo.hProcess, &&&&&&&&CloseHandle ShellInfo.hProcess&&&&&&&&RunProc = True&&&&End IfEnd Function使用时，先定义对象：&&&&Dim Run As RunExe然后：&&&&Set Run = New RunExe&&&&If Run.RunProc(文件名) Then&&&&&&\'正常执行并关闭&&&&Else&&&&\'出错&&&&End If
--&&用API实现超链接\'声明API使用ShellExecute函数Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _&&&&&&ByVal hwnd As Long, _&&&&&&ByVal lpOperation As String, _&&&&&&ByVal lpFile As String, _&&&&&&ByVal lpParameters As String, _&&&&&&ByVal lpDirectory As String, _&&&&&&ByVal nShowCmd As Long) As LongPrivate Sub Label1_Click()Dim ret&ret& = ShellExecute(Me.hwnd, "Open", "录入超链接网址", "", App.Path, 1)End Sub
--&&交换鼠标按钮声明：Declare Function SwapMouseButton Lib "user32" Alias "SwapMouseButton" (ByVal bSwap As Long) As Long使用：bSwsp 值为 True ， 为交换状态，即左手习惯。bSwsp 值为 False， 为正常状态，即右手习惯。
--&&使程序的标题条闪烁
\'建立新的项目文件，添加模块文件，并填写如下代码：Public Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As Long\'在窗体中添加两个按钮和一个计时器，并用设置以下属性：command1.caption="开始"command2.caption="停止"timer1.interval=500 \'每0.5秒闪烁一次timer1.enabled=falsePrivate Sub Timer1_Timer()&&&&a& = FlashWindow(Me.hwnd, 1)End SubPrivate Sub Command1_Click()&&&&Timer1.Enabled = TrueEnd SubPrivate Sub Command2_Click()&&&&Timer1.Enabled = FalseEnd Sub
--&&得到鼠标位置声明：
Private Type POINTAPI&&&&x As Long&&&&y As LongEnd TypeDeclare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long例子：Dim p As POINTAPICall GetCursorPos( p )\' ( p.x, p.y )为鼠标位置
--&&设定鼠标位置声明：Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long例子：ret = SetCursorPos( X, Y) \'(X,Y)为坐标，单位为 Pixel(像素)
--&&突破 SendKeys 的限制SendKeys 不能实现一些特殊的键， 如 Alt+PrintScr 。 不过使用 API ，可以改变这样的状况。声明：Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal&&bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)使用：\' 一个抓屏的例子Const VK_SNAPSHOT As Byte = &H2C\' 把应用窗口图象放到剪贴板：Call keybd_event(VK_SNAPSHOT, 0, 0, 0)\'&&把整个屏幕抓到剪贴板：Call keybd_event(VK_SNAPSHOT, 1, 0, 0)可以用该方法抓 AVI 图象。
--&&得到以某字符分隔的字符串VB提供了Split函数,可以方便的实现上述问题：描述：返回一个下标从零开始的一维数组，它包含指定数目的子字符串。语法：Split(expression[, delimiter[, count[, compare]]])compare参数的设置值如下：常数&&&&&&&&&&&&&&&&&&&&&&&&&& 值&&&&描述 vbUseCompareOption&& &#8211;1&&&&用Option Compare语句中的设置值执行比较。 vbBinaryCompare&&&&&&&&&&0&&&& 执行二进制比较。 vbTextCompare&&&&&&&&&&&&1&&&&执行文字比较。 vbDatabaseCompare&&&&&&2&&&&仅用于Microsoft Access。基于您的数据库的信息执行比较 例如：StrTmp = "AAAAA" & vbTab & "BBBBB" & "AAAAA" & vbTab & "BBBBB"ArrTmp = Split(StrTmp, vbTab)得到:ArrTmp(0)="AAAAA"ArrTmp(1)="BBBBBAAAAA"ArrTmp(2)="BBBBB"
--&&怎样实现快速Excel导出导入?技巧:1 少用select动作 和 selection对象(这是最费时间的)2 可以这样写&&&&&& range(xls_Range).Borders().LineStyle = xlContinuous3 要写入很多数据的话 不要用循环写到Excel&& 先把数据写到数组里&& 用数组可以一次性写入(数组大小要和区域一样大)&& Eg:&&&&range("a1:c100") = ArrArr是一个(1 to 100, 1 to 3 ) 的数组&& 反之&&:&&&&Arr = range("a1:c100").value----------------------------------------------------------------------------------------例子:
\'export grid to excelPrivate Sub exportExcel(grid As EditGridCtrlLib.EditGridCtrl)Dim xlApp&&&&&& As Object&&&&&& \'*Excel.Application&&&&\'Dim xlBook&&&&&&As Object&&&&&& \'*Excel.Workbook&&&&&& \'Dim xlSheet&&&& As Object&&&&&& \'*Excel.Worksheet&&&&&&\'Dim cx&&&&&&&&&&As LongDim data()&&&&&&As StringDim cnt&&&&&&&& As Integer&&&&&&\' visible column\'s countDim curCol&&&&&&As LongDim i&&&&&&&&&& As IntegerDim j&&&&&&&&&& As Integer&&&&\' if no column need output,exit&&&&With grid&&&&&&&&cnt = 0&&&&&&&&For i = 0 To .Cols - 1&&&&&&&&&&&&If .ColWidth(i) & 0 Or .ColWidth(i) & 50 Then&&&&&&&&&&&&&&&&cnt = cnt + 1&&&&&&&&&&&&End If&&&&&&&&Next i&&&&End With&&&&&&&&If cnt = 0 Then&&&&&&&&Exit Sub&&&&End If&&&&&&&&cx = GetDeviceCaps(Me.hdc, LOGPIXELSY)&&&&&&&&g_Utility.WaiterBegin&&&&&&&&On Error GoTo err_proc&&&&&&&&Set xlApp = CreateObject("Excel.Application")&&&&Set xlBook = xlApp.Workbooks.Add&&&&Set xlSheet = xlBook.Worksheets(1)&&&&&&&&&&&&xlApp.ScreenUpdating = False&&&&\' begin to fill&&&&With Me.grdList&&&&&&&&ReDim data(.Rows - 1, cnt - 1)&&&&&&&&&&&&&&&&curCol = 0&&&&&&&&&&&&&&&&For i = 0 To .Cols - 1&&&&&&&&&&&&&&&&&&&&If .ColWidth(i) & 0 Or .ColWidth(i) & 50 Then&&&&&&&&&&&&&&&&For j = 0 To .Rows - 1&&&&&&&&&&&&&&&&&&&&data(j, curCol) = .TextMatrix(j, i)&&&&&&&&&&&&&&&&Next j&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&xlSheet.Columns(curCol + 1).Select&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&If Fix(.ColAlignment(i) / 3) = 0 Then&&&&&&&&&&&&&&&&&&&&xlApp.Selection.HorizontalAlignment = -4131 \' xlLeft&&&&&&&&&&&&&&&&End If&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&If Fix(.ColAlignment(i) / 3) = 1 Then&&&&&&&&&&&&&&&&&&&&xlApp.Selection.HorizontalAlignment = -4108 \' xlCenter&&&&&&&&&&&&&&&&End If&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&If Fix(.ColAlignment(i) / 3) = 2 Then&&&&&&&&&&&&&&&&&&&&xlApp.Selection.HorizontalAlignment = -4152 \' xlRight&&&&&&&&&&&&&&&&End If&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&\' resize column width&&&&&&&&&&&&&&&&xlSheet.Columns(curCol + 1).ColumnWidth = .ColWidth(CLng(i)) / cx&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&curCol = curCol + 1&&&&&&&&&&&&End If&&&&&&&&&&&&&&&&&&&&Next i&&&&End With&&&&&&&&With xlSheet&&&&&&&&.range(.cells(1, 1), .cells(Me.grdList.Rows, cnt)).value = data&&&&End With&&&&&&&&\' colheader align center&&&&xlSheet.Rows(1).Select&&&&xlApp.Selection.HorizontalAlignment = -4108 \' xlCenter&&&&xlApp.ActiveSheet.pagesetup.PrintGridlines = True&&&&&&&&If Me.grdList.FixedRows & 0 Then&&&&&&&&xlApp.ActiveSheet.pagesetup.PrintTitleRows = xlSheet.Rows(Me.grdList.FixedRows).Address&&&&End If&&&&&&&&If Me.grdList.FixedCols & 0 Then&&&&&&&&xlApp.ActiveSheet.pagesetup.PrintTitleColumns = xlSheet.Columns(Me.grdList.FixedCols).Address&&&&End If&&&&&&&&xlApp.ScreenUpdating = True&&&&xlApp.Visible = True&&&&xlApp.ActiveWorkbook.printPreview&&&&xlApp.DisplayAlerts = False&&&&xlApp.ActiveWorkbook.Close False&&&&xlApp.DisplayAlerts = True&&&&&&&&xlApp.Quit&&&&&&&&Set xlApp = Nothing&&&&Set xlBook = Nothing&&&&Set xlSheet = Nothing&&&&&&&&g_Utility.WaitEnd&&&&&&&&Exit Sub&&&&err_proc:&&&&g_Utility.WaitEnd&&&&If Not xlApp Is Nothing Then&&&&&&&&xlApp.Quit&&&&&&&&Set xlApp = Nothing&&&&End If&&&&g_ErrLog.ShowMessage Err&&&&End Sub说明：1、使用range.value一次性填充数据，可以极大地加快速度2、ScreenUpdating 设为false可以加快速度3、对不可见列不打印，并且根据grid来设置对齐方式4、迟绑定可以减少去excel版本的依赖性为什么使用这种方法而不是其它更快速的方法1、copyformrecordset&& 这样的话就需要一个ado的结果集才可以操作，而且对列的对齐、列头文本、不可见列的操作都无法进行2、querytable&& 由于在三层开发中客户端并没有办法直接访问数据库，同时它还存在着和上面一样的缺陷3、bcp&& 这个是最快的了 可是局限性同上
--&&得到字符串的拼音韵母
Option Explicit\'说明:\'1.使用先将用ZhuJiInit进行初始化\'2.使用GetStringZhuJi字符串的拼音助记字符串\' 设置过滤的字符串Public sFilter As String\' 定义区位表,用来存放该声母的区位区间,如声母为a的区间为-20319到-20284之间\' 所有包含在此区间的国标汉字的声母为aPublic Type TypePos&&Min As Long \'一个声母字符左区间&&Max As Long \'一个声母字符右区间&&cFirst As String \'保存声母字符End TypePublic tyChinaPos(26) As TypePos \'区位表Public sSecondPos As String&&&&&&\' 第二区位表\' 初始化各区位表中声母及区间Public Sub ZhuJiInit()Dim i As Integer \'总共23个声\' 二级汉字声母表，由于二级汉字是按偏旁排列的，所以其声母很难\' 把握，把声母表列出，求其汉字相对于第一个二级汉的偏移量，就可得其声母sSecondPos = "CJWGNSPGCGNE[Y[BTYYZDXYKYGT[JNMJQMBSGZSCYJSYY[PGKBZGY[YWJKGKLJYWKPJQHY[W[DZLSGMRYPYWWCCKZNKYYGTTNJJNYKKZYTCJNMCYLQLYPYQFQRPZSLWBTGKJFYXJWZLTBNCXJJJJTXDTTSQZYCDXXHGCK[PHFFSS[YBGXLPPBYLL[HLXS[ZM[JHSOJNG" & _&&&&&&&&&&&&&&"HDZQYKLGJHSGQZHXQGKEZZWYSCSCJXYEYXADZPMDSSMZJZQJYZC[J[WQJBYZPXGZNZCPWHKXHQKMWFBPBYDTJZZKQHYLYGXFPTYJYYZPSZLFCHMQSHGMXXSXJ[[DCSBBQBEFSJYHXWGZKPYLQBGLDLCCTNMAYDDKSSNGYCSGXLYZAYBNPTSDKDYLHGYMYLCXPY[JNDQJ" & _&&&&&&&&&&&&&&"WXQXFYYFJLEJPZRXCCQWQQSBNKYMGPLBMJRQCFLNYMYQMSQYRBCJTHZTQFRXQHXMJJCJLXQGJMSHZKBSWYEMYLTXFSYDSWLYCJQXSJNQBSCTYHBFTDCYZDJWYGHQFRXWCKQKXEBPTLPXJZSRMEBWHJLBJSLYYSMDXLCLQKXLHXJRZJMFQHXHWYWSBHTRXXGLHQHFNM[Y" & _&&&&&&&&&&&&&&"KLDYXZPYLGG[MTCFPAJJZYLJTYANJGBJPLQGDZYQYAXBKYSECJSZNSLYZHSXLZCGHPXZHZNYTDSBCJKDLZAYFMYDLEBBGQYZKXGLDNDNYSKJSHDLYXBCGHXYPKDJMMZNGMMCLGWZSZXZJFZNMLZZTHCSYDBDLLSCDDNLKJYKJSYCJLKWHQASDKNHCSGANHDAASHTCPLC" & _&&&&&&&&&&&&&&"PQYBSDMPJLPZJOQLCDHJJYSPRCHN[NNLHLYYQYHWZPTCZGWWMZFFJQQQQYXACLBHKDJXDGMMYDJXZLLSYGXGKJRYWZWYCLZMSSJZLDBYD[FCXYHLXCHYZJQ[[QAGMNYXPFRKSSBJLYXYSYGLNSCMHZWWMNZJJLXXHCHSY[[TTXRYCYXBYHCSMXJSZNPWGPXXTAYBGAJC" & _&&&&&&&&&&&&&&"XLY[DCCWZOCWKCCSBNHCPDYZNFCYYTYCKXKYBSQKKYTQQXFCWCHCYKELZQBSQYJQCCLMTHSYWHMKTLKJLYCXWHEQQHTQH[PQ[QSCFYMNDMGBWHWLGSLLYSDLMLXPTHMJHWLJZYHZJXHTXJLHXRSWLWZJCBXMHZQXSDZPMGFCSGLSXYMJSHXPJXWMYQKSMYPLRTHBXFTP" & _&&&&&&&&&&&&&&"MHYXLCHLHLZYLXGSSSSTCLSLDCLRPBHZHXYYFHB[GDMYCNQQWLQHJJ[YWJZYEJJDHPBLQXTQKWHLCHQXAGTLXLJXMSL[HTZKZJECXJCJNMFBY[SFYWYBJZGNYSDZSQYRSLJPCLPWXSDWEJBJCBCNAYTWGMPAPCLYQPCLZXSBNMSGGFNZJJBZSFZYNDXHPLQKZCZWALSB" & _&&&&&&&&&&&&&&"CCJX[YZGWKYPSGXFZFCDKHJGXDLQFSGDSLQWZKXTMHSBGZMJZRGLYJBPMLMSXLZJQQHZYJCZYDJWBMYKLDDPMJEGXYHYLXHLQYQHKYCWCJMYYXNATJHYCCXZPCQLBZWWYTWBQCMLPMYRJCCCXFPZNZZLJPLXXYZTZLGDLDCKLYRZZGQTGJHHGJLJAXFGFJZSLCFDQZLC" & _&&&&&&&&&&&&&&"LGJDJCSNZLLJPJQDCCLCJXMYZFTSXGCGSBRZXJQQCTZHGYQTJQQLZXJYLYLBCYAMCSTYLPDJBYREGKLZYZHLYSZQLZNWCZCLLWJQJJJKDGJZOLBBZPPGLGHTGZXYGHZMYCNQSYCYHBHGXKAMTXYXNBSKYZZGJZLQJDFCJXDYGJQJJPMGWGJJJPKQSBGBMMCJSSCLPQPD" & _&&&&&&&&&&&&&&"XCDYYKY[CJDDYYGYWRHJRTGZNYQLDKLJSZZGZQZJGDYKSHPZMTLCPWNJAFYZDJCNMWESCYGLBTZCGMSSLLYXQSXSBSJSBBSGGHFJLYPMZJNLYYWDQSHZXTYYWHMZYHYWDBXBTLMSYYYFSXJC[DXXLHJHF[SXZQHFZMZCZTQCXZXRTTDJHNNYZQQMNQDMMG[YDXMJGDHC" & _&&&&&&&&&&&&&&"DYZBFFALLZTDLTFXMXQZDNGWQDBDCZJDXBZGSQQDDJCMBKZFFXMKDMDSYYSZCMLJDSYNSBRSKMKMPCKLGDBQTFZSWTFGGLYPLLJZHGJ[GYPZLTCSMCNBTJBQFKTHBYZGKPBBYMTDSSXTBNPDKLEYCJNYDDYKZDDHQHSDZSCTARLLTKZLGECLLKJLQJAQNBDKKGHPJTZQ" & _&&&&&&&&&&&&&&"KSECSHALQFMMGJNLYJBBTMLYZXDCJPLDLPCQDHZYCBZSCZBZMSLJFLKRZJSNFRGJHXPDHYJYBZGDLQCSEZGXLBLGYXTWMABCHECMWYJYZLLJJYHLG[DJLSLYGKDZPZXJYYZLWCXSZFGWYYDLYHCLJSCMBJHBLYZLYCBLYDPDQYSXQZBYTDKYXJY[CNRJMPDJGKLCLJBC" & _&&&&&&&&&&&&&&"TBJDDBBLBLCZQRPPXJCJLZCSHLTOLJNMDDDLNGKAQHQHJGYKHEZNMSHRP[QQJCHGMFPRXHJGDYCHGHLYRZQLCYQJNZSQTKQJYMSZSWLCFQQQXYFGGYPTQWLMCRNFKKFSYYLQBMQAMMMYXCTPSHCPTXXZZSMPHPSHMCLMLDQFYQXSZYJDYJZZHQPDSZGLSTJBCKBXYQZJ" & _&&&&&&&&&&&&&&"SGPSXQZQZRQTBDKYXZKHHGFLBCSMDLDGDZDBLZYYCXNNCSYBZBFGLZZXSWMSCCMQNJQSBDQSJTXXMBLTXZCLZSHZCXRQJGJYLXZFJPHYMZQQYDFQJJLZZNZJCDGZYGCTXMZYSCTLKPHTXHTLBJXJLXSCDQXCBBTJFQZFSLTJBTKQBXXJJLJCHCZDBZJDCZJDCPRNPQCJ" & _&&&&&&&&&&&&&&"PFCZLCLZXZDMXMPHJSGZGSZZQLYLWTJPFSYASMCJBTZKYCWMYTCSJJLJCQLWZMALBXYFBPNLSFHTGJWEJJXXGLLJSTGSHJQLZFKCGNNNSZFDEQFHBSAQTGYLBXMMYGSZLDYDQMJJRGBJTKGDHGKBLQKBDMBYLXWCXYTTYBKMRTJZXQJBHLMHMJJZMQASLDCYXYQDLQCAFYWYXQHZ"\' 一级汉字是按声母顺序排列的,所以求其第一个汉字的值,和最后一个汉字的值,如果要求汉字的值\' 在第一个汉字和最后一个汉字之间,则其声母就为这个区间的声母.\' 如:一个汉字的值为-20300(汉字的值小于零),则在a的区间内因此,此汉字的声母为ai = 0 \'字母atyChinaPos(i).cFirst = Chr(97)tyChinaPos(i).Min = -20319tyChinaPos(i).Max = -20284i = i + 1 \'字母btyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -20283tyChinaPos(i).Max = -19776i = i + 1 \'ctyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -19775tyChinaPos(i).Max = -19219i = i + 1 \'dtyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -19218tyChinaPos(i).Max = -18711i = i + 1 \'etyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -18710tyChinaPos(i).Max = -18527i = i + 1 \'ftyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -18526tyChinaPos(i).Max = -18240i = i + 1 \'gtyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -18239tyChinaPos(i).Max = -17923i = i + 1 \'htyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -17922tyChinaPos(i).Max = -17418i = i + 2&&\'jtyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -17417tyChinaPos(i).Max = -16475i = i + 1 \'ktyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -16474tyChinaPos(i).Max = -16213i = i + 1 \'ltyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -16212tyChinaPos(i).Max = -15641i = i + 1 \'mtyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -15640tyChinaPos(i).Max = -15166i = i + 1 \'ntyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -15165tyChinaPos(i).Max = -14923i = i + 1 \'otyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -14922tyChinaPos(i).Max = -14915i = i + 1 \'ptyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -14914tyChinaPos(i).Max = -14631i = i + 1 \'qtyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -14630tyChinaPos(i).Max = -14150i = i + 1 \'rtyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -14149tyChinaPos(i).Max = -14091i = i + 1 \'styChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -14090tyChinaPos(i).Max = -13319i = i + 1 \'ttyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -13318tyChinaPos(i).Max = -12839i = i + 3 \'wtyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -12838tyChinaPos(i).Max = -12557i = i + 1 \'xtyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -12556tyChinaPos(i).Max = -11848i = i + 1 \'ytyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -11847tyChinaPos(i).Max = -11056i = i + 1 \'ztyChinaPos(i).cFirst = Chr(i + 97)tyChinaPos(i).Min = -11055tyChinaPos(i).Max = -10247End Sub\' 给定一个字符串返回这个字符串的拼音助记字符串Public Function GetStringZhuJi(strS As String) As StringDim i As IntegerDim strRet As StringstrRet = ""&&\'设置返回的字符串为空For i = 1 To Len(strS)&&&& If CharFilter(Mid(strS, i, 1)) = False Then \'则说明过滤掉了&&&&&&&&\'如果没有过滤掉,则返回其小写字母&&&&&&&&strRet = strRet + LCase(Mid(strS, i, 1))&&&& ElseIf Asc(Mid(strS, i, 1)) & 0 Then \'说明是汉字，则求其第一个字母&&&&&&&&strRet = strRet + GetChinaChar(Mid(strS, i, 1)) \'则将前面的拼音助记与返回的拼音合并&&&& \' 如果为0到9之间的数字,则不改变原来的数字&&&& ElseIf Mid(strS, i, 1) &= "0" And Mid(strS, i, 1) &= "9" Then \'否则不是汉字则返回小写字母&&&&&&&&strRet = strRet + LCase(Mid(strS, i, 1))&&&& \' 如果为A到Z之间的字母,则转换为小写字母&&&& ElseIf Mid(strS, i, 1) &= "A" And Mid(strS, i, 1) &= "Z" Then&&&&&&&&strRet = strRet + LCase(Mid(strS, i, 1))&&&& \' 如果为a到z之间的字母,则不改变原来的字母&&&& ElseIf Mid(strS, i, 1) &= "a" And Mid(strS, i, 1) &= "z" Then&&&&&&&&strRet = strRet + LCase(Mid(strS, i, 1))&&&& \' 其他则为非法字符,将被过滤掉&&&& End IfNext iGetStringZhuJi = strRet \'将求得的拼音助记码返回End Function\' 把字符串过滤，如果包含要过滤的字符串则过滤掉Public Function CharFilter(strS As String) As Boolean&&Dim i As Integer&&Dim bRet As Boolean&&bRet = True&&\' 如果用户没有设置过滤字符串，则返回真，&&\' 如果设置了则按用户设置的过滤字符串，则过滤strS字符串中的字符&&If sFilter = "" And Trim(sFilter) = "" Then&&&& bRet = True&&Else&&&& For i = 1 To Len(sFilter)&&&&&&&& If Mid(sFilter, i, 1) = strS Then&&&&&&&&&&&&bRet = False&&&&&&&&&&&&Exit For&&&&&&&& End If&&&& Next i&&End If&&CharFilter = bRetEnd Function\' 得到一个汉字的第一个字母,并且返回Public Function GetChinaChar(strSt As String) As StringDim i As IntegerDim iPos As LongDim strRetF As StringstrRetF = ""\' 如果是一级汉字,遍历其值所在的区间If Asc(strSt) &= -20319 And Asc(strSt) &= -10247 Then&&&&For i = 0 To 25&& \'查找区位表中有符合条件的,如果有则返回相应的声母&&&&&&&&If Asc(strSt) &= tyChinaPos(i).Min And Asc(strSt) &= tyChinaPos(i).Max Then&&&&&&&&&& strRetF = tyChinaPos(i).cFirst&&&&&&&&&& Exit For&&&&&&&&End If&&&&Next i\' 如果是二级汉字,则算其所在的区并求出偏移量,从而求出其声母ElseIf Asc(strSt) &= -10079 And Asc(strSt) & -2050 Then&&&&iPos = Asc(strSt) + 10080 - ((Asc(strSt) + 10079) \\ 256) * 162&&&&strRetF = LCase(Mid(sSecondPos, iPos, 1))End IfGetChinaChar = strRetF \'将声母返回End Function\' 给定一个字符串返回这个字符串的拼音助记字符串Public Function GetStringZhuJi(strS As String) As StringDim i As IntegerDim strRet As StringstrRet = ""&&\'设置返回的字符串为空For i = 1 To Len(strS)&&&& If CharFilter(Mid(strS, i, 1)) = False Then \'则说明过滤掉了&&&&&&&&\'如果没有过滤掉,则返回其小写字母&&&&&&&&strRet = strRet + LCase(Mid(strS, i, 1))&&&& ElseIf Asc(Mid(strS, i, 1)) & 0 Then \'说明是汉字，则求其第一个字母&&&&&&&&strRet = strRet + GetChinaChar(Mid(strS, i, 1)) \'则将前面的拼音助记与返回的拼音合并&&&& \' 如果为0到9之间的数字,则不改变原来的数字&&&& ElseIf Mid(strS, i, 1) &= "0" And Mid(strS, i, 1) &= "9" Then \'否则不是汉字则返回小写字母&&&&&&&&strRet = strRet + LCase(Mid(strS, i, 1))&&&& \' 如果为A到Z之间的字母,则转换为小写字母&&&& ElseIf Mid(strS, i, 1) &= "A" And Mid(strS, i, 1) &= "Z" Then&&&&&&&&strRet = strRet + LCase(Mid(strS, i, 1))&&&& \' 如果为a到z之间的字母,则不改变原来的字母&&&& ElseIf Mid(strS, i, 1) &= "a" And Mid(strS, i, 1) &= "z" Then&&&&&&&&strRet = strRet + LCase(Mid(strS, i, 1))&&&& \' 其他则为非法字符,将被过滤掉&&&& End IfNext iGetStringZhuJi = strRet \'将求得的拼音助记码返回End Function\' 把字符串过滤，如果包含要过滤的字符串则过滤掉Public Function CharFilter(strS As String) As Boolean&&Dim i As Integer&&Dim bRet As Boolean&&bRet = True&&\' 如果用户没有设置过滤字符串，则返回真，&&\' 如果设置了则按用户设置的过滤字符串，则过滤strS字符串中的字符&&If sFilter = "" And Trim(sFilter) = "" Then&&&& bRet = True&&Else&&&& For i = 1 To Len(sFilter)&&&&&&&& If Mid(sFilter, i, 1) = strS Then&&&&&&&&&&&&bRet = False&&&&&&&&&&&&Exit For&&&&&&&& End If&&&& Next i&&End If&&CharFilter = bRetEnd Function\' 得到一个汉字的第一个字母,并且返回Public Function GetChinaChar(strSt As String) As StringDim i As IntegerDim iPos As LongDim strRetF As StringstrRetF = ""\' 如果是一级汉字,遍历其值所在的区间If Asc(strSt) &= -20319 And Asc(strSt) &= -10247 Then&&&&For i = 0 To 25&& \'查找区位表中有符合条件的,如果有则返回相应的声母&&&&&&&&If Asc(strSt) &= tyChinaPos(i).Min And Asc(strSt) &= tyChinaPos(i).Max Then&&&&&&&&&& strRetF = tyChinaPos(i).cFirst&&&&&&&&&& Exit For&&&&&&&&End If&&&&Next i\' 如果是二级汉字,则算其所在的区并求出偏移量,从而求出其声母ElseIf Asc(strSt) &= -10079 And Asc(strSt) & -2050 Then&&&&iPos = Asc(strSt) + 10080 - ((Asc(strSt) + 10079) \\ 256) * 162&&&&strRetF = LCase(Mid(sSecondPos, iPos, 1))End IfGetChinaChar = strRetF \'将声母返回End Function
--&&利用注册表获得"我的文档"的目录大家都知道注册表的强大功能吧！其实很多默认的路径都在&#8220;hkey_current_user\\software\\microsoft\\windows\\currentversion\\explorer\\shell folders&#8221;之中，大家可以看看。下面就是利用注册表获得我的文档的源代码。option explicit\' 这个模块用于读和写注册表关键字。\' 不同于vb 的内部注册表访问方法，它可以\' 通过字符串的值来读和写任何注册表关键字。\'---------------------------------------------------------------\'-注册表 api 声明...\'---------------------------------------------------------------private declare function regclosekey lib "advapi32" (byval hkey as long) as longprivate declare function regcreatekeyex lib "advapi32" alias "regcreatekeyexa" (byval hkey as long, byval lpsubkey as string, byval reserved as long, byval lpclass as string, byval dwoptions as long, byval samdesired as long, byref lpsecurityattributes as security_attributes, byref phkresult as long, byref lpdwdisposition as long) as longprivate declare function regopenkeyex lib "advapi32" alias "regopenkeyexa" (byval hkey as long, byval lpsubkey as string, byval uloptions as long, byval samdesired as long, byref phkresult as long) as longprivate declare function regqueryvalueex lib "advapi32" alias "regqueryvalueexa" (byval hkey as long, byval lpvaluename as string, byval lpreserved as long, byref lptype as long, byval lpdata as string, byref lpcbdata as long) as longprivate declare function regsetvalueex lib "advapi32" alias "regsetvalueexa" (byval hkey as long, byval lpvaluename as string, byval reserved as long, byval dwtype as long, byval lpdata as string, byval cbdata as long) as long\'---------------------------------------------------------------\'- 注册表 api 常数...\'---------------------------------------------------------------\' reg data types...const reg_sz = 1&&&&&&&&&&&&&&\' unicode空终结字符串const reg_expand_sz = 2&&&&&& \' unicode空终结字符串const reg_dword = 4&&&&&&&&&& \' 32-bit 数字\' 注册表创建类型值...const reg_option_non_volatile = 0&&\' 当系统重新启动时，关键字被保留\' 注册表关键字安全选项...const read_control = &h20000const key_query_value = &h1const key_set_value = &h2const key_create_sub_key = &h4const key_enumerate_sub_keys = &h8const key_notify = &h10const key_create_link = &h20const key_read = key_query_value + key_enumerate_sub_keys + key_notify + read_controlconst key_write = key_set_value + key_create_sub_key + read_controlconst key_execute = key_readconst key_all_access = key_query_value + key_set_value + _&&&&&&&&&&&&&&&&&&&&&& key_create_sub_key + key_enumerate_sub_keys + _&&&&&&&&&&&&&&&&&&&&&& key_notify + key_create_link + read_control\' 注册表关键字根类型...const hkey_classes_root = &hconst hkey_current_user = &hconst hkey_local_machine = &hconst hkey_users = &hconst hkey_performance_data = &h\' 返回值...const error_none = 0const error_badkey = 2const error_access_denied = 8const error_success = 0\'---------------------------------------------------------------\'- 注册表安全属性类型...\'---------------------------------------------------------------private type security_attributes&&&&nlength as long&&&&lpsecuritydescriptor as long&&&&binherithandle as booleanend type\'-------------------------------------------------------------------------------------------------\'sample usage - debug.print getkeyvalue(hkey_classes_root, "comctl.listviewctrl.1\\clsid", "")\'-------------------------------------------------------------------------------------------------public function getkeyvalue(keyroot as long, keyname as string, subkeyref as string) as string&&&&dim i as long&&&&&&&&&&&&&&&&\' 循环计数器&&&&dim rc as long&&&&&&&&&&&&&& \' 返回代码&&&&dim hkey as long&&&&&&&&&&&& \' 处理打开的注册表关键字&&&&dim hdepth as long&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&dim skeyval as string&&&&dim lkeyvaltype as long&&&&&&\' 注册表关键字数据类型&&&&dim tmpval as string&&&&&&&& \' 注册表关键字的临时存储器&&&&dim keyvalsize as long&&&&&& \' 注册表关键字变量尺寸&&&&\' 在 keyroot {hkey_local_machine...} 下打开注册表关键字&&&&\'------------------------------------------------------------&&&&rc = regopenkeyex(keyroot, keyname, 0, key_all_access, hkey) \' 打开注册表关键字&&&&if (rc && error_success) then goto getkeyerror&&\' 处理错误...&&&&tmpval = string$(1024, 0)&&&& \' 分配变量空间&&&&keyvalsize = 1024&&&&&&&&&&&& \' 标记变量尺寸&&&&\'------------------------------------------------------------&&&&\' 检索注册表关键字的值...&&&&\'------------------------------------------------------------&&&&rc = regqueryvalueex(hkey, subkeyref, 0, _&&&&&&&&&&&&&&&&&&&&&&&& lkeyvaltype, tmpval, keyvalsize)&& \' 获得/创建关键字的值&&&&if (rc && error_success) then goto getkeyerror&&&&&&&&&&\' 错误处理&&&&&&&&&&tmpval = left$(tmpval, instr(tmpval, chr(0)) - 1)&&&&\'------------------------------------------------------------&&&&\' 决定关键字值的转换类型...&&&&\'------------------------------------------------------------&&&&select case lkeyvaltype&&&&&&&&&&&&&&&& \' 搜索数据类型...&&&&case reg_sz, reg_expand_sz&&&&&&&&&&&&&&\' 字符串注册表关键字数据类型&&&&&&&&skeyval = tmpval&&&&&&&&&&&&&&&&&&&&\' 复制字符串的值&&&&case reg_dword&&&&&&&&&&&&&&&&&&&&&&&&&&\' 四字节注册表关键字数据类型&&&&&&&&for i = len(tmpval) to 1 step -1&&&&\' 转换每一位&&&&&&&&&&&&skeyval = skeyval + hex(asc(mid(tmpval, i, 1)))&& \' 一个字符一个字符地生成值。&&&&&&&&next&&&&&&&&skeyval = format$("&h" + skeyval)&& \' 转换四字节为字符串&&&&end select&&&&&&&&getkeyvalue = skeyval&&&&&&&&&&&&&&&&&& \' 返回值&&&&rc = regclosekey(hkey)&&&&&&&&&&&&&&&&&&\' 关闭注册表关键字&&&&exit function&&&&&&&&&&&&&&&&&&&&&&&&&& \' 退出&&&&getkeyerror:&&&&\' 错误发生过后进行清除...&&&&getkeyvalue = vbnullstring&&&&&&&&&&&&&&\' 设置返回值为空字符串&&&&rc = regclosekey(hkey)&&&&&&&&&&&&&&&&&&\' 关闭注册表关键字end functionpublic function getmydocumentspath() as string&&getmydocumentspath = getkeyvalue(hkey_current_user, "software\\microsoft\\windows\\currentversion\\explorer\\shell folders", "personal")end function
--&&获得Win的系统安装路径
使用 getwindowsdirectory 和 getsystemdirectory 可以分别获得 windows 目录和 windows 系统目录。
下面是获得的具体源代码，在粘贴源代码之前必须新建一个模块。粘贴后，在整个工程中都可以使用 getwindir 和 getsysdir 函数。
option explicit
\'声明获得 windows 路径和 windows 系统路径的 api\'private declare functio n getwindowsdirectory lib "kernel32" alias "getwindowsdirectorya" (byval lpbuffer as string, byval nsize as long) as longprivate declare functio n getsystemdirectory lib "kernel32" alias "getsystemdirectorya" (byval lpbuffer as string, byval nsize as long) as long
public functio n getwindir() as string&&dim result as long&&&&&&&&&&\'返回的结果\'&&dim strbuffer as string&&&& \'数据缓冲区\'&&dim dirlength as long&&&&&& \'表示数据大小\'&&&& \'获得路径的大小\'&&dirlength = GetWindowsDirectory(, 0)&&&& \'设置有缓冲区空格的数目\'&&strbuffer = space(dirlength)&&&& \'获得路径\'&&result = GetWindowsDirectory(strbuffer, dirlength)&&&& \'返回数据\'&&if result && 0 then&&&& \'删除空中止之后的内容\'&&&&getwindir = left(strbuffer, dirlength)&&end ifend functio n
public functio n getsysdir() as string&&dim result as long&&&&&&&&&&\'返回的结果\'&&dim strbuffer as string&&&& \'数据缓冲区\'&&dim dirlength as long&&&&&& \'表示数据大小\'&&&& \'获得路径的大小\'&&dirlength = getsystemdirectory(, 0)&&&& \'设置有缓冲区空格的数目\'&&strbuffer = space(dirlength)&&&& \'获得路径\'&&result = getsystemdirectory(strbuffer, dirlength)&&&& \'返回数据\'&&if result && 0 then&&&& \'删除空中止之后的内容\'&&&&getsysdir = left(strbuffer, dirlength)&&end ifend functio n
--&&使用VB获得一页的HTML代码加入WebBrowser、Timer、CommandButton控件各一个，然后使用以下代码：
Private Sub Command1_Click()WebBrowser1.Navigate "/bbs"Timer1.Enabled = TrueEnd SubPrivate Sub Timer1_Timer()Dim doc, objhtml As ObjectDim i As IntegerDim strhtml As StringIf Not WebBrowser1.Busy ThenSet doc = WebBrowser1.Documenti = 0Set objhtml = doc.body.createtextrange()If Not IsNull(objhtml) ThenText1.Text = objhtml.htmltextEnd IfTimer1.Enabled = FalseEnd IfEnd Sub
--&&将数字金额转成大写金额以下算法未处理零的习惯叫法
Function ChangeMoney(ByVal vMoney As Double) As String\'将数字金额转成大写金额 (小于亿亿)\'llp &&&&Dim i As Integer&&&&Dim StrMod(17) As String&&&&Dim Money As String&&&&Dim MoneyStr As String&&&&Dim StrMoneyMod(9) As String&&&&&&&&On Error GoTo MyErr: \'初始化错误代码&&&&&&&&StrMoneyMod(0) = "零"&&&&StrMoneyMod(1) = "壹"&&&&StrMoneyMod(2) = "贰"&&&&StrMoneyMod(3) = "叁"&&&&StrMoneyMod(4) = "肆"&&&&StrMoneyMod(5) = "伍"&&&&StrMoneyMod(6) = "陆"&&&&StrMoneyMod(7) = "柒"&&&&StrMoneyMod(8) = "捌"&&&&StrMoneyMod(9) = "玖"&&&&&&StrMod(0) = "正"&&&&StrMod(1) = "分"&&&&StrMod(2) = "角"&&&&StrMod(4) = "元"&&&&StrMod(5) = "拾"&&&&StrMod(6) = "佰"&&&&StrMod(7) = "仟"&&&&StrMod(8) = "万"&&&&StrMod(9) = "拾"&&&&StrMod(10) = "佰"&&&&StrMod(11) = "仟"&&&&StrMod(12) = "亿"&&&&StrMod(13) = "拾"&&&&StrMod(14) = "佰"&&&&StrMod(15) = "仟"&&&&StrMod(16) = "万"&&&&StrMod(17) = "亿"&&&&&&&&Money = CStr(Format(vMoney, "###0.00"))&&&&MoneyStr = ""&&&&For i = 1 To Len(Money)&&&&&&If i && 3 Then&&&&&&&&MoneyStr = StrMoneyMod(Mid(Money, Len(Money) - i + 1, 1)) & StrMod(i) & MoneyStr&&&&&&End If&&&&Next&&&&ChangeMoney = MoneyStr&&&&Exit Function&&&&MyErr:&&\'金额过大返回错误信息 空值&& ChangeMoney = ""End Function以下算法处理零的习惯叫法
Function ChangeMoney2(ByVal vMoney As Double) As String\'将数字金额转成大写金额\'llp &&&&Dim i As Integer&&&&Dim Num As Integer&&&&Dim StrMoneyTmp As String&&&&Dim IsAll0 As Boolean&&&&Dim StrMod(17) As String&&&&Dim Money As String&&&&Dim MoneyStr As String&&&&Dim StrMoneyMod(9) As String&&&&&& \' On Error GoTo MyErr: \'初始化错误代码&&&&&&&&StrMoneyMod(0) = "零"&&&&StrMoneyMod(1) = "壹"&&&&StrMoneyMod(2) = "贰"&&&&StrMoneyMod(3) = "叁"&&&&StrMoneyMod(4) = "肆"&&&&StrMoneyMod(5) = "伍"&&&&StrMoneyMod(6) = "陆"&&&&StrMoneyMod(7) = "柒"&&&&StrMoneyMod(8) = "捌"&&&&StrMoneyMod(9) = "玖"&&&&&&StrMod(0) = "整"&&&&StrMod(1) = "分"&&&&StrMod(2) = "角"&&&&StrMod(4) = "元"&&&&StrMod(5) = "拾"&&&&StrMod(6) = "佰"&&&&StrMod(7) = "仟"&&&&StrMod(8) = "万"&&\'*&&&&StrMod(9) = "拾"&&&&StrMod(10) = "佰"&&&&StrMod(11) = "仟"&&&&StrMod(12) = "亿" \'*&&&&StrMod(13) = "拾"&&&&StrMod(14) = "佰"&&&&StrMod(15) = "仟"&&&&&&&&&&&&IsAll0 = True&&&&&&&&Money = Right(CStr(Format(Val(vMoney), "###0.00")), 15)&&&&&&&&Num = 1&&&&MoneyStr = ""&&&&StrMoneyTmp = ""&&&&For i = 1 To Len(Money)&&&&&&If i = 1 And Val(Right(Money, 2)) = 0 Then&&&&&&&&If Mid(Money, Len(Money) - 4 + 1, 1) = 0 Then&&&&&&&&&&MoneyStr = "元整"&&&&&&&&Else&&&&&&&&&&MoneyStr = "整"&&&&&&&&End If&&&&&&&&i = 3&&&&&&End If&&&&&&If i && 3 Then&&&&&&&&If Not (Mid(Money, Len(Money) - i + 1, 1) = 0 And Num = 0) Or i = 8 Or i = 12 Then&&&&&&&&&&&&Num = Mid(Money, Len(Money) - i + 1, 1)&&&&&&&&&&&&If IsAll0 = True And Num && 0 Then&&&&&&&&&&&&&&IsAll0 = False&&&&&&&&&&&&End If&&&&&&&&&&&&If IsAll0 = False Then&&&&&&&&&&&&&&If Num = 0 And i = 8 Then&&&&&&&&&&&&&&&&MoneyStr = IIf(Val(Mid(Money, Len(Money) - (i + 2), 3)) & 0, "万", "") & MoneyStr&&&&&&&&&&&&&&Else&&&&&&&&&&&&&&&&If Num = 0 And i = 12 Then&&&&&&&&&&&&&&&&&&MoneyStr = "亿" & MoneyStr&&&&&&&&&&&&&&&&Else&&&&&&&&&&&&&&&&&&MoneyStr = StrMoneyMod(Num) & IIf(Num = 0, "", StrMod(i)) & MoneyStr&&&&&&&&&&&&&&&&End If&&&&&&&&&&&&&&End If&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&End If&&&&&&&&End If&&&&&& &&&&&&End If&&&&Next&&&&ChangeMoney2 = MoneyStr&&&&Exit Function&&&&MyErr:&&\'金额过大返回错误信息 空值&& ChangeMoney2 = ""End Function
--&&利用API函数SendMessage在Richtextbox控件中插入图片（类似MSN的聊天表情）
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&&&&&&&#8216;函数声明Private Sub Command1_Click()&&&&Clipboard.Clear&&&&Clipboard.SetData LoadPicture(App.Path & "\\Face.bmp")&&&&SendMessage RichTextBox1.hwnd, &H302, 0, ByVal 0&End Sub
--&&得到word文件内容及字体
Option Explicit\'本工程要增加引用:Microsoft Word 9.0 Object Library\'放个Text控件text1与一个Command控件Command1,将text1的MultiLine设置为True ScrollBars:3Private Sub Command1_Click()Dim filename As String&&&&Dim wapp As New Word.Application&&&&Dim WordsObj As Object&&&&Dim wdoc As Word.Document&&&&Dim i As Integer&&&&filename = "C:\\1.doc"&&&&Set wdoc = wapp.Documents.Open(filename)&&&&Set WordsObj = wdoc.Range.Words&&&&&&&&Text1.Text = "-------------------------说明---------------------------" & vbCrLf & "[内容]" & vbCrLf&&&&Text1.Text = Text1.Text & "字体:字体名/粗体/斜体/下划线/下划线色/字体大小/字体色" & vbCrLf&&&&Text1.Text = Text1.Text & "--------------------------------------------------------" & vbCrLf & vbCrLf&&&&For i = 1 To WordsObj.Count&&&&&&WordsObj.Item (i)&&&&&&&&&&&&Text1.Text = Text1.Text & "[" & WordsObj.Item(i).Text & " & vbCrLf&&&&&&\'字体:字体名/粗体/斜体/下划线/下划线色/字体大小/字体色&&&&&&Text1.Text = Text1.Text & "字体:" _&&&&&&&&&&&&&&&&&& & WordsObj.Item(i).Font.Name & "/" _&&&&&&&&&&&&&&&&&& & WordsObj.Item(i).Font.Bold & "/" _&&&&&&&&&&&&&&&&&& & WordsObj.Item(i).Font.Italic & "/" _&&&&&&&&&&&&&&&&&& & WordsObj.Item(i).Font.Underline & "/" _&&&&&&&&&&&&&&&&&& & WordsObj.Item(i).Font.UnderlineColor & "/" _&&&&&&&&&&&&&&&&&& & WordsObj.Item(i).Font.Size & "/" _&&&&&&&&&&&&&&&&&& & WordsObj.Item(i).Font.Color & _&&&&&&&&&&&&&&&&&& vbCrLf & vbCrLf&&&&Next i&&&&wdoc.Close&&&&Set wdoc = Nothing&&&&End Sub
environ("windir")
得到windows系统目录
--&&如何取消 TextBox 鼠标右键的 PopupMenu 功能
自从 Microsoft Windows 进入 Windows95 之后，有一个很方便的功能，很多软件都有提供，就是鼠标右键的 PopupMenu 功能，它确实很方便，但是有时却是梦魇，那就是您不需要它的时候，它还是会自动出现！本例中的 TextBox 就是明显的例子。但是这个梦魇从 VB5.0 以后就可以解决了，因为 VB5.0 提供了 AdressOf 这个运算子，可以做回呼(callback)处理！请将以下的程序码放在 .bas 模组中，呼叫 Hook 这个 Sub 并传入 TextBox 的 hWnd 当作参数，但是切记您在 Unload Form 之前一定要呼叫 UnHook 这个 Sub，否则会产生一个 General Protection Fault！Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongDeclare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic Const GWL_WNDPROC = -4Public Const WM_RBUTTONUP = &H205Public lpPrevWndProc As LongPrivate lngHWnd As LongPublic Sub Hook(hWnd As Long)lngHWnd = hWndlpPrevWndProc = SetWindowLong(lngHWnd, GWL_WNDPROC, AddressOf WindowProc)End SubPublic Sub UnHook()Dim lngReturnValue As LonglngReturnValue = SetWindowLong(lngHWnd, GWL_WNDPROC, lpPrevWndProc)End SubFunction WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongSelect Case uMsgCase WM_RBUTTONUP\'Do nothing\'Or popup you own menuCase ElseWindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)End SelectEnd Function在 Form_Load 事件中加入以下程序码：Call Hook(Text1.hWnd)在 Form_Unload 中加入以下程序码：Call UnHook
--&&用VB编写键盘拦截程序我们知道，在一些程序中，有一些快捷方式(如：Shift键最小化、ESC键退出、Ctrl＋S存盘、Alt＋x退出等等)。以前有一些介绍使用Win32 API可以做到，但过于繁琐，其实VB本身已经给我们提供了这个功能。　　我们来新建一个窗体Form1，对于键盘操作可以看到有三个事件KeyPress()，KeyDown和KeyUp，下面我对它们分别介绍：　　KeyPress()事件是当用户按下和松开一个 ANSI 键时发生(ANSI是可见ASCII字符1－127)。　　语法　　Private Sub object_KeyPress([index As Integer,]keyascii As Integer)　　KeyPress 事件语法包含下列部分：　　 部分 描述　　object 一个对象表达式，其值是&#8220;应用于&#8221;列表中的一个对象。　　index 一个整数，它用来唯一标识一个在控件数组中的控件（仅有控件数组时才有）。　　keyascii 是返回一个标准数字 ANSI 键代码的整数。Keyascii 通过引用传递，对它进行改变可给对象　　发送一个不同的字符。将 keyascii 改变为 0 时可取消击键，这样一来对象便接收不到字符。　　说明　　具有焦点的对象接收该事件。一个窗体仅在KeyPreview 属性被设置为 True 时才能接收该事件。一个 KeyPress 事件可以引用任何可打印的键盘字符，一个来自标准字母表的字符或少数几个特殊字符之一的字符与 CTRL 键的组合，以及 ENTER 或BACKSPACE键。KeyPress()事件过程在截取 TextBox 或 ComboBox 控件所输入的击键时是非常有用的。它可立即测试击键的有效性或在字符输入时对其进行格式处理。改变 keyascii 参数的值会改变所显示的字符。　　可使用下列表达式将 keyascii 参数转变为一个字符：　　Chr(KeyAscii)　　然后执行字符串操作，并将该字符反译成一个控件可通过该表达式解释的 ANSI 数字：　　KeyAscii = Asc(char)　　在KeyPress()处理不了的功能可以由KeyDown()和KeyUp()事件来处理：　　语法　　 Private Sub object_KeyDown([index As Integer,]keycode As Integer, shift As Integer)　　Private Sub object_KeyUp([index As Integer,]keycode As Integer, shift As Integer)　　KeyDown 和 KeyUp 事件包括下列部分：　　部分 描述　　object 一个对象表达式，其值是&#8220;应用于&#8221;列表中的一个对象。　　index 是一个整数，它用来唯一标识一个在控件数组中的控件（仅有控件数组时才有）。　　keycode 是一个键代码，诸如 vbKeyF1 （ F1 键）或 vbKeyHome （ HOME 键）。　　shift 是在该事件发生时响应 SHIFT ,CTRL 和 ALT 键的状态的一个整数。shift、CTRL、ALT 键在这些位分别对应于值 1、2 和 4。例如：如果 CTRL 和 ALT 这两个键都被按下，则 shift 的值为 6。　　说明　　对于这两个事件来说，带焦点的对象都接收所有击键。一个窗体只有在不具有可视的和有效的控件时才可以获得焦点。虽然KeyDown()和KeyUp()事件可应用于大多数键，它们最经常地还是应用于：扩展的字符键如功能键、定位键、键盘修饰键和按键的组合、区别数字小键盘和常规数字键；在需要对按下和松开一个键都响应时，可使用 KeyDown 和 KeyUp 事件过程。　　下列情况不能引用 KeyDown 和 KeyUp 事件：窗体有一个 CommandButton 控件，并且 Default 属性设置为 True 时的 ENTER 键。窗体有一个 CommandButton 控件，并且 Cancel 属性设置为 True 时的 ESC 键、TAB键，KeyDown 和 KeyUp 用两种参数解释每个字符的大写形式和小写形式：keycode —显示物理的键（将 A 和 a 作为同一个键返回）和shift—显示shift＋key键的状态而且返回A或a其中之一。　　如果需要测试 shift 参数，可使用该参数中定义各位的 shift 常数。该常数有下列值：　　常数 值 描述　　vbShiftMask 1 HIFT 键的位　　 屏蔽。　　VbCtrlMask 2 CTRL 键的　　 位屏蔽。　　VbAltMask 4 ALT 键的位　　 屏蔽。　　该常数用作位屏蔽，它可被用来测试任何键组合。　　注意：如果 KeyPreview 属性被设置为 True，则一个窗体先于该窗体上的控件接收到此事件。可用 KeyPreview 属性来创建全局键盘处理例程。　　了解了以上知识，我们可以制作出非常完美而且带有快捷键的程序，例如我们在一个程序中要用Ctrl＋S存盘，Shift最小化，Alt＋X和ESC退出：　　首先启动vb选择新建EXE文件，在Form1窗体上拉一个TextBox，并把Form1的KeyPreview属性设为True,双击Form1,选择Form的KeyPress事件，输入如下代码：　　Private Sub Form_KeyPress(KeyAscii as Integer) \'Esc键退出，VbEscape可以用27代替　　If KeyAscii=VbEscape then End　　End Sub　　在Form的KeyDown事件中输入如下代码：　　Private Sub Form_KeyDown(KeyCode as Integer,Shift as Integer) \'处理Ctrl＋X,Shift,Alt＋X　　If Shift=2 And KeyCode=VbKeyS Then Print ＃FileNum,Form1.Text1.Text \'Ctrl＋S存盘，VbKeyS=83　　If shift=2 then Form1.WindowState=1 \'Shift最小化　　If Shift=4 And KeyCode=VbKeyX Then End \'Alt＋X退出，VbkeyX=88　　End Sub　　在Form的Load事件中输入如下代码：　　Private Sub Form_load()　　Dim FileNum as integer　　FileNum=FreeFile　　Open App.Path＋&#8220;\\Sample.txt" For Append As ＃FileNum　　End Sub　　运行它就可以实现我们所要求的功能了，举这个例子只是抛砖引玉的作用，利用它我们还可以编写
--&&实现在FlexGrid控件的栅格中加入文本框、下拉框的功能在窗体上放一个TEXT,COMBO,还有LABEL控件，当然少不了MSFlexGrid控件，然后再放代码！Option ExplicitPrivate Sub Combo1_KeyPress(KeyAscii As Integer)Dim i As Integer, bSame As BooleanIf KeyAscii = vbKeyEscape Then&&&&Combo1.Visible = False&&&&MSFlexGrid1.SetFocus&&&&Exit SubEnd IfIf KeyAscii = vbKeyReturn Then&&&&MSFlexGrid1.Text = Combo1.Text&&&&Combo1.Visible = False&&&&MSFlexGrid1.SetFocus&&&&With Combo1&&&&&&&&bSame = False&&&&&&&&For i = 0 To .ListCount&&&&&&&&&&&&If .Text = .List(i) Then bSame = True&&&&&&&&Next i&&&&&&&&If Not bSame Then .AddItem .Text&&&&End WithEnd IfEnd SubPrivate Sub Combo1_LostFocus()Combo1.Visible = FalseMSFlexGrid1.SetFocusEnd SubPrivate Sub Form_Load()Dim i As IntegerWith MSFlexGrid1&&&&.Cols = 5&&&&.Rows = 5&&&&For i = 0 To 4&&&&&&&&.RowHeight(i) = 300&&&&Next iEnd WithFor i = 1 To 10&&&&Combo1.AddItem iNext iLabel1.Caption = "在第一、二行中，双击左键，会出现一文字框(TextBox)..." & vbCr & _&&&&&&&&&&&&&&&& "而第三、四行，会出现选择类表单(ComboBox)..." & vbCr & _&&&&&&&&&&&&&&&& "输入完毕后按下Enter键，资料即可保留于MSFlexGrid中，" & vbCr & _&&&&&&&&&&&&&&&& "而按下Esc键则取消输入..."End SubPrivate Sub MSFlexGrid1_DblClick()Dim c As Integer, r As IntegerWith MSFlexGrid1&&&&c = .Col: r = .Row&&&&If c &= 2 Then&&&&&&&&Text1.Left = .Left + .ColPos(c)&&&&&&&&Text1.Top = .Top + .RowPos(r)&&&&&&&&Text1.Width = .ColWidth(c)&&&&&&&&Text1.Height = .RowHeight(r)&&&&&&&&Text1 = .Text&&&&&&&&Text1.Visible = True&&&&&&&&Text1.SetFocus&&&&Else&&&&&&&&Combo1.Left = .Left + .ColPos(c)&&&&&&&&Combo1.Top = .Top + .RowPos(r)&&&&&&&&Combo1.Width = .ColWidth(c)&&&&&&&&Combo1.Text = .Text&&&&&&&&Combo1.Visible = True&&&&&&&&Combo1.SetFocus&&&&End IfEnd WithEnd SubPrivate Sub MSFlexGrid1_KeyPress(KeyAscii As Integer)If KeyAscii = vbKeyReturn Then&&&&Call MSFlexGrid1_DblClickEnd IfEnd SubPrivate Sub Text1_KeyPress(KeyAscii As Integer)If KeyAscii = vbKeyEscape Then&&&&Text1.Visible = False&&&&MSFlexGrid1.SetFocus&&&&Exit SubEnd IfIf KeyAscii = vbKeyReturn Then&&&&MSFlexGrid1.Text = Text1.Text&&&&Text1.Visible = False&&&&MSFlexGrid1.SetFocusEnd IfEnd SubPrivate Sub Text1_LostFocus()Text1.Visible = FalseMSFlexGrid1.SetFocusEnd Sub
--&&窗口事件的发生顺序
1 Form_Initialize 2 Form_Load3 Form_Resize4 Form_Activate5 Form_GotFocus6 Form_Paint7 Form_Unload8 Form_Terminate
--&&强制关闭计算机
　　用API函数ExitWindowsEx可以实现强制关机，即便是您的应用程序尚未保存文件。 Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As LongConst EWX_SHUTDOWN = 1Const EWX_LOGOFF = 0Const EWX_REBOOT = 2 Const EWX_FORCE = 4Private Sub Command1_Click()Dim aa = ExitWindowsEx(EWX_LOGOFF or EWX_FORCE or EWX_SHUTDOWN, 0)End Sub 如果将a = ExitWindowsEx(EWX_LOGOFF or EWX_FORCE or EWX_SHUTDOWN, 0)改换为a = ExitWindowsEx(EWX_LOGOFF or EWX_REBOOT, 0)即可实现强制重启计算机！
--&&VB自带打包程序实现"卸载程序"
在&#8220;启动菜单项&#8221;你可以设置在&#8220;开始菜单&#8221;中显示哪些项目，你可以加卸载程序项：
选择&#8220;新建项&#8221;按钮，然后在&#8220;目标&#8221;栏中输入$(WinPath)\\st6unst.exe -n "$(AppPath)\\ST6UNST.LOG"，包括双引号。在&#8220;开始&#8221;项目中选择&#8220;$(WinPath)&#8221;，不包括双引号。
--&&快速读取 TextBox 第 N 行的资料TextBox 是以 vbCr+vbLf 为分行符号， 如果我们要逐一读取 TextBox 每一行，无非是寻找 vbCr+vbLf 的所在位置， 然后取出每一行的字串， 不过这个方法真的不快，而且如果我们要读取第 N 行资料， 还是要从第 1、2、┅N-1 行逐一读起， 实在麻烦。还好 Windows API 提供有读取 TextBox 第 N 行的功能， 细节如下：
1. API 的声明：Const EM_GETLINE = &HC4Const EM_LINELENGTH = &HC1Const EM_LINEINDEX = &HBBPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)注：如果以上的声明放在「一般模块」底下， 应在 Const 之前加上 Public 保留字， 并且将 Private 保留字去掉。2. 程序范例：Sub TB_GetLine(ByVal hWnd As Long, ByVal whichLine As Long, Line As String)Dim length As Long, bArr() As Byte, bArr2() As Byte, lc As Longlc = SendMessage(hWnd, EM_LINEINDEX, whichLine, ByVal 0&)length = SendMessage(hWnd, EM_LINELENGTH, lc, ByVal 0&)If length & 0 ThenReDim bArr(length + 1) As Byte, bArr2(length - 1) As ByteCall RtlMoveMemory(bArr(0), length, 2)Call SendMessage(hWnd, EM_GETLINE, whichLine, bArr(0))Call RtlMoveMemory(bArr2(0), bArr(0), length)Line = StrConv(bArr2, vbUnicode)ElseLine = ""End IfEnd Sub\' 假设要读取 Text1 第 5 行的资料Dim S As StringCall TB_GetLine( Text1.hWnd, 5, S )\' 传回值 S 即等于到 5 行的资料注：TextBox 的行次是从 0 起算。
--&&VB中使用正则表达式正则表达式使用的例子，比如要将所有&#8220;&&&#8221;括起来的标记(比如&html&)替换成{}先引用Microsoft VBScript Regular Expressions&&&&Dim re As New RegExp&&&&re.IgnoreCase = True&&&&re.Global = True&&&&re.Pattern = "&[^&]+&"&&&&text1.Text = re.Replace(text1.Text, "{}")
--&&[原创]用VB在NT上发传真
先将NT的传真服务设置好,在VB中引用faxcom就可以实现传真发送了.
xTiNtPrivate Sub FaxSend()&&&&Dim objFaxSev As New FAXCOMLib.FaxServer&&&&Dim objFaxDoc As FAXCOMLib.FaxDoc&&&&Dim b As Long&&&&Dim strFile As String&&&&&&&&strFile = "E:\\fax\\fax.txt" \'文件名&&&&objFaxSev.Connect ("GZTX") \'本机机器名&&&&Set objFaxDoc = objFaxSev.CreateDocument(strFile)&&&& &&&&objFaxDoc.FaxNumber = <FONT color=#378496"&&\'发送到的号码&&&&objFaxDoc.CoverpageSubject = "AAA"&&&&objFaxDoc.CoverpageName = "BBB"&&&&&&&&b = objFaxDoc.Send()
--&&完全模拟【开始】中的【关机】功能在【问题：如何从您的应程序中结束 Windows 重开机？】我们曾经提到过，如何由程序中强迫关机、重开机，但是在这个主题中，我们要告诉您的，是如何模拟按下了【开始】中的【关机】选项，屏幕变成灰灰一片，并且在屏幕中央出现【关闭 Windows】问话框！在声明区中加入以下声明：Declare Function SHShutDownDialog Lib "shell32" Alias "#60" (ByVal lType As Long) As LongPublic Const EWX_LOGOFF = 0Public Const EWX_SHUTDOWN = 1Public Const EWX_REBOOT = 2Public Const EWX_FORCE = 4Public Const EWX_POWEROFF = 8要 Show 出【关闭 Windows】问话框时用法如下：SHShutDownDialog EWX_SHUTDOWN
--&&如何将桌面上所有的视窗最小化有很多好用的桌面工具软件都有提供这个功能，将桌面上所有的视窗最小化，也会提供将它们复原的功能，当然，要提供这种功能的软件，执行后都是将程序缩到桌面右下角的工具列中，使用 Menu 来操控，否则，将桌面上所有的视窗最小化，也包括它自己的程序本身的视窗的！\'请在视窗声明区中加入以下声明及模组：Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPrivate Const WM_COMMAND As Long = &H111Private Const MIN_ALL As Long = 419Private Const MIN_ALL_UNDO As Long = 416Public Sub MinimizeAll()Dim lngHwnd As LonglngHwnd = FindWindow("Shell_TrayWnd", vbNullString)Call PostMessage(lngHwnd, WM_COMMAND, MIN_ALL, 0&)End SubPublic Sub RestoreAll()Dim lngHwnd As LonglngHwnd = FindWindow("Shell_TrayWnd", vbNullString)Call PostMessage(lngHwnd, WM_COMMAND, MIN_ALL_UNDO, 0&)End Sub\'而实际使用之范例如下：Private Sub Command1_Click()MinimizeAll \'将桌面上所有的视窗最小化End SubPrivate Sub Command2_Click()RestoreAll \'将最小化的视窗还原End Sub
--&&完全模拟【开始】中的【运行...】功能
请输入程序、资料夹、文件或 Internet 资源的名称，Windows 会自动开启。
如果说您我也可以做到这种功能，只要是可开启的、可执行的，通通可以做到，您相信吗？不要怀疑！不但可以做到，而且更让您惊讶的，是程序竟然这么短，只要一行就可以了！
您一定认为要用 API，喔！不是！先别乱猜，这次不用声明 API！直接来看一个例子：
在 Form 中放一个 TextBox，名称为 Text1
Private Sub Command1_Click()Call Shell("rundll32.exe url.dll,FileProtocolHandler " & Text1, 1)End Sub
而其中的 Text1 可以输入程序、资料夹、文件或 Internet 资源的名称，也可以输入快捷方式 (shortcut file)，都可以正确执行！
--&&实现映射/ 断开网络驱动器
\'请在声明区中加入以下声明及模组：
Declare Function WNetAddConnection Lib "mpr.dll" Alias "WNetAddConnectionA" (ByVal lpszNetPath As String, ByVal lpszPassword As String, ByVal lpszLocalName As String) As Long
Declare Function WNetCancelConnection Lib "mpr.dll" Alias "WNetCancelConnectionA" _(ByVal lpszName As String, ByVal bForce As Long) As Long
Function AddConnection(MyShareName As String, MyPWD As String, UseLetter As String) As IntegerOn Local Error GoTo AddConnection1_ErrAddConnection = WNetAddConnection(MyShareName, MyPWD, UseLetter)AddConnection_End:Exit Function
AddConnection1_Err:AddConnection = ErrMsgBox Error$Resume AddConnection_EndEnd Function
Function CancelConnection(DriveLetter As String, Force As Integer) As IntegerOn Local Error GoTo CancelConnection_ErrCancelConnection = WNetCancelConnection(DriveLetter, Force)CancelConnection_End:Exit Function
CancelConnection_Err:CancelConnection = ErrMsgBox Error$Resume CancelConnection_EndEnd Function
呼叫的方法如下：
连线网路磁盘：传回值 = AddConnection(&共享的路径&, &密码&, &磁盘代号&)
中断网路磁盘：传回值 = CancelConnection(&磁盘代号&, &强迫中断？&)
呼叫实例：
连线网路磁盘：X = AddConnection("\\\\IO\\io_c", "", "H:")
中断网路磁盘：X = CancelConnection("H:", True)
注：这个范例实际执行，连线时，NT 及 Novell 之速度相若，但是，在中断时，Novell 之速度明显较慢！
注：以上的方式乃是由程序中直接指定，另外的一个方法是显示问话框由使用者自行设定，这个方法我们在以后将再说明！
--&&实现 Windows 的资源回收站
您现在将屏幕上所有的视窗全部缩小，找到资源回收站，按鼠标右键，选择【属性】，便会出现【资源回收站】的属性问话框。
其中有几个选项如下：
1、不要将文件移到资源回收站，删除时立即移除文件。2、显示删除确认对话框？
根据以上之状况，文件之删除有三种情形：
1、删除文件，出现确认对话框，文件移到资源回收站。2、删除文件，出现确认对话框，文件不移到资源回收站。3、删除文件，不出现确认对话框，文件也不移到资源回收站。
模拟程序如下：
\'在模组的声明区中加入以下声明：
Public Type SHFILEOPSTRUCThwnd As LongwFunc As LongpFrom As StringpTo As StringfFlags As IntegerfAnyOperationsAborted As LonghNameMappings As LonglpszProgressTitle As LongEnd Type
Public Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Public Const FO_DELETE = &H3Public Const FOF_ALLOWUNDO = &H40 \'可以还原Public Const FOF_NOCONFIRMATION = &H10 \'不出现确认对话框Public Const FOF_SILENT = &H4
\'在程序中之使用方法如下：\'以下之例子会出现确认对话框，文件也会移到资源回收站。
Private Sub Command1_Click()Dim SHop As SHFILEOPSTRUCTDim strFile As String \'要删除的文件(含全路径)strFile = "c:\\test.txt"With SHop.wFunc = FO_DELETE.pFrom = strFile.fFlags = FOF_ALLOWUNDOEnd WithSHFileOperation SHopEnd Sub
\'若要调整，只要更改 fFlags 之值即可，如下：.fFlags = FOF_SILENT \'删除文件，出现确认对话框，文件不移到资源回收站。.fFlags = FOF_NOCONFIRMATION \'删除文件，不出现确认对话框，文件也不移到资源回收站。
--&&建立多级目录的函数Public Function MkDirs(ByVal PathIn As String) As BooleanDim nPos As LongMkDirs = True \'先假设成功If Right$(PathIn, 1) && "\\" Then PathIn = PathIn + "\\"nPos = InStr(1, PathIn, "\\")Do While nPos & 0If Dir$(Left$(PathIn, nPos), vbDirectory) = "" ThenOn Error GoTo FailedMkDir Left$(PathIn, nPos)On Error GoTo 0End IfnPos = InStr(nPos + 1, PathIn, "\\")LoopExit FunctionFailed:MkDirs = FalseEnd Function
--&&调整 Combo 下拉部分的宽度声明：Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPrivate Const CB_GETDROPPEDWIDTH = &H15FPrivate Const CB_SETDROPPEDWIDTH = &H160Private Const CB_ERR = -1函数：\' 取得 Combo 下拉的宽度\' 可以利用该函数比例放大或缩小宽度Public Function GetDropdownWidth(cboHwnd As Long) As LongDim lRetVal As LonglRetVal = SendMessage(cboHwnd, CB_GETDROPPEDWIDTH, 0, 0)If lRetVal && CB_ERR ThenGetDropdownWidth = lRetVal\'单位为 pixelsElseGetDropdownWidth = 0End IfEnd Function\'设置 Combo 下拉的宽度\'单位为 pixelsPublic Function SetDropdownWidth(cboHwnd As Long, NewWidthPixel As Long) As BooleanDim lRetVal As LonglRetVal = SendMessage(cboHwnd, CB_SETDROPPEDWIDTH, NewWidthPixel, 0)If lRetVal && CB_ERR ThenSetDropdownWidth = TrueElseSetDropdownWidth = FalseEnd IfEnd Function