VB中怎样可以清除用Print所编写的文字？_百度知道
VB中怎样可以清除用Print所编写的文字？
用&&虽然可以清除，但会留出一行的，谁有什么办法？
我有更好的答案
输入cls就可以了 。Private Sub Command2_Click()ClsEnd Sub
采纳率：26%
List1.Clearload事件要print必需将AutoRedraw设置为True，或者在调用Print之前先执行Form1.show
直接输入cls
其他2条回答
为您推荐：
其他类似问题
print的相关知识
换一换
回答问题，赢新手礼包
个人、企业类
违法有害信息,请在下方选择后提交
色情、暴力
我们会通过消息、邮箱等方式尽快将举报结果通知您。您还可以使用以下方式登录
当前位置：&>&&>& > VB实用代码，收藏！！
VB实用代码，收藏！！
&不错VB代码，收藏！！！ 收藏 实现毫秒精度的延时'Module Code:Option ExplicitDeclare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As LongDeclare Function QueryPerformanceCounter Lib "kernel32" _&&&&&&& (lpPerformanceCount As LARGE_INTEGER) As LongType LARGE_INTEGER&&& LowPart As Long&&& HighPart As LongEnd Type'实现毫秒量级精确延时,(n 毫秒)Public Sub Wait(ByVal n As Long)&&& Dim PFrequency As LARGE_INTEGER&&& Dim Interval As LARGE_INTEGER&&& Dim Privious As LARGE_INTEGER&&& Dim Current As LARGE_INTEGER&&& &&& '获得高精度计数器的频率&&& QueryPerformanceFrequency PFrequency&&& &&& '获得高精度运行计数器的值&&& QueryPerformanceCounter Privious&&& Current = Privious&&& Interval.LowPart = (PFrequency.LowPart / 1000) * n&&& '下面这句可以精确到微秒,好像不太实用,也未必精确到如此地步&&& 'Interval.LowPart = (PFrequency.LowPart / 1000000) * n&&& Interval.HighPart = 0&&& &&& '通过比较两次计数器的值差实现高精度延时&&& Do While (Abs(Current.HighPart * 2 ^ 16) + Current.LowPart) - _&&&&&&&&&&&& (Abs(Privious.HighPart * 2 ^ 16) + Privious.LowPart) & _&&&&&&&&&&&& (Abs(Interval.HighPart * 2 ^ 16) + Interval.LowPart)&&&&&&& QueryPerformanceCounter Current&&&&&&& &&&&&&& '此句若省略,循环期间其它事就都不能做了&&&&&&& DoEvents&&& LoopEnd Sub'Form Code:Option ExplicitDim l As LongPrivate Sub Command1_Click()&&& l = 0&&& '对照时钟计时(它并不很精确,这里仅对照而已)&&& '间隔10毫秒已经很小了&&& Timer1.Interval = 10&&& &&& '延时&&& Wait 5000&&& &&& '停止计时&&& Timer1.Interval = 0&&& MsgBox "你够狠,憋了我5000毫秒才放出来"End SubPrivate Sub Form_Load()&&& '共三个控件:一个时钟,一个标签,一个按钮&&& Command1.Caption = "等待5000毫秒"&&& Label1.AutoSize = True&&& Label1.Caption = "这里是时钟计时"End SubPrivate Sub Timer1_Timer()&&& l = l + 10&&& Label1.Caption = lEnd Sub&-------------------------------------------------------VB未公开的三个函数ObjPtr,StrPtr,VarPtr'Form Code:'ObjPtr: 返回对象实例私有域的地址'StrPtr: 返回字符串第一个字的地址'VarPtr: 返回变量的地址'使用对象浏览器（Object Browser），你可以发现更多其他对象未公开的细节。'使用诸如金山游侠之类的游戏修改器可以跟踪到这个变量的地址(查数值)'需生成EXE,这样容易操作,不会受到VB6干扰Dim l As LongPrivate Sub Command1_Click()&&& Print "对象实例私有域:", ObjPtr(Command1)&&& &&& Dim str As String&&& str = "字符串第一个字的地址:"&&& Print str, StrPtr(str)&&& &&& Print "----------------------------------"&&& Dim ramid As Double&&& ramid = VarPtr(l)&&& l = &&& Print "变量的内存地址:", VarPtr(l)&&& Print "转换成十六进制:", Hex(ramid)&&& Print "变量 l 的值:", lEnd SubPrivate Sub Form_Load()&&& '为了能持久显示,便于查看&&& Me.AutoRedraw = TrueEnd Sub'VarPtr用在包含字符串的变量时,可能返回的指针是临时地址(UNICODE转换的缘故)'StrPtr还是唯一能直观地告诉你空字符串和null字符串的不同的方法。'对于null字符串(vbNullString)，StrPtr的返回值为0，而对于空字符串，函数的返回值为非零'详细信息请查阅相关文档------------------------------------------------------------'返回阿拉伯数字的中文大写或者普通写法的一个函数Public Function ChnNumber(Number As Double, _&&&&&&&&&&&&&&&&&&&&&&&&& Optional Capital As Boolean = False, _&&&&&&&&&&&&&&&&&&&&&&&&& Optional Simple As Boolean = False) As String&&& '返回阿拉伯数字的中文大写或者普通写法&&& '调用方法例如:Debug.Print ChnNumber(12300.43)&&&&&& '返回:壹萬贰仟叁佰点肆叁&&& '&&&&&&&&&&&& Debug.Print ChnNumber()&&& '返回:一万二千三百点四三&&& '&&&&&&&&&&&& Debug.Print ChnNumber(12300.43, , 1)& '返回:一二三○○点四三&&& '作者:csdngoodnight&&& 'E-mail:&&& &&& 'Number:阿拉伯数字(12300.43)&&& 'Capital:True为中文大写(壹萬贰仟叁佰点肆叁),默认为False普通(一万二千三百点四三)&&& 'Simple:True为简单排列(壹贰叁零零点肆叁/一二三○○点四三)&&& &&& If Abs(Number) & CDbl(9.99E+15) Then&&&&&&& '万9990 or 9990 or 9.99E+15&&&&&&& MsgBox "超出这个范围的数字,将会有四舍五入进位情况。" & Space(5) & vbCrLf & _&&&&&&&&&&&&&& "难道你...要计算星星的数量?偶帮不了你啦 :(", vbInformation, "老兄:天文数字啊"&&&&&&& 'Exit Function&&& End If&&& &&& Dim varNumber As Variant&&& Dim ChnString(1) As String, strClass(1) As String&&& Dim iNumberLen As Integer, iCapital As Integer&&& Dim boolZero As Boolean&&& Dim strTemp As String&&& Dim i As Integer, j As Integer&&& strClass(0) = "十百千万亿兆"&&& strClass(1) = "拾佰仟萬億兆"&&& ChnString(0) = "○一二三四五六七八九"&&& ChnString(1) = "零壹贰叁肆伍陆柒捌玖"&&& &&& varNumber = Split(Format(Number, "0.################"), ".")&&& iNumberLen = Len(varNumber(0))&&& If Number & 0 Then&&&&&&& varNumber(0) = Right$((varNumber(0)), iNumberLen - 1)&&&&&&& iNumberLen = iNumberLen - 1&&& End If&&& iCapital = Abs(CInt(Capital))&&& &&& If Simple Then&&&&&&& For i = 1 To iNumberLen&&&&&&&&&&& j = CInt(Mid$(varNumber(0), i, 1))&&&&&&&&&&& ChnNumber = ChnNumber & Mid$(ChnString(iCapital), j + 1, 1)&&&&&&& Next&&&&&&& If UBound(varNumber) & 0 Then&&&&&&&&&&& iNumberLen = Len(varNumber(1))&&&&&&&&&&& For i = 1 To iNumberLen&&&&&&&&&&&&&&& j = CInt(Mid$(varNumber(1), i, 1))&&&&&&&&&&&&&&& strTemp = strTemp & Mid$(ChnString(iCapital), j + 1, 1)&&&&&&&&&&& Next&&&&&&& End If&&&&&&& If Len(strTemp) & 0 Then ChnNumber = ChnNumber & "点" & strTemp&&&&&&& If Number & 0 Then ChnNumber = "[负]" & ChnNumber&&&&&&& Exit Function&&& End If&&& &&& If iNumberLen & 2 Then&&&&&&& If iNumberLen = 0 Then varNumber(0) = "0"&&&&&&& ChnNumber = Mid$(ChnString(iCapital), CInt(varNumber(0)) + 1, 1)&&& Else&&&&&&& For i = 0 To iNumberLen - 1&&&&&&&&&&& j = CInt(Mid$(varNumber(0), iNumberLen - i, 1))&&&&&&&&&&& strTemp = Mid$(ChnString(iCapital), j + 1, 1)&&&&&&&&&&& &&&&&&&&&&& If j = 0 Then&&&&&&&&&&&&&&& If boolZero = True Then strTemp = ""&&&&&&&&&&&&&&& If i Mod 4 = 0 Then&&&&&&&&&&&&&&&&&&& strTemp = ""&&&&&&&&&&&&&&&&&&& boolZero = True&&&&&&&&&&&&&&&&&&& If i & 0 Then&&&&&&&&&&&&&&&&&&&&&&& strTemp = Mid$(strClass(iCapital), i / 4 + 3, 1)&&&&&&&&&&&&&&&&&&&&&&& If iNumberLen - i & 4 Then&&&&&&&&&&&&&&&&&&&&&&&&&&& If CInt(Right$(Left$(varNumber(0), iNumberLen - i), 4)) = 0 Then strTemp = ""&&&&&&&&&&&&&&&&&&&&&&& End If&&&&&&&&&&&&&&&&&&& End If&&&&&&&&&&&&&&& End If&&&&&&&&&&&&&&& If strTemp = "零" And Capital Then boolZero = True&&&&&&&&&&&&&&& If strTemp = "○" And Not Capital Then boolZero = True&&&&&&&&&&& Else&&&&&&&&&&&&&&& boolZero = False&&&&&&&&&&&&&&& If i Mod 4 = 0 Then&& '万亿兆&&&&&&&&&&&&&&&&&&& j = i / 4 Mod 3&&&&&&&&&&&&&&&&&&& If j = 0 Then j = 6 Else j = j + 3& '可能出现的天文数字&&&&&&&&&&&&&&&&&&& If i & 0 Then strTemp = strTemp & Mid$(strClass(iCapital), j, 1)&&&&&&&&&&&&&&& Else&&&&&&&&&&& '十百千位&&&&&&&&&&&&&&&&&&& strTemp = strTemp & Mid$(strClass(iCapital), i Mod 4, 1)&&&&&&&&&&&&&&& End If&&&&&&&&&&& End If&&&&&&&&&&& ChnNumber = strTemp & ChnNumber&&&&&&&&&&& strTemp = ""&&&&&&& Next&&& End If&&& '处理小数部分&&& If UBound(varNumber) & 0 Then&&&&&&& iNumberLen = Len(varNumber(1))&&&&&&& For i = 1 To iNumberLen&&&&&&&&&&& j = CInt(Mid$(varNumber(1), i, 1))&&&&&&&&&&& strTemp = strTemp & Mid$(ChnString(iCapital), j + 1, 1)&&&&&&& Next&&& End If&&& If Len(strTemp) & 0 Then ChnNumber = ChnNumber & "点" & strTemp&&& If Number & 0 Then ChnNumber = "[负数]" & ChnNumberEnd Function系统托盘图标 例2将下列文件恢复后:form1.picture1中载入一个图标,运行【Project Code:将下面代码用记事本保存为 工程1.vbp(VB工程文件),此括弧及括弧内容除外】Type=ExeClass=CT CTray.clsReference=*\G{0-}#2.0#0#C:\WINDOWS\system32\stdole2.tlb#OLE AutomationForm=Form1.frmStartup="Form1"HelpFile=""Command32=""Name="工程1"HelpContextID="0"CompatibleMode="0"MajorVer=1MinorVer=0RevisionVer=0AutoIncrementVer=0ServerSupportFiles=0VersionCompanyName="xufeng"CompilationType=0OptimizationType=0FavorPentiumPro(tm)=0CodeViewDebugInfo=0NoAliasing=0BoundsCheck=0OverflowCheck=0FlPointCheck=0FDIVCheck=0UnroundedFP=0StartMode=0Unattended=0Retained=0ThreadPerObject=0MaxNumberOfThreads=1[MS Transaction Server]AutoRefresh=1【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】VERSION 5.00Begin VB.Form Form1 && Caption&&&&&&&& =&& "本例演示托盘图标"&& ClientHeight&&& =&& 3090&& ClientLeft&&&&& =&& 165&& ClientTop&&&&&& =&& 855&& ClientWidth&&&& =&& 4680&& Icon&&&&&&&&&&& =&& "Form1.frx":0000&& LinkTopic&&&&&& =&& "Form1"&& ScaleHeight&&&& =&& 3090&& ScaleWidth&&&&& =&& 4680&& StartUpPosition =&& 3& '窗口缺省&& Begin VB.PictureBox Picture1 &&&&& Height&&&&&&&&& =&& 735&&&&& Left&&&&&&&&&&& =&& 720&&&&& Picture&&&&&&&& =&& "Form1.frx":000C&&&&& ScaleHeight&&&& =&& 675&&&&& ScaleWidth&&&&& =&& 915&&&&& TabIndex&&&&&&& =&& 0&&&&& Top&&&&&&&&&&&& =&& 600&&&&& Width&&&&&&&&&& =&& 975&& End&& Begin VB.Menu tempmenu &&&&& Caption&&&&&&&& =&& "托盘菜单"&&&&& Begin VB.Menu m_open &&&&&&&& Caption&&&&&&&& =&& "打开&&&&&&& "&&&&&&&& Shortcut&&&&&&& =&& ^O&&&&& End&&&&& Begin VB.Menu m_save &&&&&&&& Caption&&&&&&&& =&& "保存"&&&&&&&& Shortcut&&&&&&& =&& ^S&&&&& End&&&&& Begin VB.Menu m_11 &&&&&&&& Caption&&&&&&&& =&& "-"&&&&& End&&&&& Begin VB.Menu m_exit &&&&&&&& Caption&&&&&&&& =&& "关闭"&&&&&&&& Shortcut&&&&&&& =&& ^Q&&&&& End&& EndEndAttribute VB_Name = "Form1"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = FalseOption ExplicitDim WithEvents Tray As CTrayAttribute Tray.VB_VarHelpID = -1Private Sub Form_Load()&&& '托盘图标&&& Set Tray = New CTray&&& With Tray&&&&&&& .TipText = Me.Caption&& '提示文本&&&&&&& .PicBox = Picture1&& '一个用于托盘的图标(PictureBox)&&& End With&&& Tray.ShowIcon&& '添加图标在托盘End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)&&& '删除托盘图标&&& Tray.DeleteIcon&&& Set Tray = NothingEnd SubPrivate Sub m_exit_Click()&&& Unload MeEnd Sub'以下为托盘图标事件Private Sub Tray_LButtonDblClick()&&& '左键双击End SubPrivate Sub Tray_LButtonDown()&&& '左键按下End SubPrivate Sub Tray_LButtonUp()&&& '左键放开End SubPrivate Sub Tray_RButtonDblClick()&&& '右键双击End SubPrivate Sub Tray_RButtonDown()&&& '右键按下End SubPrivate Sub Tray_RButtonUp()&&& '右键放开&&& PopupMenu tempmenuEnd Sub【Class Code:将下面代码用记事本保存为 CTray.cls(类模块文件),此括弧及括弧内容除外】VERSION 1.0 CLASSBEGIN& MultiUse = -1& 'True& Persistable = 0& 'NotPersistable& DataBindingBehavior = 0& 'vbNone& DataSourceBehavior& = 0& 'vbNone& MTSTransactionMode& = 0& 'NotAnMTSObjectENDAttribute VB_Name = "CTray"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = TrueAttribute VB_PredeclaredId = FalseAttribute VB_Exposed = False'-------------------------------------------------------------------'类模块:托盘图标的添加'-------------------------------------------------------------------Option ExplicitPrivate Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" _&&&&&&& (ByVal dwMessage As Long, pNid As NOTIFYICONDATA) As BooleanPrivate Const NIM_ADD = &H0Private Const NIM_MODIFY = &H1Private Const NIM_DELETE = &H2Private Const NIF_MESSAGE = &H1Private Const NIF_ICON = &H2Private Const NIF_TIP = &H4Private Const WM_MOUSEMOVE = &H200Private Const WM_LBUTTONDOWN = &H201Private Const WM_LBUTTONUP = &H202Private Const WM_LBUTTONDBLCLK = &H203Private Const WM_RBUTTONDOWN = &H204Private Const WM_RBUTTONUP = &H205Private Const WM_RBUTTONDBLCLK = &H206Private Type NOTIFYICONDATA&&& lSize As Long&&& hWnd As Long&&& lId As Long&&& lFlags As Long&&& lCallBackMessage As Long&&& hIcon As Long&&& szTip As String * 64End TypePrivate mNID As NOTIFYICONDATAPrivate WithEvents mPic As PictureBoxAttribute mPic.VB_VarHelpID = -1Public Event RButtonDown()&&&&& '鼠标右键按下Public Event RButtonUp()&&&&&&& '鼠标右键放开Public Event RButtonDblClick()& '鼠标右键双击Public Event LButtonDown()&&&&& '鼠标左键按下Public Event LButtonUp()&&&&&&& '鼠标左键放开Public Event LButtonDblClick()& '鼠标左键双击Private Sub Class_Initialize()&&& With mNID&&&&&&& .lSize = Len(mNID)&&&&&&& .lCallBackMessage = WM_MOUSEMOVE&&&&&&& .lFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE&&&&&&& .lId = 1&&&& End WithEnd SubPrivate Sub Class_Terminate()&&& DeleteIcon&&& Set mPic = NothingEnd SubPublic Property Let PicBox(ByVal PicBox As PictureBox)&&& Set mPic = PicBox&&& With mNID&&&&&&& .hWnd = mPic.hWnd&&&&&&& .hIcon = mPic&&& End WithEnd PropertyPublic Property Get TipText() As String&&& TipText = mNID.szTipEnd PropertyPublic Property Let TipText(ByVal TipText As String)&&& mNID.szTip = TipText & Chr$(0)&&& Shell_NotifyIcon NIM_MODIFY, mNIDEnd PropertyPublic Function ShowIcon() As Boolean&&& If mPic Is Nothing Then&&&&&&& ShowIcon = False&&& Else&&&&&&& Shell_NotifyIcon NIM_ADD, mNID&&&&&&& ShowIcon = True&&& End IfEnd FunctionPublic Sub DeleteIcon()&&& Shell_NotifyIcon NIM_DELETE, mNIDEnd SubPrivate Sub mPic_Change()&&& mNID.hIcon = mPic&&& Shell_NotifyIcon NIM_MODIFY, mNIDEnd SubPrivate Sub mPic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)&&& Static bRec As Boolean&&& Dim lMsg As Long&&& lMsg = X / Screen.TwipsPerPixelX&&& If bRec = False Then&&&&&&& bRec = True&&&&&&& Select Case lMsg&&&&&&&&&&& Case WM_LBUTTONDBLCLK:&&&&&&&&&&&&&&& '左键双击&&&&&&&&&&&&&&& RaiseEvent LButtonDblClick&&&&&&&&&&& Case WM_LBUTTONDOWN:&&&&&&&&&&&&&&& '左键按下&&&&&&&&&&&&&&& RaiseEvent LButtonDown&&&&&&&&&&& Case WM_LBUTTONUP:&&&&&&&&&&&&&&& '左键放开&&&&&&&&&&&&&&& RaiseEvent LButtonUp&&&&&&&&&&& Case WM_RBUTTONDBLCLK:&&&&&&&&&&&&&&& '右键双击&&&&&&&&&&&&&&& RaiseEvent RButtonDblClick&&&&&&&&&&& Case WM_RBUTTONDOWN:&&&&&&&&&&&&&&& '右键按下&&&&&&&&&&&&&&& RaiseEvent RButtonDown&&&&&&&&&&& Case WM_RBUTTONUP:&&&&&&&&&&&&&&& '右键放开&&&&&&&&&&&&&&& RaiseEvent RButtonUp&&&&&&& End Select&&&&&&& bRec = False&&& End IfEnd SubShell 函数的几个示例'Form Code:'执行一个可执行文件，返回一个 Variant (Double)，'如果成功的话，代表这个程序的任务 ID，若不成功，则会返回 0。'语法'Shell(pathname[,windowstyle])'Shell 函数的语法含有下面这些命名参数:'部分 描述'pathname 必要参数。Variant (String)，要执行的程序名，以及任何必需的参数或命令行变量， _&&&&&&&&&&&&&&&&&&& 可能还包括目录或文件夹，以及驱动器。'Windowstyle 可选参数。Variant (Integer)，表示在程序运行时窗口的样式。 _&&&&&&&&&&&&&&&&&&&&&& 如果 windowstyle 省略，则程序是以具有焦点的最小化窗口来执行的。'windowstyle 命名参数有以下这些值:'常数 值 描述'vbHide 0 窗口是隐藏的，并且焦点被传递给隐藏窗口。'vbNormalFocus 1 窗口拥有焦点，并且恢复到原来的大小与位置。'vbMinimizedFocus 2 窗口缩小为图符并拥有焦点。'vbMaximizedFocus 3 窗口最大化并拥有焦点。'vbNormalNoFocus 4 窗口被恢复到最近一次的大小与位置。当前活动窗口仍为活动窗口。'vbMinimizeNoFocus 6 窗口缩小为图符。当前活动窗口仍为活动窗口。Private Sub Command1_Click()&&& '如果指定文件夹不存在,则创建&&& If Dir("c:\mydos", vbDirectory) = "" Then MkDir "c:\mydos" '在硬盘上新建一个c:\mydos的文件夹。&&& '调用指令,复制一批文件到该文件夹下(需具备xcopy.exe)&&& Shell "xcopy.exe C:\WINDOWS\Web\Wallpaper\*.* c:\mydos/s/e", vbHide&&& '使用浏览器打开该目录&&& Shell "explorer.exe " & "c:\mydos", vbNormalFocusEnd SubPrivate Sub Command2_Click()&&& '把DOS应用程序的屏幕输出写到一个文件中去。&&& '例如用下列代码可把DOS命令copy的帮助信息写到一个文件中去。&&& Open "c:\test.bat" For Output As #1 '建立批处理文件&&& Print #1, "copy/?&c:\copyhelp.txt"&&& Print #1, "@exit"&&& Close #1&&& &&& '执行这个批处理文件&&& Shell "c:\test.bat", vbHide&&& &&& '最后一句必须是@exit，不然经Shell调用后的批处理文件无法从内存中退出End Sub---------------------------------------托盘图标 例1将下列文件恢复后:form1.icon中载入一个图标,运行【Project Code:将下面代码用记事本保存为 PROJECT1.vbp(VB工程文件),此括弧及括弧内容除外】Type=ExeForm=Form1.frmReference=*\G{0-}#2.0#0#C:\WINDOWS\system32\stdole2.tlb#OLE AutomationModule=APIS Apistuff.basIconForm="Form1"Startup="Form1"Command32=""Name="Project1"HelpContextID="0"CompatibleMode="0"MajorVer=1MinorVer=0RevisionVer=0AutoIncrementVer=0ServerSupportFiles=0VersionCompanyName="Rocky Mountain Computer Consulting, Inc."CompilationType=0OptimizationType=0FavorPentiumPro(tm)=0CodeViewDebugInfo=0NoAliasing=0BoundsCheck=0OverflowCheck=0FlPointCheck=0FDIVCheck=0UnroundedFP=0StartMode=0Unattended=0Retained=0ThreadPerObject=0MaxNumberOfThreads=1[MS Transaction Server]AutoRefresh=1【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】VERSION 5.00Begin VB.Form Form1 && Caption&&&&&&&& =&& "Form1"&& ClientHeight&&& =&& 4710&& ClientLeft&&&&& =&& 1635&& ClientTop&&&&&& =&& 1830&& ClientWidth&&&& =&& 7665&& Icon&&&&&&&&&&& =&& "Form1.frx":0000&& LinkTopic&&&&&& =&& "Form1"&& ScaleHeight&&&& =&& 4710&& ScaleWidth&&&&& =&& 7665&& ShowInTaskbar&& =&& 0&& 'False&& Begin VB.Menu mnuFile &&&&& Caption&&&&&&&& =&& "文件"&&&&& Begin VB.Menu mnuFileExit &&&&&&&& Caption&&&&&&&& =&& "退出"&&&&& End&& End&& Begin VB.Menu mnuTray &&&&& Caption&&&&&&&& =&& "Popup"&&&&& Visible&&&&&&&& =&& 0&& 'False&&&&& Begin VB.Menu mnuTrayRestore &&&&&&&& Caption&&&&&&&& =&& "恢复"&&&&& End&&&&& Begin VB.Menu mnuTrayMove &&&&&&&& Caption&&&&&&&& =&& "移动"&&&&& End&&&&& Begin VB.Menu mnuTraySize &&&&&&&& Caption&&&&&&&& =&& "大小"&&&&& End&&&&& Begin VB.Menu mnuTrayMinimize &&&&&&&& Caption&&&&&&&& =&& "最小化"&&&&& End&&&&& Begin VB.Menu mnuTrayMaximize &&&&&&&& Caption&&&&&&&& =&& "最大化"&&&&& End&&&&& Begin VB.Menu mnuTraySep &&&&&&&& Caption&&&&&&&& =&& "-"&&&&& End&&&&& Begin VB.Menu mnuTrayClose &&&&&&&& Caption&&&&&&&& =&& "关闭"&&&&& End&& EndEndAttribute VB_Name = "Form1"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = FalseOption ExplicitPublic LastState As IntegerPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" _&&&&&&& (ByVal hwnd As Long, ByVal wMsg As Long, _&&&&&&& ByVal wParam As Long, lParam As Any) As LongPrivate Const WM_SYSCOMMAND = &H112Private Const SC_MOVE = &HF010&Private Const SC_RESTORE = &HF120&Private Const SC_SIZE = &HF000&Private Sub Form_Load()&&& If WindowState = vbMinimized Then&&&&&&& LastState = vbNormal&&& Else&&&&&&& LastState = WindowState&&& End If&&& AddToTray Me, mnuTray&&& SetTrayTip "VB Helper tray icon program"End SubPrivate Sub Form_Resize()&&& Select Case WindowState&&&&&&& Case vbMinimized&&&&&&&&&&& mnuTrayMaximize.Enabled = True&&&&&&&&&&& mnuTrayMinimize.Enabled = False&&&&&&&&&&& mnuTrayMove.Enabled = False&&&&&&&&&&& mnuTrayRestore.Enabled = True&&&&&&&&&&& mnuTraySize.Enabled = False&&&&&&& Case vbMaximized&&&&&&&&&&& mnuTrayMaximize.Enabled = False&&&&&&&&&&& mnuTrayMinimize.Enabled = True&&&&&&&&&&& mnuTrayMove.Enabled = False&&&&&&&&&&& mnuTrayRestore.Enabled = True&&&&&&&&&&& mnuTraySize.Enabled = False&&&&&&& Case vbNormal&&&&&&&&&&& mnuTrayMaximize.Enabled = True&&&&&&&&&&& mnuTrayMinimize.Enabled = True&&&&&&&&&&& mnuTrayMove.Enabled = True&&&&&&&&&&& mnuTrayRestore.Enabled = False&&&&&&&&&&& mnuTraySize.Enabled = True&&& End Select&&& If WindowState && vbMinimized Then _&&&&&&& LastState = WindowStateEnd SubPrivate Sub Form_Unload(Cancel As Integer)&&& RemoveFromTrayEnd SubPrivate Sub mnuFileExit_Click()&&& Unload MeEnd SubPrivate Sub mnuTrayClose_Click()&&& Unload MeEnd SubPrivate Sub mnuTrayMaximize_Click()&&& WindowState = vbMaximizedEnd SubPrivate Sub mnuTrayMinimize_Click()&&& WindowState = vbMinimizedEnd SubPrivate Sub mnuTrayMove_Click()&&& SendMessage hwnd, WM_SYSCOMMAND, SC_MOVE, 0&End SubPrivate Sub mnuTrayRestore_Click()&&& SendMessage hwnd, WM_SYSCOMMAND, SC_RESTORE, 0&End SubPrivate Sub mnuTraySize_Click()&&& SendMessage hwnd, WM_SYSCOMMAND, SC_SIZE, 0&End Sub(待续)(续)【Module Code:将下面代码用记事本保存为 *.bas(基本模块文件),此括弧及括弧内容除外】Attribute VB_Name = "APIStuff"Option ExplicitPublic OldWindowProc As LongPublic TheForm As FormPublic TheMenu As MenuDeclare 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 LongDeclare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" _&&&&&&& (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As LongPublic Const WM_USER = &H400Public Const WM_LBUTTONUP = &H202Public Const WM_MBUTTONUP = &H208Public Const WM_RBUTTONUP = &H205Public Const TRAY_CALLBACK = (WM_USER + 1001&)Public Const GWL_WNDPROC = (-4)Public Const GWL_USERDATA = (-21)Public Const NIF_ICON = &H2Public Const NIF_TIP = &H4Public Const NIM_ADD = &H0Public Const NIF_MESSAGE = &H1Public Const NIM_MODIFY = &H1Public Const NIM_DELETE = &H2Public Type NOTIFYICONDATA&&& cbSize As Long&&& hwnd As Long&&& uID As Long&&& uFlags As Long&&& uCallbackMessage As Long&&& hIcon As Long&&& szTip As String * 64End TypePrivate TheData As NOTIFYICONDATAPublic Function NewWindowProc(ByVal hwnd As Long, ByVal Msg As Long, _&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ByVal wParam As Long, ByVal lParam As Long) As Long&&& If Msg = TRAY_CALLBACK Then&&&&&&& If lParam = WM_LBUTTONUP Then&&&&&&&&&&& If TheForm.WindowState = vbMinimized Then _&&&&&&&&&&&&&&& TheForm.WindowState = TheForm.LastState&&&&&&&&&&& TheForm.SetFocus&&&&&&&&&&& Exit Function&&&&&&& End If&&&&&&& If lParam = WM_RBUTTONUP Then&&&&&&&&&&& TheForm.PopupMenu TheMenu&&&&&&&&&&& Exit Function&&&&&&& End If&&& End If&&& &&& NewWindowProc = CallWindowProc(OldWindowProc, hwnd, Msg, wParam, lParam)End FunctionPublic Sub AddToTray(frm As Form, mnu As Menu)&&& Set TheForm = frm&&& Set TheMenu = mnu&&& &&& OldWindowProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf NewWindowProc)&&& With TheData&&&&&&& .uID = 0&&&&&&& .hwnd = frm.hwnd&&&&&&& .cbSize = Len(TheData)&&&&&&& .hIcon = frm.Icon.Handle&&&&&&& .uFlags = NIF_ICON&&&&&&& .uCallbackMessage = TRAY_CALLBACK&&&&&&& .uFlags = .uFlags Or NIF_MESSAGE&&&&&&& .cbSize = Len(TheData)&&& End With&&& Shell_NotifyIcon NIM_ADD, TheDataEnd SubPublic Sub RemoveFromTray()&&& With TheData&&&&&&& .uFlags = 0&&& End With&&& Shell_NotifyIcon NIM_DELETE, TheData&&& &&& SetWindowLong TheForm.hwnd, GWL_WNDPROC, OldWindowProcEnd SubPublic Sub SetTrayTip(tip As String)&&& With TheData&&&&&&& .szTip = tip & vbNullChar&&&&&&& .uFlags = NIF_TIP&&& End With&&& Shell_NotifyIcon NIM_MODIFY, TheDataEnd SubPublic Sub SetTrayIcon(pic As Picture)&&& If pic.Type && vbPicTypeIcon Then Exit Sub&&& With TheData&&&&&&& .hIcon = pic.Handle&&&&&&& .uFlags = NIF_ICON&&& End With&&& Shell_NotifyIcon NIM_MODIFY, TheDataEnd Sub---------------------------------------------------几个小函数'(作者:csdngoodnight,E-mail:)Public Function LenBB(Expression As String) As Integer&&& '取得字符串实际字节长度&&& LenBB = LenB(StrConv(Expression, vbFromUnicode))End Function'-------------------------------------'获得我的文档路径'(作者:csdngoodnight,E-mail:)Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _&&&&&&& (ByVal pIdl As Long, ByVal pszPath As String) As LongDeclare Function SHGetSpecialFolderLocation Lib "shell32.dll" _&&&&&&& (ByVal hwndOwner As Long, ByVal nFolder As Long, pIdl As ITEMIDLIST) As LongType SHITEMID&&& cb As Long&&& abID() As ByteEnd TypeType ITEMIDLIST&&& mkid As SHITEMIDEnd TypePublic Function MyDocumentsDir(oForm As Form) As String&&& Dim IDL As ITEMIDLIST&&& Dim sPath As String * 260&&& If SHGetSpecialFolderLocation(oForm.hWnd, 5, IDL) = 0 Then&&&&&&& If SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) Then&&&&&&&&&&& '返回我的文档路径&&&&&&&&&& MyDocumentsDir = Left$(sPath, InStr(sPath, vbNullChar) - 1)&&&&&&& End If&&& End IfEnd Function'----------------------------------------'(作者:csdngoodnight,E-mail:)Public Function RangeDiff(RangeNameA As String, RangeNameB As String) As Integer&&& '返回两列间隔数(Excel表中的列)&&& Dim a As Integer, b As Integer&&& If Len(RangeNameA) = 0 Or Len(RangeNameB) = 0 Then Exit Function&&& RangeNameA = UCase(RangeNameA)&&& RangeNameB = UCase(RangeNameB)&&& If Len(RangeNameA) = 1 Then&&&&&&& a = Asc(RangeNameA) - 64&&& Else&&&&&&& a = (Asc(Left(RangeNameA, 1)) - 64) * 26 + Asc(Right(RangeNameA, 1)) - 64&&& End If&&& If Len(RangeNameB) = 1 Then&&&&&&& b = Asc(RangeNameB) - 64&&& Else&&&&&&& b = (Asc(Left(RangeNameB, 1)) - 64) * 26 + Asc(Right(RangeNameB, 1)) - 64&&& End If&&& RangeDiff = b - aEnd Function'-----------------------------------------'(作者:csdngoodnight,E-mail:)Public Function FindRepeat(strChr As String) As String&&& '判断字符串是否有重复字符&&& Dim i As Integer, j As Integer&&& For i = 1 To Len(strChr)&&&&&&& For j = 1 To Len(strChr)&&&&&&&&&&& If j && i Then&&&&&&&&&&&&&&& If Mid(strChr, i, 1) = Mid(strChr, j, 1) Then&&&&&&&&&&&&&&&&&&& FindRepeat = Mid(strChr, i, 1)&&&&&&&&&&&&&&&&&&& Exit Function&&&&&&&&&&&&&&& End If&&&&&&&&&&& End If&&&&&&& Next&&& NextEnd Function'---------------------------------------------------'(作者:csdngoodnight,E-mail:)'配合上面那个LenBB函数使用Public Function FileNameIs(AllFileDir As String, FileDirIs As String) As String&&& '获取文件路径中的 路径部分 和 文件名部分&&& '调用:&&& 'Dim filedir As String&&& 'Debug.Print "文件名:", FileNameIs("c:\abc.txt", filedir)&&& 'Debug.Print "路径:", filedir&&& If Len(AllFileDir) = 0 Then FileDirIs = "": Exit Function&&& &&& Dim v As Variant&&& Dim i As Integer&&& v = Split(AllFileDir, "\")&&& i = UBound(v)&&& '取得路径&&& FileDirIs = Left(AllFileDir, LenBB(AllFileDir) - LenBB(CStr(v(i))) - 1)&&& '取得文件名&&& FileNameIs = v(i)End Function'---------------------------------------------------检查窗口是否激活Public OldWindowProc As LongDeclare 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 Long'Const GWL_WNDPROC = (-4)Const WM_ACTIVATE = &H6Const WA_ACTIVE = 1Const WA_CLICKACTIVE = 2Const WA_INACTIVE = 0Public Function NewWindowProc(ByVal hWnd As Long, ByVal Msg As Long, _&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ByVal wParam As Long, ByVal lParam As Long) As Long&&& If Msg = WM_ACTIVATE Then&&&&&&& If (wParam = WA_ACTIVE Or wParam = WA_CLICKACTIVE) Then&&&&&&&&&&& '活动&&&&&&&&&&& debug.print "活动"&&&&&&& Else&&&&&&&&&&& '非活动&&&&&&&&&&& debug.print "不活动"&&&&&&& End If&&& End If&&& NewWindowProc = CallWindowProc(OldWindowProc, hWnd, Msg, wParam, lParam)End Function'窗体load中加上此代码:OldWindowProc = SetWindowLong(hWnd, (-4), AddressOf NewWindowProc)-----------------------------------------------------用API指定文件夹(对话框)'Module Code:Private Type BrowseInfo&&&& hWndOwner As Long&&&& pIDLRoot As Long&&&& pszDisplayName As Long&&&& lpszTitle As Long&&&& ulFlags As Long&&&& lpfnCallback As Long&&&& lParam As Long&&&& iImage As LongEnd TypePrivate Const BIF_RETURNONLYFSDIRS = 1Private Const MAX_PATH = 260Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _&&&&&&& (ByVal lpString1 As String, ByVal lpString2 As String) As LongPrivate Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As LongPrivate Declare Function SHGetPathFromIDList Lib "shell32" _&&&&&&& (ByVal pidList As Long, ByVal lpBuffer As String) As LongPublic Function BrowseForFolder(hWndOwner As Long, sPrompt As String) As String&&& Dim iNull As Integer&&& Dim lpIDList As Long&&& Dim lResult As Long&&& Dim sPath As String&&& Dim udtBI As BrowseInfo&&& With udtBI&&&&&&& .hWndOwner = hWndOwner&&&&&&& .lpszTitle = lstrcat(sPrompt, "")&&&&&&& .ulFlags = BIF_RETURNONLYFSDIRS&&& End With&&& lpIDList = SHBrowseForFolder(udtBI)&&& If lpIDList Then&&&&&&& sPath = String$(MAX_PATH, 0)&&&&&& lResult = SHGetPathFromIDList(lpIDList, sPath)&&&&&&& Call CoTaskMemFree(lpIDList)&&&&&&& iNull = InStr(sPath, vbNullChar)&&&&&&& If iNull Then&&&&&&&&&&& sPath = Left$(sPath, iNull - 1)&&&&&&& End If&&& End If&&& BrowseForFolder = sPathEnd Function'Form Code:Private Sub Command1_Click()&&& Dim sDirectoryName As String&&& sDirectoryName = BrowseForFolder(Me.hWnd, "请选择目录")&&& Debug.Print sDirectoryNameEnd Sub------------------------------------------------判定Variant变量值的类型VarType 常数&& 语法: VarType(varname)可在代码中的任何地方用下列常数代替实际值：常数 值 描述 vbEmpty 0 未初始化（缺省值） vbNull 1 不含任何有效数据 vbInteger 2 Integer vbLong 3 长整数 vbSingle 4 单精度浮点数 vbDouble 5 双精度浮点数 vbCurrency 6 Currency vbDate 7 Date vbString 8 String vbObject 9 对象 vbError 10 错误 vbBoolean 11 布尔 vbVariant 12 Variant（只用于变体的数组类型） vbDataObject 13 数据访问对象 vbDecimal 14 Decimal vbByte 17 Byte vbUserDefinedType 36 包含用户定义类型的变量 vbArray 8192 数组 TypeName 函数返回一个 String，提供有关变量的信息。语法: TypeName(varname)必要的 varname 参数是一个 Variant，它包含用户定义类型变量之外的任何变量。TypeName 所返回的字符串可以是下面列举的任何一个字符串：返回字符串 变量 &object type& 类型为 objecttype 的对象 Byte 位值 Integer 整数 Long 长整数 Single 单精度浮点数 Double 双精度浮点数 Currency 货币 Decimal 十进制值 Date 日期 String 字符串 &Boolean& 布尔值:False 或 TrueError 错误值 Empty 未初始化 Null 无效数据 Object 对象 Unknown 类型未知的对象 Nothing 不再引用对象的对象变量 如果 varname 是一个数组，则返回的字符串可以是任何一个后面添加了空括号的可能的返回字符串（或 Variant）。例如，如果 varname 是一个整数数组，则 TypeName 返回 "Integer()"。--------------------------------------------------------VB工程组成结构文件扩展名及描述.bas基本模块.cls类模块.ctl用户控件文件.ctx用户控件的二进制文件.dca活动的设计器的高速缓存.ddf打包和扩展向导CAB信息文件.dep打包和展开向导从属文件.dll运行中的AvtiveX部件.dobAvtiveX文档窗体文件.doxAvtiveX文档二进制窗体文件.dsr活动的设计器文件.dsx活动的设计器的二进制文件.dws部署向导教本文件.exe可执行文件或AvtiveX部件.frm窗体文件.frx二进制窗体文件.log加载错误的日志文件.oca控件类型库缓存文件.ocxAvtiveX控件.pag属性页文件.pgx二进制属性页文件.res资源文件.tlb远程自动化类型库文件.vbdAvtiveX文档状态文件.vbgVisual Basic组工程文件.vbl控件许可文件.vbpVisual Basic工程文件.vbr远程自动化注册文件.vbwVisual Basic工程工作空间文件.vbz向导发射文件.wctWebClass HTML模板-----------------------------------------------"!"感叹号与"."圆点的用法差异都用在对象的属性等的引用上.圆点操作符"."用来表示对象的属性和方法,在引用时需要用在对象的名称、圆点和需要的属性和方法.例如引用按钮的Caption属性:Command1.Caption感叹号"!"常用于一个控件作为一个特性访问的情况下,例如引用另一窗体中的TextBox的Text属性:Form2!Text1.Text,用"!"连接两个控件,且前者是后者的容器.值得注意的是这里如果使用"."替换"!",可以获得同样效果.为了提高代码可读性,用"!"吧.------------------------------------------动态数组相关'介绍如何声明动态数组,以及保留动态数组的内容'声明动态数组Dim MyArray() As IntegerPrivate Sub Form_Load()&&& Dim i As Integer&&& Dim j As Integer&&& j = 5&&& '重定数组数维大小&&& ReDim MyArray(j)&&& Debug.Print "当前数维:", UBound(MyArray)&&& &&& For i = 0 To j&&&&&&& '初始化数组&&&&&&& MyArray(i) = i&&&&&&& Debug.Print MyArray(i)&&& Next&&& &&& &&& '若要再次重定数维大小,而且要保留原有数据&&& '那么,用关键字 Preserve,但它只能重定最末维大小&&& j = j + 5&&& ReDim Preserve MyArray(j)&&& Debug.Print "当前数维:", UBound(MyArray)&&& &&& '查看数据&&& For i = j - 5 To j&&&&&&& MyArray(i) = i&&&&&&& Debug.Print MyArray(i)&&& Next&&& &&& Debug.Print "全部数据:"&&& For i = 0 To j&&&&&&& Debug.Print MyArray(i)&&& NextEnd Sub----------------------------------------------------遍历所有控件和判断控件类型Private Sub Form_DblClick()&&& '定义对象&&& Dim ctl As Control&&& '遍历所有控件&&& For Each ctl In Me&& 'For Each ctl In Me.Controls&&&&&&& '根据类型,改变属性值&&&&&&& If TypeOf ctl Is TextBox Then&&&&&&&&&&& ctl.Text = "文本框" & ctl.Text&&&&&&& ElseIf TypeOf ctl Is Label Then&&&&&&&&&&& ctl.Caption = "标签" & ctl.Caption&&&&&&& ElseIf TypeOf ctl Is CommandButton Then&&&&&&&&&&& ctl.Caption = "按钮" & ctl.Caption&&&&&&& End If&&& NextEnd SubVB的坐标系统综述&由于在visual basic系统中有多种坐标定义,容易使初学者混淆,本文将详细总结vb的坐标系统的一些基本概念，并提供坐标定义的详细方法：visual basic 坐标系统概述：visual basic 的坐标系统是指在屏幕（screen）、窗体(form)、容器(container)上定义的表示图形对象位置的平面二维格线，一般采用数对（x,y）的形式定位。其中，x 值是沿 x 轴点的位置，最左端是缺省位置 0。y 值是沿 y 轴点的位置，最上端是缺省位置 0。在visual basic坐标系中，沿坐标轴定义位置的测量单位，统称为刻度，坐标系统的每个轴都有自己的刻度。坐标轴的方向、起点和刻度都是可变的,在后面的叙述中，将讨论如何改变这些定义。如何创建坐标系统:创建图形对象的坐标系统，一般有以下几种方法：1、使用系统缺省定义：在系统缺省状态下，visual basic使用twips坐标系，以’缇’为单位(1缇的长度等于1/1440英寸；1/567厘米;1/20磅)。应当注意的是：这些值指示的是图形对象打印尺寸的大小。而在计算机屏幕上的物理距离则根据监视器的大小及分辨率的变化而变化。2、选择系统标准刻度定义：除了缺省的twips坐标系外，用户还可以通过对象的scalemode属性来设置其它的坐标刻度：（共有8种设置），现将这些设置列表如下：scalemode值 表示 说明0 user 用户自定义1 twip 缇，系统缺省设置2 point 磅，每英寸约为72磅3 pixel 像素，像素是监视器或打印机分率的最小单位。每英寸里像素的数目由系统设备的分辨率决定。4 character 字符，打印时，一个字符高 1/6 英寸，宽1/12 英寸5 inch 英寸，每英寸为2.54厘米6 millimeter 毫米7 centimeter 厘米　在上述设置值中，除了 0 和 3以外，其它所有模式都是打印机所打印的单位长度。例如，某对象长为4个单位，当 scalemode 设为 5 时，打印时就是4英寸长。在程序中设定scalemode值的代码如下：'设窗体的刻度单位为厘米。scalemode = 7'设 picture1 的刻度单位为像素。picture1.scalemode = 33、创建自定义坐标系统：当scalemode=0时，即为用户自定义模式，可采用设置对象的相应属性，来创建所需的坐标系统,这些属性是：scaleleft: 设置对象左边距值scaletop: 设置对象上边距值scalewidth: 设置对象宽度scaleheight: 设置对象高度下面给出如下设置代码：scaleleft=100scaletop=100scalewidth=300scaleheight=200picture1.scaleleft=50picture1.scaletop=50则所定义的坐标系如下图所示：scaletop=100picture1.scaleleft=50以上代码定义窗体左上角坐标为（100，100），定义窗体内图形对象picture1距窗体左边距离为50，上边距离为50。scalewidth 和 scaleheight 语句定义窗体内部宽度的 1/300 为水平坐标单位；当前窗体内部高度的 1/200 为垂直坐标单位。如果窗体的大小以后被调整，这些单位保持原状。也就是说：scalewidth 和 scaleheight 是按照对象的内部尺寸来定义单位的，并且这些尺寸不包括边框厚度或菜单标题的高度。scalewidth 和 scaleheight 是指对象内的可用空间的大小。它们决定了对象本身的坐标系统。这有别于内部尺寸和外部尺寸（由 width 和 height属性指定）定义，width 和 height 总是按照容器的坐标系统来表示。另外以上刻度属性都可包括分数，也可是负数。如果将 scalewidth 和 scaleheight 属性设置值为负数即改变坐标系统的方向。4．使用scale方法定义坐标系统：一个更简洁的改变坐标系统的途径是使用 scale 方法。定义形式如下：[object.]scale (x1, y1) – (x2, y2)x1 和 y1 的值，决定了 scaleleft 和 scaletop 属性的设置值。x2-x1的差值和y2-y1的差值，分别决定了 scalewidth 和 scaleheight 属性的设置值。若指定 x1 & x2 或 y1 & y2 的值，与设置 scalewidth 或 scaleheight 为负值的效果相同。例如：设定窗体坐标系统如下：scale (100, 100)-(200, 200)该语句定义等同于以下属性设置：scaletop=100:scaleleft=100:scalewidth=100:scaleheight=100如何恢复缺省坐标系统：在定义了其它坐标系后，如果需要将坐标系统恢复为缺省的twips坐标系，可以使用不含参数的scale方法，如语句：picture1.scale将图形对象的坐标系统恢复为缺省，其左上角坐标为（0，0）。---------------------------------------------------------键码键码常数&&&&&&&&&&& 值&&&&&&&&&& 描述 vbKeyLButton 1 鼠标左键 vbKeyRButton 2 鼠标右键 vbKeyCancel 3 CANCEL 键 vbKeyMButton 4 鼠标中键 vbKeyBack 8 BACKSPACE 键 vbKeyTab 9 TAB 键 vbKeyClear 12 CLEAR 键 vbKeyReturn 13 ENTER 键 vbKeyShift 16 SHIFT 键 vbKeyControl 17 CTRL 键 vbKeyMenu 18 菜单键 vbKeyPause 19 PAUSE 键 vbKeyCapital 20 CAPS LOCK 键 vbKeyEscape 27 ESC 键 vbKeySpace 32 SPACEBAR 键 vbKeyPageUp 33 PAGEUP 键 vbKeyPageDown 34 PAGEDOWN 键 vbKeyEnd 35 END 键 vbKeyHome 36 HOME 键 vbKeyLeft 37 LEFT ARROW 键 vbKeyUp 38 UP ARROW 键 vbKeyRight 39 RIGHT ARROW 键 vbKeyDown 40 DOWN ARROW 键 vbKeySelect 41 SELECT 键 vbKeyPrint 42 PRINT SCREEN 键 vbKeyExecute 43 EXECUTE 键 vbKeySnapshot 44 SNAP SHOT 键 vbKeyInser 45 INS 键 vbKeyDelete 46 DEL 键 vbKeyHelp 47 HELP 键 vbKeyNumlock 144 NUM LOCK 键 A 键到 Z 键与其 ASCII 码的相应值'A' 到 'Z' 是一致的常数 值 描述 vbKeyA 65 A 键 vbKeyB 66 B 键 vbKeyC 67 C 键 vbKeyD 68 D 键 vbKeyE 69 E 键 vbKeyF 70 F 键 vbKeyG 71 G 键 vbKeyH 72 H 键 vbKeyI 73 I 键 vbKeyJ 74 J 键 vbKeyK 75 K 键 vbKeyL 76 L 键 vbKeyM 77 M 键 vbKeyN 78 N 键 vbKeyO 79 O 键 vbKeyP 80 P 键 vbKeyQ 81 Q 键 vbKeyR 82 R 键 vbKeyS 83 S 键 vbKeyT 84 T 键 vbKeyU 85 U 键 vbKeyV 86 V 键 vbKeyW 87 W 键 vbKeyX 88 X 键 vbKeyY 89 Y 键 vbKeyZ 90 Z 键 0 键到 9 键与其 ASCII 码的相应值 '0' 到 '9' 是一致的常数 值 描述 vbKey0 48 0 键 vbKey1 49 1 键 vbKey2 50 2 键 vbKey3 51 3 键 vbKey4 52 4 键 vbKey5 53 5 键 vbKey6 54 6 键 vbKey7 55 7 键 vbKey8 56 8 键 vbKey9 57 9 键 数字小键盘上的键常数 值 描述 vbKeyNumpad0 96 0 键 vbKeyNumpad1 97 1 键 vbKeyNumpad2 98 2 键 vbKeyNumpad3 99 3 键 vbKeyNumpad4 100 4 键 vbKeyNumpad5 101 5 键 vbKeyNumpad6 102 6 键 vbKeyNumpad7 103 7 键 vbKeyNumpad8 104 8 键 vbKeyNumpad9 105 9 键 vbKeyMultiply 106 乘号 (*) 键 vbKeyAdd 107 加号 (+) 键 vbKeySeparator 108 ENTER 键（在数字小键盘上） vbKeySubtract 109 减号 (-) 键 vbKeyDecimal 110 小数点 (.) 键 vbKeyDivide 111 除号 (/) 键 功能键常数 值 描述 vbKeyF1 112 F1 键 vbKeyF2 113 F2 键 vbKeyF3 114 F3 键 vbKeyF4 115 F4 键 vbKeyF5 116 F5 键 vbKeyF6 117 F6 键 vbKeyF7 118 F7 键 vbKeyF8 119 F8 键 vbKeyF9 120 F9 键 vbKeyF10 121 F10 键 vbKeyF11 122 F11 键 vbKeyF12 123 F12 键 vbKeyF13 124 F13 键 vbKeyF14 125 F14 键 vbKeyF15 126 F15 键 vbKeyF16 127 F16 键以下是我的一个安装包的注释内容:- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -;下面的注释包含自解压脚本命令Path=xufengn635 v2.0SavePathSetup=xfn6353.exeOverwrite=1Title=庆晓资料运算工具 2.0 安装程序Text{《庆晓资料运算工具& ver 2.0 最终用户许可协议》首先你必须承认：世界上没有烤不熟的地瓜，以表明你与作者就地瓜一事已达成共识。其次，(此处略去)联系作者：旭峰 E-mail: }Shortcut=D, "xfn6353.exe", "", "", "庆晓资料运算工具 2.0"Shortcut=P, "xfn6353.exe", "", "", "庆晓资料运算工具 2.0"- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -用WinRar制作自释放压缩包,可以同样有安装界面,同样可以创建快捷键,可以有反安装项,仅把需要的几个部件加进去就行了.体积不会很大,适用于一些免费软件.上述安装包仅1.25M,一张软盘就可以带走.在win98-2上(没有装过任何VB类型程序的系统)运行都可以通过.其中包括的组件及描述:xfn6353.exe主程序(form 3个,用户控件 2个,image 若干,picturebox 8个,Label 若干,combobox 若干,timer ...)704k MSVBVM60.DLL运行库(我们用的很多函数和一些基本控件,诸如Mid,UCase,Shell,Left,Right...都在里面) 1.34MPICCLP32.OCX因为做了个动画,用到了PictureClip,所以连控件一并打包 81.1khelp.chm帮助文件 446kSound目录有几个WAV在里面 40kn635.ico图标,工程和压缩包都用到(为了减小体积,要把图标文件中不需要的24X,48X,真彩色等图层全部去掉.仅保留16X 256色和32X 256色两层)要注意的是,有些不能自我注册的Dll或OCX,可以写个BAT文件解压后自动运行执行注册:regsvr32 abcd.dllrem regsvr32 /u abcd.dll@exit(那个regsvr32.exe要13k大小,第二行被注释掉的是反注册命令)&---------------------------------------------------------------磁盘序号'Form Code:Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" _&&&&&&& (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, _&&&&&&& ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, _&&&&&&& lpMaximumComponentLength As Long, lpFileSystemFlags As Long, _&&&&&&& ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As LongFunction GetSerialNumber(strDrive As String) As Long&&& Dim SerialNum As Long&&& Dim Res As Long&&& Dim Temp1 As String&&& Dim Temp2 As String&&& Temp1 = String$(255, Chr$(0))&&& Temp2 = String$(255, Chr$(0))&&& Res = GetVolumeInformation(strDrive, Temp1, _&&& Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))&&& GetSerialNumber = SerialNumEnd Function&Private Sub form_load()&&& '使用该函数:&&&& MsgBox GetSerialNumber("c:\")&&& '它将告诉你C驱的磁盘序号。End Sub--------------------------------------------------------获取所有驱动器类型【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】VERSION 5.00Begin VB.Form Demo_Frm && Caption&&&&&&&& =&& "Demo"&& ClientHeight&&& =&& 2670&& ClientLeft&&&&& =&& 3795&& ClientTop&&&&&& =&& 1905&& ClientWidth&&&& =&& 4035&& LinkTopic&&&&&& =&& "Form1"&& ScaleHeight&&&& =&& 2670&& ScaleWidth&&&&& =&& 4035&& Tag&&&&&&&&&&&& =&& "hello"&& Begin VB.ListBox List1 &&&&& Height&&&&&&&&& =&& 2040&&&&& Left&&&&&&&&&&& =&& 120&&&&& TabIndex&&&&&&& =&& 1&&&&& Top&&&&&&&&&&&& =&& 240&&&&& Width&&&&&&&&&& =&& 3855&& End&& Begin VB.CommandButton Command1 &&&&& Caption&&&&&&&& =&& "获取信息"&&&&& Height&&&&&&&&& =&& 375&&&&& Left&&&&&&&&&&& =&& 1440&&&&& TabIndex&&&&&&& =&& 0&&&&& Top&&&&&&&&&&&& =&& 2280&&&&& Width&&&&&&&&&& =&& 975&& EndEndAttribute VB_Name = "Demo_Frm"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = FalsePrivate Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" _&&&&&&& (ByVal nBufferLength As Long, ByVal lpBuffer As String) As LongPrivate Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _&&&&&&& (ByVal nDrive As String) As LongPrivate Declare Function GetLogicalDrives Lib "kernel32" () As LongPrivate Const DRIVE_UNKNOWN = 0Private Const DRIVE_NO_ROOT_DIR = 1Private Const DRIVE_REMOVABLE = 2Private Const DRIVE_FIXED = 3Private Const DRIVE_REMOTE = 4Private Const DRIVE_CDROM = 5Private Const DRIVE_RAMDISK = 6'　　用来返回磁盘驱动器的个数Public Function DriveCount() As Integer&&& Dim BitMask As Long&&& Dim j, i&&& &&& BitMask = GetLogicalDrives()&&& For i = 0 To 24&&&&&&& If BitMask And 2 ^ i Then&&&&&&&&&&& j = j + 1&&&&&&& End If&&& Next i&&& DriveCount = jEnd Function'& 返回驱动器的名称Public Function LoadDrivenames(An_Array() As String) As Long&&& Dim j, i&&& Dim lpBuffer As String&&& &&& ReDim An_Array(128) As String&&& lpBuffer = Space$(1024)&&& '& 返回当前所有逻辑驱动器的根驱动器路径&&& GetLogicalDriveStrings Len(lpBuffer), lpBuffer&&& j = InStr(lpBuffer, Chr$(0))&&& '& 存储磁盘驱动器的名称到An_Array中&&& Do While j & 0&&&&&&& An_Array(i) = Left$(lpBuffer, j - 1)&&&&&&& i = i + 1&&&&&&& lpBuffer = Mid$(lpBuffer, j + 1)&&&&&&& j = InStr(lpBuffer, Chr$(0))&&& Loop&&& ReDim Preserve An_Array(DriveCount)End Function'& 返回磁盘驱动器的类型Public Function Types(Optional sDrive As String) As String&&& Select Case GetDriveType(sDrive)&&&&&&& Case DRIVE_UNKNOWN&&&&&&& Types = "不能识别"&&&&&&& Case DRIVE_NO_ROOT_DIR&&&&&&& Types = "不存在"&&&&&&& Case DRIVE_REMOVABLE&&&&&&& Types = "可移除驱动器"&&&&&&& Case DRIVE_FIXED&&&&&&& Types = "固定驱动器"&&&&&&& Case DRIVE_REMOTE&&&&&&& Types = "远程驱动器"&&&&&&& Case DRIVE_CDROM&&&&&&& Types = "光盘驱动器"&&&&&&& Case DRIVE_RAMDISK&&&&&&& Types = "随机存取磁盘"&&&&&&& Case Else&&&&&&& Types = "ERROR"&&& End SelectEnd FunctionPrivate Sub Command1_Click()&&& Dim DrivesN() As String&&& Dim i As Integer&&& &&& Me.Cls&&& Print "驱动器个数:" & DriveCount&&& Call LoadDrivenames(DrivesN)&&& For i = 0 To DriveCount - 1&&&&&&& List1.AddItem DrivesN(i) & Types(DrivesN(i))&&& Next iEnd Sub-------------------------------------------------ComboBox加长加宽下拉选单'form code:Private Declare Function MoveWindow Lib "user32" _&&&&&&& (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _&&&&&&& ByVal nHeight As Long, ByVal bRepaint As Long) As LongPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" _&&&&&&& (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As LongConst CB_SETDROPPEDWIDTH = &H160'& 设置ComboBox下拉选单长度函数Public Sub SetComboHeight(ComboBox_Obj As ComboBox, NewHeight As Long)&&& Dim OldScaleMode As Integer&&& If TypeOf ComboBox_Obj.Parent Is Frame Then Exit Sub&&& ' 改变ComboBox控件的容器的坐标度量单位为象素&&& OldScaleMode = ComboBox_Obj.Parent.ScaleMode&&& ComboBox_Obj.Parent.ScaleMode = vbPixels&&& ' 重新定义ComboBox的尺寸&&& MoveWindow ComboBox_Obj.hwnd, ComboBox_Obj.Left, _&&& ComboBox_Obj.Top, ComboBox_Obj.Width, NewHeight, 1&&& ' 恢复ComboBox控件的容器的坐标度量单位&&& ComboBox_Obj.Parent.ScaleMode = OldScaleModeEnd Sub'& 设置ComboBox下拉选单宽度函数Public Sub SetComboWidth(ComboBox_Obj As ComboBox, NewWidth As Long)&&& '& NewWidth 是宽度，单位是 pixels&&& SendMessage ComboBox_Obj.hwnd, CB_SETDROPPEDWIDTH, NewWidth, 0End SubPrivate Sub Form_Load()&&& Dim i As Integer&&& '& 向ComboBox添加项&&& For i = 0 To 40&&&&&&& Combo1.AddItem ("This is the long Item " + CStr(i))&&& Next iEnd Sub'& 改变ComboBox下拉选单长度和宽度Private Sub Change_But_Click()&&& Call SetComboHeight(Combo1, 300)&&& Call SetComboWidth(Combo1, 200)End Sub&获取硬盘序列号、生产厂家/型号【Class Code:将下面代码用记事本保存为 CDiskInfo.cls(类模块文件),此括弧及括弧内容除外】Option Explicit'http://vip.6to23.com/NowCan1/tech/vb_hd_info.htm'--------------------------------------------------------------------------'&& 类模块： CDiskInfo.cls'&& 功能说明：获取硬盘序列号、生产厂家/型号'&& 注意事项：支持Windows 95 OSR2, Windows 98, Windows NT, Windows 2000'&&&&&&&&&&&& XP没有测试，估计没问题，在Win9X下必须保证存在SMARTVSD.vxd'--------------------------------------------------------------------------Private Const MAX_IDE_DRIVES As Long = 4Private Const READ_ATTRIBUTE_BUFFER_SIZE As Long = 512Private Const IDENTIFY_BUFFER_SIZE As Long = 512Private Const READ_THRESHOLD_BUFFER_SIZE As Long = 512Private Const DFP_GET_VERSION As Long = &H74080Private Const DFP_SEND_DRIVE_COMMAND As Long = &H7C084Private Const DFP_RECEIVE_DRIVE_DATA As Long = &H7C088Private Type GETVERSIONOUTPARAMS&&& bVersion As Byte&&& bRevision As Byte&&& bReserved As Byte&&& bIDEDeviceMap As Byte&&& fCapabilities As Long&&& dwReserved(3) As LongEnd TypePrivate Const CAP_IDE_ID_FUNCTION As Long = 1Private Const CAP_IDE_ATAPI_ID As Long = 2Private Const CAP_IDE_EXECUTE_SMART_FUNCTION As Long = 4Private Type IDEREGS&&& bFeaturesReg As Byte&&& bSectorCountReg As Byte&&& bSectorNumberReg As Byte&&& bCylLowReg As Byte&&& bCylHighReg As Byte&&& bDriveHeadReg As Byte&&& bCommandReg As Byte&&& bReserved As ByteEnd TypePrivate Type SENDCMDINPARAMS&&& cBufferSize As Long&&& irDriveRegs As IDEREGS&&& bDriveNumber As Byte&&& bReserved(2) As Byte&&& dwReserved(3) As Long&&& bBuffer(0) As ByteEnd TypePrivate Const IDE_ATAPI_ID As Long = &HA1Private Const IDE_ID_FUNCTION As Long = &HECPrivate Const IDE_EXECUTE_SMART_FUNCTION As Long = &HB0Private Const SMART_CYL_LOW As Long = &H4FPrivate Const SMART_CYL_HI As Long = &HC2Private Type DRIVERSTATUS&&& bDriverError As Byte&&& bIDEStatus As Byte&&& bReserved(1) As Byte&&& dwReserved(1) As LongEnd TypePrivate Const SMART_NO_ERROR As Long = 0Private Const SMART_IDE_ERROR As Long = 1Private Const SMART_INVALID_FLAG As Long = 2Private Const SMART_INVALID_COMMAND As Long = 3Private Const SMART_INVALID_BUFFER As Long = 4Private Const SMART_INVALID_DRIVE As Long = 5Private Const SMART_INVALID_IOCTL As Long = 6Private Const SMART_ERROR_NO_MEM As Long = 7Private Const SMART_INVALID_REGISTER As Long = 8Private Const SMART_NOT_SUPPORTED As Long = 9Private Const SMART_NO_IDE_DEVICE As Long = 10Private Type SENDCMDOUTPARAMS&&& cBufferSize As Long&&& drvStatus As DRIVERSTATUS&&& bBuffer(0) As ByteEnd TypePrivate Const SMART_READ_ATTRIBUTE_VALUES As Long = &HD0Private Const SMART_READ_ATTRIBUTE_THRESHOLDS As Long = &HD1Private Const SMART_ENABLE_DISABLE_ATTRIBUTE_AUTOSAVE As Long = &HD2Private Const SMART_SAVE_ATTRIBUTE_VALUES As Long = &HD3Private Const SMART_EXECUTE_OFFLINE_IMMEDIATE As Long = &HD4Private Const SMART_ENABLE_SMART_OPERATIONS As Long = &HD8Private Const SMART_DISABLE_SMART_OPERATIONS As Long = &HD9Private Const SMART_RETURN_SMART_STATUS As Long = &HDAPrivate Type DRIVEATTRIBUTE&&& bAttrID As Byte&&& wStatusFlags As Integer&&& bAttrValue As Byte&&& bWorstValue As Byte&&& bRawValue(5) As Byte&&& bReserved As ByteEnd TypePrivate Type ATTRTHRESHOLD&&& bAttrID As Byte&&& bWarrantyThreshold As Byte&&& bReserved(9) As ByteEnd TypePrivate Type IDSECTOR&&& wGenConfig As Integer&&& wNumCyls As Integer&&& wReserved As Integer&&& wNumHeads As Integer&&& wBytesPerTrack As Integer&&& wBytesPerSector As Integer&&& wSectorsPerTrack As Integer&&& wVendorUnique(2) As Integer&&& sSerialNumber(19) As Byte&&& wBufferType As Integer&&& wBufferSize As Integer&&& wECCSize As Integer&&& sFirmwareRev(7) As Byte&&& sModelNumber(39) As Byte&&& wMoreVendorUnique As Integer&&& wDoubleWordIO As Integer&&& wCapabilities As Integer&&& wReserved1 As Integer&&& wPIOTiming As Integer&&& wDMATiming As Integer&&& wBS As Integer&&& wNumCurrentCyls As Integer&&& wNumCurrentHeads As Integer&&& wNumCurrentSectorsPerTrack As Integer&&& ulCurrentSectorCapacity(3) As Byte&&& wMultSectorStuff As Integer&&& ulTotalAddressableSectors(3) As Byte&&& wSingleWordDMA As Integer&&& wMultiWordDMA As Integer&&& bReserved(127) As ByteEnd TypePrivate Const ATTR_INVALID As Long = 0Private Const ATTR_READ_ERROR_RATE As Long = 1Private Const ATTR_THROUGHPUT_PERF As Long = 2Private Const ATTR_SPIN_UP_TIME As Long = 3Private Const ATTR_START_STOP_COUNT As Long = 4Private Const ATTR_REALLOC_SECTOR_COUNT As Long = 5Private Const ATTR_READ_CHANNEL_MARGIN As Long = 6Private Const ATTR_SEEK_ERROR_RATE As Long = 7Private Const ATTR_SEEK_TIME_PERF As Long = 8Private Const ATTR_POWER_ON_HRS_COUNT As Long = 9Private Const ATTR_SPIN_RETRY_COUNT As Long = 10Private Const ATTR_CALIBRATION_RETRY_COUNT As Long = 11Private Const ATTR_POWER_CYCLE_COUNT As Long = 12Private Const PRE_FAILURE_WARRANTY As Long = &H1Private Const ON_LINE_COLLECTION As Long = &H2Private Const PERFORMANCE_ATTRIBUTE As Long = &H4Private Const ERROR_RATE_ATTRIBUTE As Long = &H8Private Const EVENT_COUNT_ATTRIBUTE As Long = &H10Private Const SELF_PRESERVING_ATTRIBUTE As Long = &H20Private Const NUM_ATTRIBUTE_STRUCTS As Long = 30Private Const INVALID_HANDLE_VALUE As Long = -1Private Const VER_PLATFORM_WIN32s As Long = 0Private Const VER_PLATFORM_WIN32_WINDOWS As Long = 1Private Const VER_PLATFORM_WIN32_NT As Long = 2Private Type OSVERSIONINFO&&& dwOSVersionInfoSize As Long&&& dwMajorVersion As Long&&& dwMinorVersion As Long&&& dwBuildNumber As Long&&& dwPlatformId As Long&&& szCSDVersion As String * 128End Type(待续)(续)Private Declare Function GetVersionEx Lib "KERNEL32" Alias "GetVersionExA" _&&& (lpVersionInformation As OSVERSIONINFO) As LongPrivate Const CREATE_NEW As Long = 1Private Const GENERIC_READ As Long = &HPrivate Const GENERIC_WRITE As Long = &HPrivate Const FILE_SHARE_READ As Long = &H1Private Const FILE_SHARE_WRITE As Long = &H2Private Const OPEN_EXISTING& As Long = 3Private Declare Function CreateFile Lib "KERNEL32" Alias "CreateFileA" _&&& (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _&&& ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _&&& ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _&&& ByVal hTemplateFile As Long) As LongPrivate Declare Function DeviceIoControl Lib "KERNEL32" _&&& (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, _&&& ByVal nInBufferSize As Long, lpOutBuffer As Any, _&&& ByVal nOutBufferSize As Long, lpBytesReturned As Long, _&&& ByVal lpOverlapped As Long) As LongPrivate Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _&&& (Destination As Any, Source As Any, ByVal Length As Long)Private Declare Function CloseHandle Lib "KERNEL32" _&&& (ByVal hObject As Long) As LongPrivate m_DiskInfo As IDSECTORPrivate Function OpenSMART(ByVal nDrive As Byte) As Long&&& Dim hSMARTIOCTL As Long&&& Dim hd As String&&& Dim VersionInfo As OSVERSIONINFO&&& hSMARTIOCTL = INVALID_HANDLE_VALUE&&& VersionInfo.dwOSVersionInfoSize = Len(VersionInfo)&&& GetVersionEx VersionInfo&&& Select Case VersionInfo.dwPlatformId&&&&&&& Case VER_PLATFORM_WIN32s&&&&&&&&&&& OpenSMART = hSMARTIOCTL&&&&&&& Case VER_PLATFORM_WIN32_WINDOWS&&&&&&&&&&& 'Version Windows 95 OSR2, Windows 98&&&&&&&&&&& hSMARTIOCTL = CreateFile("\\.\SMARTVSD", 0, 0, 0, CREATE_NEW, 0, 0)&&&&&&& Case VER_PLATFORM_WIN32_NT&&&&&&&&&&& 'Windows NT, Windows 2000&&&&&&&&&&& If nDrive & MAX_IDE_DRIVES Then&&&&&&&&&&&&&&& hd = "\\.\PhysicalDrive" & nDrive&&&&&&&&&&&&&&& hSMARTIOCTL = CreateFile(hd, GENERIC_READ Or GENERIC_WRITE, _&&&&&&&&&&&&&&& FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0)&&&&&&&&&&& End If&&& End Select&&& OpenSMART = hSMARTIOCTLEnd FunctionPrivate Function DoIDENTIFY(ByVal hSMARTIOCTL As Long, _&&& pSCIP As SENDCMDINPARAMS, pSCOP() As Byte, ByVal bIDCmd As Byte, _&&& ByVal bDriveNum As Byte, lpcbBytesReturned As Long) As Boolean&&& '-------------------------------------------------------------------&&& pSCIP.cBufferSize = IDENTIFY_BUFFER_SIZE&&& pSCIP.irDriveRegs.bFeaturesReg = 0&&& pSCIP.irDriveRegs.bSectorCountReg = 1&&& pSCIP.irDriveRegs.bSectorNumberReg = 1&&& pSCIP.irDriveRegs.bCylLowReg = 0&&& pSCIP.irDriveRegs.bCylHighReg = 0&&& pSCIP.irDriveRegs.bDriveHeadReg = &HA0 Or ((bDriveNum And 1) * 2 ^ 4)&&& pSCIP.irDriveRegs.bCommandReg = bIDCmd&&& pSCIP.bDriveNumber = bDriveNum&&& pSCIP.cBufferSize = IDENTIFY_BUFFER_SIZE&&& DoIDENTIFY = CBool(DeviceIoControl(hSMARTIOCTL, DFP_RECEIVE_DRIVE_DATA, _&&&&&&& pSCIP, 32, pSCOP(0), 528, lpcbBytesReturned, 0))End FunctionPrivate Function DoEnableSMART(ByVal hSMARTIOCTL As Long, _&&& pSCIP As SENDCMDINPARAMS, pSCOP As SENDCMDOUTPARAMS, _&&& ByVal bDriveNum As Byte, lpcbBytesReturned As Long) As Boolean&&& '---------------------------------------------------------------------&&& pSCIP.cBufferSize = 0&&& pSCIP.irDriveRegs.bFeaturesReg = SMART_ENABLE_SMART_OPERATIONS&&& pSCIP.irDriveRegs.bSectorCountReg = 1&&& pSCIP.irDriveRegs.bSectorNumberReg = 1&&& pSCIP.irDriveRegs.bCylLowReg = SMART_CYL_LOW&&& pSCIP.irDriveRegs.bCylHighReg = SMART_CYL_HI&&& pSCIP.irDriveRegs.bDriveHeadReg = &HA0 Or ((bDriveNum And 1) * 2 ^ 4)&&& pSCIP.irDriveRegs.bCommandReg = IDE_EXECUTE_SMART_FUNCTION&&& pSCIP.bDriveNumber = bDriveNum&&& DoEnableSMART = CBool(DeviceIoControl(hSMARTIOCTL, DFP_SEND_DRIVE_COMMAND, _&&&&&&& pSCIP, LenB(pSCIP) - 1, pSCOP, LenB(pSCOP) - 1, lpcbBytesReturned, 0))End FunctionPrivate Sub ChangeByteOrder(szString() As Byte, ByVal uscStrSize As Integer)&&& Dim i As Integer&&& Dim bTemp As Byte&&& For i = 0 To uscStrSize - 1 Step 2&&&&&&& bTemp = szString(i)&&&&&&& szString(i) = szString(i + 1)&&&&&&& szString(i + 1) = bTemp&&& Next iEnd SubPrivate Sub DisplayIdInfo(pids As IDSECTOR, pSCIP As SENDCMDINPARAMS, _&&& ByVal bIDCmd As Byte, ByVal bDfpDriveMap As Byte, ByVal bDriveNum As Byte)&&& '--------------------------------------------------------------------------&&& ChangeByteOrder pids.sModelNumber, UBound(pids.sModelNumber) + 1&&& 'ChangeByteOrder pids.sFirmwareRev, UBound(pids.sFirmwareRev) + 1&&& ChangeByteOrder pids.sSerialNumber, UBound(pids.sSerialNumber) + 1End Sub'调用过程Public Function GetDiskInfo(ByVal nDrive As Byte) As Long&&& Dim hSMARTIOCTL As Long&&& Dim cbBytesReturned As Long&&& Dim VersionParams As GETVERSIONOUTPARAMS&&& Dim scip As SENDCMDINPARAMS&&& Dim scop() As Byte&&& Dim OutCmd As SENDCMDOUTPARAMS&&& Dim bDfpDriveMap As Byte&&& Dim bIDCmd As Byte&&& Dim uDisk As IDSECTOR&&& m_DiskInfo = uDisk&&& &&& hSMARTIOCTL = OpenSMART(nDrive)&&& If hSMARTIOCTL && INVALID_HANDLE_VALUE Then&&&&&&& Call DeviceIoControl(hSMARTIOCTL, DFP_GET_VERSION, ByVal 0, 0, _&&&&&&&&&&& VersionParams, Len(VersionParams), cbBytesReturned, 0)&&&&&&& If Not (VersionParams.bIDEDeviceMap \ 2 ^ nDrive And &H10) Then&&&&&&&&&&& If DoEnableSMART(hSMARTIOCTL, scip, OutCmd, nDrive, cbBytesReturned) Then&&&&&&&&&&&&&&& bDfpDriveMap = bDfpDriveMap Or 2 ^ nDrive&&&&&&&&&&& End If&&&&&&& End If&&&&&&& bIDCmd = IIf((VersionParams.bIDEDeviceMap \ 2 ^ nDrive And &H10), _&&&&&&&&&&& IDE_ATAPI_ID, IDE_ID_FUNCTION)&&&&&&& ReDim scop(LenB(OutCmd) + IDENTIFY_BUFFER_SIZE - 1) As Byte&&&&&&& If DoIDENTIFY(hSMARTIOCTL, scip, scop, bIDCmd, nDrive, cbBytesReturned) Then&&&&&&&&&&& CopyMemory m_DiskInfo, scop(LenB(OutCmd) - 4), LenB(m_DiskInfo)&&&&&&&&&&& Call DisplayIdInfo(m_DiskInfo, scip, bIDCmd, bDfpDriveMap, nDrive)&&&&&&&&&&& CloseHandle hSMARTIOCTL&&&&&&&&&&& GetDiskInfo = 1&&&&&&&&&&& Exit Function&&&&&&& End If&&&&&&& CloseHandle hSMARTIOCTL&&&&&&& GetDiskInfo = 0&&&&& Else&&&&&&& GetDiskInfo = -1&&& End IfEnd Function'硬盘生产厂/型号Public Property Get pSerialNumber() As String&&& pSerialNumber = StrConv(m_DiskInfo.sSerialNumber, vbUnicode)&&& pSerialNumber = PurString(pSerialNumber)End Property'硬盘序列号Public Property Get pModelNumber() As String&&& pModelNumber = StrConv(m_DiskInfo.sModelNumber, vbUnicode)&&& pModelNumber = PurString(pModelNumber)End PropertyPrivate Function PurString(str As String) As String&&& 'On Error Resume Next&&& Dim i As Integer&&& For i = 1 To Len(str)&&&&&&& If Asc(Mid(str, i, 1)) && 0 Then PurString = PurString & Mid(str, i, 1)&&& Next&&& PurString = Trim(PurString)End Function'################################################################################'窗体代码：'Private Sub Form_Load()'&&& Dim hdinfo As New CDiskInfo'&&& hdinfo.GetDiskInfo 0'&&& Text1.Text = "生产厂家/型号:" & hdinfo.pModelNumber'&&& Text2.Text = "硬盘序列号:" & hdinfo.pSerialNumber'End Sub设置显示模式【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】VERSION 5.00Begin VB.Form Form1 && Caption&&&&&&&& =&& "Form1"&& ClientHeight&&& =&& 3540&& ClientLeft&&&&& =&& 60&& ClientTop&&&&&& =&& 345&& ClientWidth&&&& =&& 5970&& LinkTopic&&&&&& =&& "Form1"&& ScaleHeight&&&& =&& 3540&& ScaleWidth&&&&& =&& 5970&& StartUpPosition =&& 3& '窗口缺省&& Begin VB.ListBox List1 &&&&& Height&&&&&&&&& =&& 3300&&&&& Left&&&&&&&&&&& =&& 120&&&&& TabIndex&&&&&&& =&& 2&&&&& Top&&&&&&&&&&&& =&& 120&&&&& Width&&&&&&&&&& =&& 4215&& End&& Begin VB.CommandButton Command2 &&&&& Caption&&&&&&&& =&& "退出"&&&&& Height&&&&&&&&& =&& 375&&&&& Left&&&&&&&&&&& =&& 4560&&&&& TabIndex&&&&&&& =&& 1&&&&& Top&&&&&&&&&&&& =&& 1080&&&&& Width&&&&&&&&&& =&& 1335&& End&& Begin VB.CommandButton Command1 &&&&& Caption&&&&&&&& =&& "设置显示模式"&&&&& Height&&&&&&&&& =&& 375&&&&& Left&&&&&&&&&&& =&& 4560&&&&& TabIndex&&&&&&& =&& 0&&&&& Top&&&&&&&&&&&& =&& 360&&&&& Width&&&&&&&&&& =&& 1335&& EndEndAttribute VB_Name = "Form1"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = FalseOption ExplicitPrivate Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" _&&&&&&& (lpDevMode As Any, ByVal dwflags As Long) As LongPrivate Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" _&&&&&&& (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As Any) As LongPrivate Declare Function SendMessageByLong& Lib "user32" Alias "SendMessageA" _&&&&&&& (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)Private Declare Function InvalidateRect Lib "user32" _&&&&&&& (ByVal hwnd As Long, lprect As Any, ByVal bErase As Long) 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 Type RECT&&& Left As Long&&& Top As Long&&& Right As Long&&& Bottom As LongEnd Type'& 设备模式结构Private Type DEVMODE&&& dmDeviceName As String * 32&&& dmSpecVersion As Integer&&& dmDriverVersion As Integer&&& dmSize As Integer&&& dmDriverExtra As Integer&&& dmFields As Long&&& dmOrientation As Integer&&& dmPaperSize As Integer&&& dmPaperLength As Integer&&& dmPaperWidth As Integer&&& dmScale As Integer&&& dmCopies As Integer&&& dmDefaultSource As Integer&&& dmPrintQuality As Integer&&& dmColor As Integer&&& dmDuplex As Integer&&& dmYResolution As Integer&&& dmTTOption As Integer&&& dmCollate As Integer&&& dmFormName(1 To 32) As Byte&&& dmLogPixels As Integer&&& dmBitsPerPel As Long&&& dmPelsWidth As Long&&& dmPelsHeight As Long&&& dmDisplayFlags As Long&&& dmDisplayFrequency As Long&&& dmICMMethod As Long&&&&&&&&& ' Windows 95 only&&& dmICMIntent As Long&&&&&&&&& ' Windows 95 only&&& dmMediaType As Long&&&&&&&&& ' Windows 95 only&&& dmDitherType As Long&&&&&&&& ' Windows 95 only&&& dmReserved1 As Long&&&&&&&&& ' Windows 95 only&&& dmReserved2 As Long&&&&&&&&& ' Windows 95 onlyEnd TypeConst DM_BITSPERPEL = &H40000Const DM_PELSWIDTH = &H80000Const DM_PELSHEIGHT = &H100000Const DM_DISPLAYFLAGS = &H200000Const DM_DISPLAYFREQUENCY = &H400000Const DISP_CHANGE_SUCCESSFUL = 0Const DISP_CHANGE_RESTART = 1Const DISP_CHANGE_FAILED = -1Const DISP_CHANGE_BADMODE = -2Const DISP_CHANGE_NOTUPDATED = -3Const DISP_CHANGE_BADFLAGS = -4Const DISP_CHANGE_BADPARAM = -5Const CDS_UPDATEREGISTRY = 1Const CDS_FORCE As Long = &HConst CDS_RESET = &HConst HWND_BROADCAST = &HFFFF&Const WM_SYSCOLORCHANGE = &H15Const WM_PALETTECHANGED = &H311Const WM_DISPLAYCHANGE = &H7EConst WM_SETTINGCHANGE = &H1ADim ModeCube(128) As DEVMODEDim lproc As Long'& 列出显示设备支持的显示模式Sub LoadDisplayMode()&&& Dim i As Long&&& Dim RS As Long&&& Dim AStr As String& &&& i = 0&&& ' 遍历所有的显示模式并在List1中显示出来&&& Do&&&&&&& ModeCube(i).dmFields = DM_BITSPERPEL Or DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_DISPLAYFLAGS Or DM_DISPLAYFREQUENCY&&&&&&& ModeCube(i).dmSize = Len(ModeCube(i))&&&&&&& '获得显示模式并保存到数组中&&&&&&& RS = EnumDisplaySettings(vbNullString, i, ModeCube(i))&&&&&&& If RS Then&&&&&&&&&&& AStr = Str$(ModeCube(i).dmPelsWidth) + "*" + Trim$(Str$(ModeCube(i).dmPelsHeight)) + " "&&&&&&&&&&& Select Case ModeCube(i).dmBitsPerPel&&&&&&&&&&&&&&& Case 4&&&&&&&&&&&&&&&&&&& AStr = AStr + "16色"&&&&&&&&&&&&&&& Case 8&&&&&&&&&&&&&&&&&&& AStr = AStr + "256色"&&&&&&&&&&&&&&& Case 16&&&&&&&&&&&&&&&&&&& AStr = AStr + "16位彩色"&&&&&&&&&&&&&&& Case 24&&&&&&&&&&&&&&&&&&& AStr = AStr + "24位彩色"&&&&&&&&&&&&&&& Case 32&&&&&&&&&&&&&&&&&&& AStr = AStr + "32位彩色"&&&&&&&&&&&&&&& Case Else&&&&&&&&&&&&&&&&&&& AStr = AStr + Str$(ModeCube(i).dmBitsPerPel)&&&&&&&&&&& End Select&&&&&&&&&&& AStr = AStr + "& 刷新频率:" & CStr(ModeCube(i).dmDisplayFrequency) + "Hz"&&&&&&&&&&& i = i + 1&&&&&&& End If&&&&&&& List1.AddItem AStr&&& Loop Until (RS = 0)&&&& '获得最后一个显示模式之后EnumDisplaySettings会返回0End Sub'& 设置显示模式Private Sub Command1_Click()&&& Dim aDev As DEVMODE&&& Dim RS As Long&&&&&&& &&& If List1.ListIndex & 0 Then Exit Sub&&& aDev = ModeCube(List1.ListIndex)&&& &&& RS = ChangeDisplaySettings(aDev, CDS_FORCE)&&&& '& 改变完显示模式设置之后向所有的窗口发送显示模式改变消息&&& RS = SendMessageByLong(HWND_BROADCAST, WM_SYSCOLORCHANGE, 0&, 0&)&&& RS = SendMessageByLong(HWND_BROADCAST, WM_PALETTECHANGED, Me.hwnd, 0&)&&& RS = PostMessage(HWND_BROADCAST, WM_SYSCOLORCHANGE, 0&, 0&)&&& &&& '& windows就会重画窗口&&& RS = InvalidateRect(0&, ByVal 0, 1&)End Sub'& 加载窗体时加载显示系统支持的显示模式Private Sub Form_Load()&&& LoadDisplayModeEnd Sub------------------------------------------使ComboBox自动下拉Option Explicit'使ComboBox自动下拉Const CB_SHOWDROPDOWN = &H14FPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" _&&&&&&& (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Sub Combo1_Click()&&& Text1.Text = Combo1.TextEnd SubPrivate Sub Combo1_GotFocus()&&& '获得焦点自动拉开&&& SendMessage Combo1.hWnd, CB_SHOWDROPDOWN, 1, ByVal 0&End SubPrivate Sub Form_Load()&&& Dim i As Integer&&& For i = 0 To 10&&&&&&& Combo1.AddItem "项目" & i&&& NextEnd Sub-------------------------------------------------------动态添加控件Option ExplicitPrivate WithEvents NewButton As CommandButtonPrivate Sub Command1_Click()&&& If NewButton Is Nothing Then&&&&&&& Set NewButton = Controls.Add("VB.CommandButton", "cmdNew", Me)&&&&&&& NewButton.Move Command1.Left + Command1.Width + 240, Command1.Top&&&&&&& NewButton.Caption = "新按钮"&&&&&&& NewButton.Visible = True&&& End IfEnd SubPrivate Sub NewButton_Click()&&& MsgBox "你单击了" & NewButton.CaptionEnd Sub-----------------------------------------------------'取得控件绝对Top值(left值也类似)&&&&&&&&&&& Public Function AbsoluteTop(ctlContl As Control) As Single&&& Dim wrkContl As Control&&& Dim wrkTopPos As Single&&& '&&& On Error GoTo AbsoluteTopError&&& ' 初始&&& Set wrkContl = ctlContl&&& wrkTopPos = 0&&& ' 循环&&& Do&&&&&&& If (wrkContl.Container.Name = ctlContl.Parent.Name) Then Exit Do&&&&&&& wrkTopPos = wrkTopPos + wrkContl.Top ' 计算位置&&&&&&& Set wrkContl = wrkContl.Container ' 下个控件&&& Loop&&& &&& AbsoluteTop = wrkTopPos + ctlContl.Parent.Top&&& Exit Function&&& 'AbsoluteTopError:&&& AbsoluteTop = ctlContl.Top + ctlContl.Parent.TopEnd Function&SendMessage函数【Form Code:将下面代码用记事本保存为 Form1.frm(窗体文件),此括弧及括弧内容除外】VERSION 5.00Begin VB.Form Form1 && Caption&&&&&&&& =&& "Form1"&& ClientHeight&&& =&& 5700&& ClientLeft&&&&& =&& 60&& ClientTop&&&&&& =&& 450&& ClientWidth&&&& =&& 6735&& LinkTopic&&&&&& =&& "Form1"&& ScaleHeight&&&& =&& 5700&& ScaleWidth&&&&& =&& 6735&& StartUpPosition =&& 3& '窗口缺省&& Begin VB.TextBox Text2 &&&&& Height&&&&&&&&& =&& 375&&&&& Left&&&&&&&&&&& =&& 1320&&&&& TabIndex&&&&&&& =&& 14&&&&& Top&&&&&&&&&&&& =&& 2880&&&&& Width&&&&&&&&&& =&& 1215&& End&& Begin VB.ListBox List1 &&&&& Height&&&&&&&&& =&& 1860&&&&& Left&&&&&&&&&&& =&& 1320&&&&& TabIndex&&&&&&& =&& 13&&&}