Dim FontCount as integer For FontCount = 0 To Screen.FontCount - 1 List1.AddItem Screen.Fonts(FontCount) Next |
-- 防止将重复项目添加到列表框中 防止将重复项目添加到列表框中:(当然用循环也可以实现) Option Explicit Private Declare Function SendMessageFind Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As String) As Long Const WM_USER = &H400 Const LB_ERR = (-1) Const LB_FINDSTRING = &H18F Private Sub Form_Load() List1.AddItem "Item1" List1.AddItem "Item2" List1.AddItem "Item3" End Sub Private Sub Command1_Click() CheckForDupes End Sub Sub 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 If End 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 With End Sub Private Sub Text1_GotFocus() SelectAllTxt \'调用过程 End Sub |
| ！ |
-- 截屏代码(可截屏整个Screen/当前活动界面) Option Explicit Private 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 \'整个Screen Const 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 If End 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 2001-04-05 Public Function Len_CnE(ByVal vStr As String) As Long Len_CnE = LenB(StrConv(vStr, vbFromUnicode)) End Function Public Function Left_CnE(ByVal vStr As String, ByVal vInt As Long) As String \'取字符（中英）llp 2001-08-10 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 Function Public Function Right_CnE(ByVal vStr As String, ByVal vInt As Long) As String \'取字符（中英）对应 Right \'llp 2003-06-18 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 Function Public Function Mid_CnE(ByVal tStr As String, Start As Integer, Optional Leng As Variant) As String \'取字符（中英）对应 Mid \'llp 2003-06-18 Dim TmpStr As String Dim TmpStr1 As String If 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 If End If If IsMissing(Leng) Then TmpStr = StrConv(MidB(StrConv(tStr, vbFromUnicode), Start), vbUnicode) Else TmpStr = StrConv(MidB(StrConv(tStr, vbFromUnicode), Start, Leng), vbUnicode) End If Mid_CnE = TmpStr End 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 Sub Private 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.Icon End 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.quit 2. 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("123中国456", vbFromUnicode)) \'10 \'根据系统的缺省码页将字符串转成 Unicode Debug.Print StrConv(StrConv("123中国", 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 Explicit Private 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 0 End 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 0 End Sub Private Sub Form_Resize() \'确保窗体改变时控件随之改变 Call ResizeForm(Me) End Sub Private 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, I ReturnValue = 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 Explicit Private Declare Function ShellExecuteEx Lib "shell32.dll" Alias "ShellExecuteExA" (lpExecInfo As SHELLEXECUTEINFO) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare Function GetDesktopWindow Lib "user32" () As Long Private 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 Long End Type Public 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, 99999999 CloseHandle ShellInfo.hProcess RunProc = True End If End 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 Long Private 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=false Private Sub Timer1_Timer() a& = FlashWindow(Me.hwnd, 1) End Sub Private Sub Command1_Click() Timer1.Enabled = True End Sub Private Sub Command2_Click() Timer1.Enabled = False End Sub |
-- 得到鼠标位置 声明： Private Type POINTAPI x As Long y As Long End Type Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 例子： Dim p As POINTAPI Call 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 –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 = xlContinuous 3 要写入很多数据的话 不要用循环写到Excel 先把数据写到数组里 用数组可以一次性写入(数组大小要和区域一样大) Eg: range("a1:c100") = Arr Arr是一个(1 to 100, 1 to 3 ) 的数组 反之 : Arr = range("a1:c100").value ---------------------------------------------------------------------------------------- 例子: \'export grid to excel Private 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 Long Dim data() As String Dim cnt As Integer \' visible column\'s count Dim curCol As Long Dim i As Integer Dim 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之间 \' 所有包含在此区间的国标汉字的声母为a Public Type TypePos Min As Long \'一个声母字符左区间 Max As Long \'一个声母字符右区间 cFirst As String \'保存声母字符 End Type Public 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的区间内因此,此汉字的声母为a i = 0 \'字母a tyChinaPos(i).cFirst = Chr(97) tyChinaPos(i).Min = -20319 tyChinaPos(i).Max = -20284 i = i + 1 \'字母b tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -20283 tyChinaPos(i).Max = -19776 i = i + 1 \'c tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -19775 tyChinaPos(i).Max = -19219 i = i + 1 \'d tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -19218 tyChinaPos(i).Max = -18711 i = i + 1 \'e tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -18710 tyChinaPos(i).Max = -18527 i = i + 1 \'f tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -18526 tyChinaPos(i).Max = -18240 i = i + 1 \'g tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -18239 tyChinaPos(i).Max = -17923 i = i + 1 \'h tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -17922 tyChinaPos(i).Max = -17418 i = i + 2 \'j tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -17417 tyChinaPos(i).Max = -16475 i = i + 1 \'k tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -16474 tyChinaPos(i).Max = -16213 i = i + 1 \'l tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -16212 tyChinaPos(i).Max = -15641 i = i + 1 \'m tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -15640 tyChinaPos(i).Max = -15166 i = i + 1 \'n tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -15165 tyChinaPos(i).Max = -14923 i = i + 1 \'o tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -14922 tyChinaPos(i).Max = -14915 i = i + 1 \'p tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -14914 tyChinaPos(i).Max = -14631 i = i + 1 \'q tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -14630 tyChinaPos(i).Max = -14150 i = i + 1 \'r tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -14149 tyChinaPos(i).Max = -14091 i = i + 1 \'s tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -14090 tyChinaPos(i).Max = -13319 i = i + 1 \'t tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -13318 tyChinaPos(i).Max = -12839 i = i + 3 \'w tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -12838 tyChinaPos(i).Max = -12557 i = i + 1 \'x tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -12556 tyChinaPos(i).Max = -11848 i = i + 1 \'y tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -11847 tyChinaPos(i).Max = -11056 i = i + 1 \'z tyChinaPos(i).cFirst = Chr(i + 97) tyChinaPos(i).Min = -11055 tyChinaPos(i).Max = -10247 End Sub \' 给定一个字符串返回这个字符串的拼音助记字符串 Public Function GetStringZhuJi(strS As String) As String Dim i As Integer Dim strRet As String strRet = "" \'设置返回的字符串为空 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 If Next i GetStringZhuJi = 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 = bRet End Function \' 得到一个汉字的第一个字母,并且返回 Public Function GetChinaChar(strSt As String) As String Dim i As Integer Dim iPos As Long Dim strRetF As String strRetF = "" \' 如果是一级汉字,遍历其值所在的区间 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 If GetChinaChar = strRetF \'将声母返回 End Function \' 给定一个字符串返回这个字符串的拼音助记字符串 Public Function GetStringZhuJi(strS As String) As String Dim i As Integer Dim strRet As String strRet = "" \'设置返回的字符串为空 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 If Next i GetStringZhuJi = 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 = bRet End Function \' 得到一个汉字的第一个字母,并且返回 Public Function GetChinaChar(strSt As String) As String Dim i As Integer Dim iPos As Long Dim strRetF As String strRetF = "" \' 如果是一级汉字,遍历其值所在的区间 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 If GetChinaChar = strRetF \'将声母返回 End Function |
-- 利用注册表获得"我的文档"的目录 大家都知道注册表的强大功能吧！其实很多默认的路径都在“hkey_current_user\\software\\microsoft\\windows\\currentversion\\explorer\\shell folders”之中，大家可以看看。下面就是利用注册表获得我的文档的源代码。 option explicit \' 这个模块用于读和写注册表关键字。 \' 不同于vb 的内部注册表访问方法，它可以 \' 通过字符串的值来读和写任何注册表关键字。 \'--------------------------------------------------------------- \'-注册表 api 声明... \'--------------------------------------------------------------- private declare function regclosekey lib "advapi32" (byval hkey as long) as long private 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 long private 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 long private 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 long private 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 = &h20000 const key_query_value = &h1 const key_set_value = &h2 const key_create_sub_key = &h4 const key_enumerate_sub_keys = &h8 const key_notify = &h10 const key_create_link = &h20 const key_read = key_query_value + key_enumerate_sub_keys + key_notify + read_control const key_write = key_set_value + key_create_sub_key + read_control const key_execute = key_read const 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 = &h80000000 const hkey_current_user = &h80000001 const hkey_local_machine = &h80000002 const hkey_users = &h80000003 const hkey_performance_data = &h80000004 \' 返回值... const error_none = 0 const error_badkey = 2 const error_access_denied = 8 const error_success = 0 \'--------------------------------------------------------------- \'- 注册表安全属性类型... \'--------------------------------------------------------------- private type security_attributes nlength as long lpsecuritydescriptor as long binherithandle as boolean end 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 function public 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\' public functio n getwindir() as string public functio n getsysdir() as string |
-- 使用VB获得一页的HTML代码 加入WebBrowser、Timer、CommandButton控件各一个，然后使用以下代码： Private Sub Command1_Click() WebBrowser1.Navigate "code.chinacun.com/bbs" Timer1.Enabled = True End Sub Private Sub Timer1_Timer() Dim doc, objhtml As Object Dim i As Integer Dim strhtml As String If Not WebBrowser1.Busy Then Set doc = WebBrowser1.Document i = 0 Set objhtml = doc.body.createtextrange() If Not IsNull(objhtml) Then Text1.Text = objhtml.htmltext End If Timer1.Enabled = False End If End Sub |
-- 将数字金额转成大写金额 以下算法未处理零的习惯叫法 Function ChangeMoney(ByVal vMoney As Double) As String \'将数字金额转成大写金额 (小于亿亿) \'llp 2001-05-04 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 2001-05-04 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 ‘函数声明 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:3 Private 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 就是明显的例子。 |
|
|
|
|
-- 用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 一个对象表达式，其值是“应用于”列表中的一个对象。 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 一个对象表达式，其值是“应用于”列表中的一个对象。 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＋“\\Sample.txt" For Append As ＃FileNum End Sub 运行它就可以实现我们所要求的功能了，举这个例子只是抛砖引玉的作用，利用它我们还可以编写 |
-- 实现在FlexGrid控件的栅格中加入文本框、下拉框的功能 在窗体上放一个TEXT,COMBO,还有LABEL控件，当然少不了MSFlexGrid控件，然后再放代码！ Option Explicit Private Sub Combo1_KeyPress(KeyAscii As Integer) Dim i As Integer, bSame As Boolean If KeyAscii = vbKeyEscape Then Combo1.Visible = False MSFlexGrid1.SetFocus Exit Sub End If If 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 With End If End Sub Private Sub Combo1_LostFocus() Combo1.Visible = False MSFlexGrid1.SetFocus End Sub Private Sub Form_Load() Dim i As Integer With MSFlexGrid1 .Cols = 5 .Rows = 5 For i = 0 To 4 .RowHeight(i) = 300 Next i End With For i = 1 To 10 Combo1.AddItem i Next i Label1.Caption = "在第一、二行中，双击左键，会出现一文字框(TextBox)..." & vbCr & _ "而第三、四行，会出现选择类表单(ComboBox)..." & vbCr & _ "输入完毕后按下Enter键，资料即可保留于MSFlexGrid中，" & vbCr & _ "而按下Esc键则取消输入..." End Sub Private Sub MSFlexGrid1_DblClick() Dim c As Integer, r As Integer With 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 If End With End Sub Private Sub MSFlexGrid1_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyReturn Then Call MSFlexGrid1_DblClick End If End Sub Private Sub Text1_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyEscape Then Text1.Visible = False MSFlexGrid1.SetFocus Exit Sub End If If KeyAscii = vbKeyReturn Then MSFlexGrid1.Text = Text1.Text Text1.Visible = False MSFlexGrid1.SetFocus End If End Sub Private Sub Text1_LostFocus() Text1.Visible = False MSFlexGrid1.SetFocus End Sub |
-- 窗口事件的发生顺序 1 Form_Initialize 2 Form_Load 3 Form_Resize 4 Form_Activate 5 Form_GotFocus 6 Form_Paint 7 Form_Unload 8 Form_Terminate |
-- 强制关闭计算机 用API函数ExitWindowsEx可以实现强制关机，即便是您的应用程序尚未保存文件。 |
-- VB自带打包程序实现"卸载程序" 在“启动菜单项”你可以设置在“开始菜单”中显示哪些项目，你可以加卸载程序项： 选择“新建项”按钮，然后在“目标”栏中输入$(WinPath)\\st6unst.exe -n "$(AppPath)\\ST6UNST.LOG"，包括双引号。在“开始”项目中选择“$(WinPath)”，不包括双引号。 |
-- 快速读取 TextBox 第 N 行的资料 TextBox 是以 vbCr+vbLf 为分行符号， 如果我们要逐一读取 TextBox 每一行， 无非是寻找 vbCr+vbLf 的所在位置， 然后取出每一行的字串， 不过这个方法真 的不快，而且如果我们要读取第 N 行资料， 还是要从第 1、2、┅N-1 行逐一读 起， 实在麻烦。 还好 Windows API 提供有读取 TextBox 第 N 行的功能， 细节如下： 1. API 的声明： Const EM_GETLINE = &HC4 Const EM_LINELENGTH = &HC1 Const EM_LINEINDEX = &HBB 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 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 Long lc = SendMessage(hWnd, EM_LINEINDEX, whichLine, ByVal 0&) length = SendMessage(hWnd, EM_LINELENGTH, lc, ByVal 0&) If length > 0 Then ReDim bArr(length + 1) As Byte, bArr2(length - 1) As Byte Call RtlMoveMemory(bArr(0), length, 2) Call SendMessage(hWnd, EM_GETLINE, whichLine, bArr(0)) Call RtlMoveMemory(bArr2(0), bArr(0), length) Line = StrConv(bArr2, vbUnicode) Else Line = "" End If End Sub \' 假设要读取 Text1 第 5 行的资料 Dim S As String Call TB_GetLine( Text1.hWnd, 5, S ) \' 传回值 S 即等于到 5 行的资料 注：TextBox 的行次是从 0 起算。 |
-- VB中使用正则表达式 正则表达式使用的例子，比如要将所有“<>”括起来的标记(比如<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() End Sub |
|
|
-- 完全模拟【开始】中的【关机】功能 在【问题：如何从您的应程序中结束 Windows 重开机？】我们曾经提到过，如何由程序中强迫关机、重开机，但是在这个主题中，我们要告诉您的，是如何模拟按下了【开始】中的【关机】选项，屏幕变成灰灰一片，并且在屏幕中央出现【关闭 Windows】问话框！ 在声明区中加入以下声明： Declare Function SHShutDownDialog Lib "shell32" Alias "#60" (ByVal lType As Long) As Long Public Const EWX_LOGOFF = 0 Public Const EWX_SHUTDOWN = 1 Public Const EWX_REBOOT = 2 Public Const EWX_FORCE = 4 Public 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 Long Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const WM_COMMAND As Long = &H111 Private Const MIN_ALL As Long = 419 Private Const MIN_ALL_UNDO As Long = 416 Public Sub MinimizeAll() Dim lngHwnd As Long lngHwnd = FindWindow("Shell_TrayWnd", vbNullString) Call PostMessage(lngHwnd, WM_COMMAND, MIN_ALL, 0&) End Sub Public Sub RestoreAll() Dim lngHwnd As Long lngHwnd = FindWindow("Shell_TrayWnd", vbNullString) Call PostMessage(lngHwnd, WM_COMMAND, MIN_ALL_UNDO, 0&) End Sub \'而实际使用之范例如下： Private Sub Command1_Click() MinimizeAll \'将桌面上所有的视窗最小化 End Sub Private Sub Command2_Click() RestoreAll \'将最小化的视窗还原 End Sub |
-- 完全模拟【开始】中的【运行...】功能 请输入程序、资料夹、文件或 Internet 资源的名称，Windows 会自动开启。 如果说您我也可以做到这种功能，只要是可开启的、可执行的，通通可以做到，您相信吗？不要怀疑！不但可以做到，而且更让您惊讶的，是程序竟然这么短，只要一行就可以了！ 您一定认为要用 API，喔！不是！先别乱猜，这次不用声明 API！直接来看一个例子： 在 Form 中放一个 TextBox，名称为 Text1 Private Sub Command1_Click() 而其中的 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" _ Function AddConnection(MyShareName As String, MyPWD As String, UseLetter As String) As Integer AddConnection1_Err:
CancelConnection_Err: 呼叫的方法如下： 连线网路磁盘：传回值 = AddConnection(<共享的路径>, <密码>, <磁盘代号>) 中断网路磁盘：传回值 = CancelConnection(<磁盘代号>, <强迫中断？>) 呼叫实例： 连线网路磁盘：X = AddConnection("\\\\IO\\io_c", "", "H:") 中断网路磁盘：X = CancelConnection("H:", True) 注：这个范例实际执行，连线时，NT 及 Novell 之速度相若，但是，在中断时，Novell 之速度明显较慢！ 注：以上的方式乃是由程序中直接指定，另外的一个方法是显示问话框由使用者自行设定，这个方法我们在以后将再说明！ |
-- 实现 Windows 的资源回收站 您现在将屏幕上所有的视窗全部缩小，找到资源回收站，按鼠标右键，选择【属性】，便会出现【资源回收站】的属性问话框。 其中有几个选项如下： 1、不要将文件移到资源回收站，删除时立即移除文件。 根据以上之状况，文件之删除有三种情形： 1、删除文件，出现确认对话框，文件移到资源回收站。 模拟程序如下： \'在模组的声明区中加入以下声明： Public Type SHFILEOPSTRUCT Public Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long Public Const FO_DELETE = &H3 \'在程序中之使用方法如下： Private Sub Command1_Click() \'若要调整，只要更改 fFlags 之值即可，如下： |
-- 建立多级目录的函数 Public Function MkDirs(ByVal PathIn As String) As Boolean Dim nPos As Long MkDirs = True \'先假设成功 If Right$(PathIn, 1) <> "\\" Then PathIn = PathIn + "\\" nPos = InStr(1, PathIn, "\\") Do While nPos > 0 If Dir$(Left$(PathIn, nPos), vbDirectory) = "" Then On Error GoTo Failed MkDir Left$(PathIn, nPos) On Error GoTo 0 End If nPos = InStr(nPos + 1, PathIn, "\\") Loop Exit Function Failed: MkDirs = False End 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 Long Private Const CB_GETDROPPEDWIDTH = &H15F Private Const CB_SETDROPPEDWIDTH = &H160 Private Const CB_ERR = -1 函数： \' 取得 Combo 下拉的宽度 \' 可以利用该函数比例放大或缩小宽度 Public Function GetDropdownWidth(cboHwnd As Long) As Long Dim lRetVal As Long lRetVal = SendMessage(cboHwnd, CB_GETDROPPEDWIDTH, 0, 0) If lRetVal <> CB_ERR Then GetDropdownWidth = lRetVal \'单位为 pixels Else GetDropdownWidth = 0 End If End Function \'设置 Combo 下拉的宽度 \'单位为 pixels Public Function SetDropdownWidth(cboHwnd As Long, NewWidthPixel As Long) As Boolean Dim lRetVal As Long lRetVal = SendMessage(cboHwnd, CB_SETDROPPEDWIDTH, NewWidthPixel, 0) If lRetVal <> CB_ERR Then SetDropdownWidth = True Else SetDropdownWidth = False End If End Function |
浙公网安备 33010602011771号