我收藏的一些源代码

- <数据>
 <名称>制作垂直标题栏的窗体下</名称>
 <类别>窗体</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-10 12:36:46</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>垂直</关键字1>
 <关键字2>窗体</关键字2>
 <关键字3>标题栏</关键字3>
 <内容简介 />
 <内容>Form1  Private Sub Form_Load() prevWndProc = GetWindowLong(Me.hwnd, GWL_WNDPROC) SetWindowLong Picture1.hwnd, GWL_WNDPROC, AddressOf WndProc End Sub Private Sub Form_Unload(Cancel As Integer) SetWindowLong Picture1.hwnd, GWL_WNDPROC, prevWndProc End Sub Private Sub Picture1_Paint() Dim font As LOGFONT, hOldFont As Long, hFont As Long Dim w As Integer, h As Integer, r As RECT With Picture1 RtlMoveMemory font.lfFaceName(0), _ ByVal CStr(.font.Name), _ LenB(StrConv(.font.Name, vbFromUnicode)) + 1 font.lfHeight = (.font.Size * -20) / Screen.TwipsPerPixelY font.lfEscapement = 2700 font.lfWeight = IIf(.font.Bold, 700, 400) font.lfItalic = .font.Italic font.lfUnderline = .font.Underline font.lfStrikeOut = .font.Strikethrough font.lfCharSet = DEFAULT_CHARSET hFont = CreateFontIndirect(font) hOldFont = SelectObject(.hDC, hFont) r.Left = 0: r.Top = 0 DrawText Me.hDC, .Tag, LenB(StrConv(.Tag, vbFromUnicode)), r, DT_CALCRECT w = r.Right h = r.Bottom .Cls .CurrentX = .ScaleWidth - h / 2 .CurrentY = cmdClose.Height + 15 Picture1.Print .Tag SelectObject .hDC, hOldFont DeleteObject hFont End With End Sub</内容>
 </数据>
- <数据>
 <名称>用API函数控制光驱的开关</名称>
 <类别>VBAPI</类别>
 <数据来源>yesky</数据来源>
 <来源时间>2001-11-24 22:09:12</来源时间>
 <保存时间>2002-01-05 22:14:01</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>API</关键字1>
 <关键字2>光驱</关键字2>
 <关键字3>开关</关键字3>
 <内容简介>NULL</内容简介>
 <内容>使用API函数CDdoor 来控制光驱门的开和关程序十分简单，由于 CDdoor 函数自身包含了对异常错误的处理机制，因此这个程序的通用性很高，你可以把这段代码移植到你的程序中，实现某些多媒体播放器所常用的开关光驱的功能。  以下是源代码： 　　------------------------------------------- 　　 利用API函数控制光驱的开和关 　　------------------------------------------- 　　程序说明： 　　 本例使用API函数 CDdoor 来控制光驱门的开和关 　　程序十分简单，由于 CDdoor 函数自身包含了对异常 　　错误的处理机制，因此这个程序的通用性很高，你可 　　以把这段代码移植到你的程序中，实现某些多媒体播 　　放器所常用的开关光驱的功能。 　　------------------------------------------- Option Explicit 　　说明：CDdoor函数是安装WINDOWS时所自带的winmm.dll文件中包含的函数 Private Declare Function CDdoor Lib "winmm.dll" Alias "mciSendStringA" _ ( _ ByVal lpstrCommand As String, _ ByVal lpstrReturnString As String, _ ByVal uReturnLength As Long, _ ByVal hwndCallback As Long _ ) As Long  　　CDOpen用来标示光驱开与关的状态 Dim CDOpen As Boolean Private Sub Command1_Click() On Error Resume Next   　　如果关闭则打开，并且按钮做相应变化 If CDOpen = False Then Call CDdoor("set CDAudio door open", 0, 0, 0) CDOpen = True Command1.Caption = "点击关闭光驱" Else  　　否则关闭 Call CDdoor("set CDAudio door closed", 0, 0, 0) CDOpen = False Command1.Caption = "点击打开光驱" End If End Sub Private Sub Form_Load() CDOpen = False Call CDdoor("set CDAudio door closed", 0, 0, 0) End Sub   　　CDdoor函数是安装WINDOWS时所自带的winmm.dll文件中包含的函数，我们只须先加入如下的声明后就能引用这个API函数： 　　Private Declare Function CDdoor Lib "winmm.dll" Alias "mciSendStringA" _  　　　( _  　　　ByVal lpstrCommand As String, _ 　　　　　　String，这是控制命令参数 　　　ByVal lpstrReturnString As String, _　　　　String，这是返回值 　　　ByVal uReturnLength As Long, _　　　　　　　Long，返回值长度参数 　　　ByVal hwndCallback As Long _ 　　　) As Long 　　引用的语法是：Call CDdoor("set CDAudio door closed", 0, 0, 0)　　用以关闭光驱门 　　　　　　　　　Call CDdoor("set CDAudio door open", 0, 0, 0)　　　用以打开光驱门   　　程序中使用了一个布尔型变量来标示当前光驱门开与关的状态。 　　如果配合检测光驱是否存在的函数一起使用，此程序的通用性会更高。而关于检测驱动器信息的函数请参看 GetDriveType，GetLogicalDrives的用法。</内容>
 </数据>
- <数据>
 <名称>如何映射/中断网络磁盘</名称>
 <类别>网络</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-05 23:13:34</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>映射</关键字1>
 <关键字2>网络磁盘</关键字2>
 <关键字3>中断</关键字3>
 <内容简介 />
 <内容>下面的程序段可以模拟【网上邻居】及【我的电脑】中的【映射 / 中断网络磁盘】，就是出现【映射 / 中断网络磁盘】的问话框，让使用者根据自己电脑的情形，来决定要连接的网络磁盘要映射到自己的那一个磁盘？要中断的又是那一个对应的磁盘？ 　　请在声明区中加入以下声明及模组： Private Declare Function WNetConnectionDialog Lib "mpr.dll" _ (ByVal hwnd As Long, ByVal dwType As Long) As Long Private Declare Function WNetDisconnectDialog Lib "mpr.dll" _ (ByVal hwnd As Long, ByVal dwType As Long) As Long Sub ShowMapDrives(hwnd As Long) 　WNetConnectionDialog hwnd, 1 End Sub Sub ShowUnMapDrives(hwnd As Long) 　WNetDisconnectDialog hwnd, 1 End Sub '程序中使用方式如下： Private Sub Command1_Click() 　'出现 映射网络磁盘 问话框 　ShowMapDrives Me.hwnd  End Sub Private Sub Command2_Click() 　'出现 中断网络磁盘 问话框 　ShowUnMapDrives Me.hwnd  End Sub</内容>
 </数据>
- <数据>
 <名称>制作垂直标题栏的窗体上</名称>
 <类别>窗体</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-10 16:12:52</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>垂直</关键字1>
 <关键字2>窗体</关键字2>
 <关键字3>标题栏</关键字3>
 <内容简介 />
 <内容>源代码如下： Module1 Option Explicit  Public Const GWL_WNDPROC = (-4) Public Const WM_LBUTTONDOWN = &H201 Public Const WM_NCHITTEST = &H84 Public Const WM_NCLBUTTONDOWN = &HA1 Public Const HTCLIENT = 1 Public Const HTCAPTION = 2 Public Const LF_FACESIZE = 32 Public Const DEFAULT_CHARSET = 1 Public Const DT_CALCRECT = &H400 Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName(0 To LF_FACESIZE - 1) As Byte End Type Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Public prevWndProc As Long Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long If Msg = WM_LBUTTONDOWN Then SendMessage Form1.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0& Else WndProc = CallWindowProc(prevWndProc, hwnd, Msg, wParam, lParam) End If End Function</内容>
 </数据>
- <数据>
 <名称>实现隐藏和显示桌面图标</名称>
 <类别>VBAPI</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-05 22:30:34</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>API</关键字1>
 <关键字2>隐藏和显示</关键字2>
 <关键字3>桌面图标</关键字3>
 <内容简介>NULL</内容简介>
 <内容>源代码如下：  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Const SW_HIDE = 0 Private Const SW_RESTORE = 9   隐藏桌面图标 Private Sub Command1_Click() Dim Hwd As Long Dim rtn As Long Hwd = FindWindow("Progman", vbNullString) rtn = ShowWindow(Hwd, SW_HIDE) End Sub  显示桌面图标 Private Sub Command2_Click() Dim Hwd As Long Dim rtn As Long Hwd = FindWindow("Progman", vbNullString) rtn = ShowWindow(Hwd, SW_RESTORE) End Sub</内容>
 </数据>
- <数据>
 <名称>VB托盘程序详解下</名称>
 <类别>界面</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-05 23:10:32</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>API</关键字1>
 <关键字2>托盘</关键字2>
 <关键字3 />
 <内容简介 />
 <内容>这样我们就取得并处理了来自托盘图标的消息，现在的问题是在鼠标右键菜单弹出后，怎么控制程序主窗体的状态，这时我们需要用到SendMessage函数来向主窗体发送最大化、最小化、关闭、移动等消息，具体的代码实现如下，其中HWnd是主窗体的句柄，WM_SYSCOMMAND表示发送的是系统控制类的消息，SC_MOVE、SC_SIZE、SC_RESTORE便是要发送的消息了： 　　　'托盘图标右键菜单上的“移动”项被点击时 　　　Private Sub mnuTrayMove_Click()  　　　　　SendMessage HWnd, WM_SYSCOMMAND, SC_MOVE, 0&  　　　End Sub  　　　'托盘图标右键菜单上的“恢复”项被点击时  　　　Private Sub mnuTrayRestore_Click()  　　　　　SendMessage HWnd, WM_SYSCOMMAND, SC_RESTORE, 0&  　　　End Sub  　　　'托盘图标右键菜单上的“退出”项被点击时  　　　Private Sub mnuTraySize_Click()  　　　　　SendMessage HWnd, WM_SYSCOMMAND, SC_SIZE, 0&  　　　End Sub   　　最后要提醒你，在程序退出时一定要把窗口过程的地址恢复为默认值，同时把托盘图标移去哦。</内容>
 </数据>
- <数据>
 <名称>妙用GetSystemMetrics函数</名称>
 <类别>VBAPI</类别>
 <数据来源>yesky</数据来源>
 <来源时间>2001-11-24 22:09:12</来源时间>
 <保存时间>2002-01-05 22:15:17</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>API</关键字1>
 <关键字2>函数</关键字2>
 <关键字3>NULL</关键字3>
 <内容简介>NULL</内容简介>
 <内容>在Windows9x编程过程中，我们经常需要了解当前系统的运行状态。例如，如果Win9x运行于安全模式，那么多媒体等部件可能无法正确运行。程序中有必要对此做相应处理，以提高程序安全性，增强系统的适应能力。VB中没有直接提供此类控制或函数，但是我们可以通过API函数GetSystemMetrics轻松地实现对Win运行模式的判断。 　　GetSystemMetrics函数原型如下：    　　Public Declare Function GetSystemMetrics Lib “user32” (ByVal nIndex As Long) As Long 　　其中nIndex的不同取值可以使该函数实现不同的功能。例如返回Win桌面中各种显示单元的宽度和高度、是否安装了鼠标、是否调换了鼠标左右键的定义等。 　　当nIndex = 67（SM_CLEANBOOT）时，该函数的返回值表示Windows9x的当前运行模式。 　　在以下的示例中我们可以看到GetSystemMetrics函数的用法和作用。首先在BAS模块文件中做如下说明： 　　Option Explicit 　　Public Const SM_CLEANBOOT = 67 　　Public Declare Function GetSystemMetrics Lib “user32” (ByVal nIndex As Long) As Long  　　在窗体中添加标签Label1和命令按钮Command1，设置如下代码： 　　Private Sub Command1_Click() 　　 Select Case GetSystemMetrics(SM_CLEANBOOT)  　　 Case 0:Label1=“系统运行于正常模式” 　　 Case 1:Label1=“系统运行于安全模式” 　　 Case 2:Label1=“系统运行于网络环境下的安全模式” 　　 End Select 　　End Sub</内容>
 </数据>
- <数据>
 <名称>利用API和注册表获取系统信息上</名称>
 <类别>DelphiAPI</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 12:01:30</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>API</关键字1>
 <关键字2>注册表</关键字2>
 <关键字3>系统信息</关键字3>
 <内容简介 />
 <内容>在开发应用程序时，增加一项显示计算机系统信息的功能，例如已安装的软盘、硬盘、光驱、网络驱动器，硬盘的容量和剩余空间，显示器分辨率、键盘类型、鼠标的键数，内存大小、CPU类型，Windows的版本号、产品标识、注册用户单位名和用户名、当前操作用户名等(见运行图示)，当然还有更多的信息，这样会使你的程序更友好。其实，有很多应用程序就是这样做的。 　　通过调用Windows的API函数和访问Windows注册表，可以获取大量的系统信息。Delphi为绝大多数WindowsAPI函数提供了调用接口(可参见DELPHI3\SOURCE\RTL\WIN\windows.pas文件)，并提供了一个功能全面的TRegistry类，使我们可以方便的调用WindowsAPI函数和访问注册表，例如： 　　1、function GetDriveType(lpRootPathName: PChar): UINT;返回指定驱动器的类型。 　　2、function GetDiskFreeSpace(lpRootPathName: PChar; var lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL;返回指定驱动器的总簇数、剩余簇数及每簇扇区数、每扇区字节数，从而可以计算出总容量和剩余空间。 　　3、function GetSystemMetrics(SM_CXSCREEN或 SM_CYSCREEN): Integer;返回显示器分辨率。 　　4、function GetSystemMetrics(SM_CMOUSEBUTTONS): Integer;返回鼠标的按键数目。 　　5、 在windows 注 册 表 的HKEY_LOCAL_MACHINE\ software\microsoft\windows\currentversion \RegisteredOwner主键下存放着Windows安装时输入的用户名,可用以下语句读取。  myreg:=Tregistry.Create;  file://必须在程序单元的uses部分加入Registry myreg.RootKey:=HKEY_LOCAL_MACHINE; if myreg.openkey('software\microsoft \windows\currentversion',false) then 　memo1.lines.add(' 注册用户名: '+myreg.readstring('RegisteredOwner')); 　myreg.closekey;  　　以上仅举几例，获取其他一些信息的方法与此类似，详见源程序。 　　本程序在Pwin95、Delphi3下调试通过。 　　附:源程序清单。 unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,Registry; type TForm1 = class(TForm) Button1: TButton; Memo1: TMemo; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM}</内容>
 </数据>
- <数据>
 <名称>利用API和注册表获取系统信息中</名称>
 <类别>DelphiAPI</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 12:01:39</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>API</关键字1>
 <关键字2>注册表</关键字2>
 <关键字3>系统信息</关键字3>
 <内容简介 />
 <内容>procedure TForm1.Button1Click(Sender: TObject); var  i,x,y:integer; ch:char; file://驱动器字符'A'~'Z' buffer:string; cpuinfo:TSYSTEMINFO; file://存放系统信息的记录类型,在Windows.pas中查到详细内容。 meminfo:TMemoryStatus; file://存放系统内存信息的记录类型。 computername,username:pchar; file://计算机名称、用户名 spc,bps,nofc,tnoc:longint; file://用于存放磁盘容量的变量 myreg:Tregistry; file://用于访问注册表的TRegistry变量 begin memo1.Lines.Clear; for ch:='A' to 'Z' do begin i:=getdrivetype(pchar(ch+':\')); buffer:=' '+ch+': '; case i of DRIVE_UNKNOWN : buffer:=buffer+'未知类型'; DRIVE_REMOVABLE: buffer:=buffer+'软盘'; DRIVE_FIXED : begin buffer:=buffer+'硬盘'; if getdiskfreespace(pchar(ch+':\'),spc,bps,nofc,tnoc) then  begin buffer:=buffer+'总容量: '+inttostr((spc*bps*tnoc) div (1024*1024))+'MB'; buffer:=buffer+'剩余: '+inttostr((spc*bps*nofc) div (1024*1024))+'MB'; end; end; DRIVE_REMOTE : buffer:=buffer+'网络驱动器'; DRIVE_CDROM :buffer:=buffer+'CD-ROM驱动器'; DRIVE_RAMDISK:buffer:=buffer+'RAM虚拟驱动器'; end; if (ch >'D') and (i=1) then break; if i< >1 then memo1.Lines.Add(buffer); end; case getkeyboardtype(0) of file://获取键盘类型 1: buffer:=' 键盘: IBM PC/XT或兼容类型(83键)'; 2: buffer:=' 键盘: Olivetti "ICO"(102键)'; 3: buffer:=' 键盘: IBM PC/AT(84键)'; 4: buffer:=' 键盘: IBM增强型(101或102键)'; 5: buffer:=' 键盘: Nokia 1050'; 6: buffer:=' 键盘: Nokia 9140'; 7: buffer:=' 键盘: Japanese'; end; memo1.lines.add(buffer); file://获取键盘功能键数目 memo1.lines.add(' 功能键数目: '+inttostr(getkeyboardtype(2))); memo1.Lines.add('显示器分辨率: '+inttostr(getsystemmetrics(SM_CXSCREEN)) +'x'+ inttostr(getsystemmetrics(SM_CYSCREEN))); file://获取鼠标按键数目 memo1.Lines.add(' 鼠标: '+inttostr(getsystemmetrics(SM_CMOUSEBUTTONS))+'键'); globalmemorystatus(meminfo); file://获取系统内存数量 memo1.lines.add(' 物理内存: '+inttostr(meminfo.dwTotalPhys div 1024)+' KB'); i:=getsystemmetrics(SM_CLEANBOOT); case i of 0:buffer:='系统启动模式:正常模式'; 1:buffer:='系统启动模式:保护模式'; 2:buffer:='系统启动模式:网络保护模式'; end; memo1.lines.add(buffer); </内容>
 </数据>
- <数据>
 <名称>利用API和注册表获取系统信息下</名称>
 <类别>DelphiAPI</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 12:01:46</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>API</关键字1>
 <关键字2>注册表</关键字2>
 <关键字3>系统信息</关键字3>
 <内容简介 />
 <内容>x:=getsystemmetrics(SM_ARRANGE);  file://获取系统最小化窗口的起始位置和排列方式 y:=x; x:=x and 3; y:=y and 12; case x of ARW_BOTTOMLEFT : buffer:=' 最小化窗口:自左下角'; ARW_BOTTOMRIGHT : buffer:=' 最小化窗口:自右下角'; ARW_TOPLEFT : buffer:=' 最小化窗口:自左上角'; ARW_TOPRIGHT : buffer:=' 最小化窗口:自右上角'; end; case y of ARW_LEFT : buffer:=buffer+'横向排列'; ARW_UP : buffer:=buffer+'纵向排列'; ARW_HIDE : buffer:=buffer+'隐藏'; end; memo1.lines.add(buffer); getmem(computername,255); file://获取计算机名称和用户名 getmem(username,255); i:=255; getcomputername(computername,i); memo1.lines.add(' 计算机名称: '+computername); getusername(username,i); memo1.lines.add(' 用户名: '+username); freemem(computername); freemem(username); getsysteminfo(cpuinfo); file://获取CPU类型 case cpuinfo.dwProcessorType of 386 : buffer:=' CPU类型: 386'; 486 : buffer:=' CPU类型: 486'; 586 : buffer:=' CPU类型: Pentium'; end; memo1.Lines.add(buffer); file://从注册表中获取CPU标识，Windows版本， 产品标识，注册单位名称及用户名 myreg:=Tregistry.Create; myreg.RootKey:=HKEY_LOCAL_MACHINE; if myreg.OpenKey('hardware\descriptionsystem\centralprocessor\0',false) then memo1.lines.add(' CPU标识: '+myreg.ReadString('VendorIdentifier')); myreg.closekey; if myreg.openkey('software\microsoft\ windows\currentversion',false) then  begin memo1.lines.add(' windows版本: '+myreg.ReadString('Version')); memo1.lines.add(' 版本号: '+myreg.ReadString('VersionNumber')+' '+myreg.ReadString('Subversionnumber')); memo1.lines.add(' 产品标识: '+myreg.Readstring('ProductID')); memo1.lines.add('注册单位名称: '+myreg.readstring('RegisteredOrganization')); memo1.lines.add(' 注册用户名: '+myreg.readstring('RegisteredOwner')); end; myreg.CloseKey; myreg.Free; end; end</内容>
 </数据>
- <数据>
 <名称>百叶窗图形特效</名称>
 <类别>动画</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-05 23:09:56</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>API</关键字1>
 <关键字2>图形特效</关键字2>
 <关键字3>百叶窗</关键字3>
 <内容简介 />
 <内容>在Powerpoint这样的软件中，各种各样的图形特效层出不穷，其中“百叶窗”的切换效果尤为新颖奇特。在VB中实现这样的图形特效十分简单方便。其方法是调用WINDOWS的API函数Bitblt。BitBlt函数就类似于C语言中的getimage、putimage两个函数的组合运用。BitBlt原意是“Bit Block Transfer”，其主要用途是位图的复制。用BitBlt函数显示图形特效，其原理十分简单，制作时先在表单中绘制两个图片框，将图片存入一个图片框，同时将另一个图片框设为空，然后调用BitBlt函数将第一个图片框中的图形一部分一部分地复制到第二个图片框中，这样就可以实现千奇百怪的图形特效。其步骤如下： 　　在VB环境中新建一个窗体，绘制两个图片框picSour和picDest，两个命令按钮cmdShow和cmdExit。首先在窗体的通用过程中声明BitBlt函数即所需要的常量名，在载入窗体同时在picSour中载入图片，在按钮cmdShow的事件中调用BitBlt函数。程序如下： API函数声明： Declare Function BitBlt Lib″GDI″(ByVal hDestDC As Integer,ByVal X As Integer,ByVal Y As Integer,ByVal nWidth AS Integer,ByVal nHeight As Integer,ByVal hSrcDC As Integer,ByVal xSrc As Integer,ByVal ySrc As Integer,ByVal dwRop As Long)As Integer  　　Const COPY－PUT=＆HCC0020′BitBlt的15种算法之一，表示直接拷贝 　　载入图片： Sub Form－Load() picsour.Picture=LoadPicture(″c:\windows\LEAVES.bmp″) picsour.ScaleMode=3′以象素为单位 End Sub  显示“百叶窗”的切换效果： Sub Comshow－Click() H％=picsour.ScaleHeight W％=picsour.ScaleWidth scanlines=4 For i=0 To(scanlines－1) For j=i To H％ Step scanlines s％=BitBlt％(picdest.hDC,0,j,W％,1,picsour.hDC,0,j,copy－Put) delay 500′延时 Next j Next i End Sub  　　其中delay是一个通用子过程，用于延时，以便于能看清楚切换效果。代码如下：  Sub delay(delaytime As Integer) For i=1 To delaytime Next i End Sub  　　通过这样简单的程序就可以实现“百叶窗”的切换特效，其实，只要有合适的算法，运用BitBlt函数能够实现的图形特效是无穷的。有兴趣的读者可以查阅有关VB的参考书。</内容>
 </数据>
- <数据>
 <名称>实现平面工具栏下</名称>
 <类别>控件特效</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 18:13:17</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>API</关键字1>
 <关键字2>工具栏</关键字2>
 <关键字3>平面</关键字3>
 <内容简介 />
 <内容>【参数表】 hWnd1 ---------- Long，在其中查找子的父窗口。如设为零，表示使用桌面窗口（通常说的顶级窗口都被认为是桌面的子窗口，所以也会对它们进行查找）  hWnd2 ---------- Long，从这个窗口后开始查找。这样便可利用对FindWindowEx的多次调用找到符合条件的所有子窗口。如设为零，表示从第一个子窗口开始搜索  lpsz1 ---------- String，欲搜索的类名。零表示忽略  lpsz2 ---------- String，欲搜索的类名。零表示忽略  Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _ (ByVal hWnd1 As Long, _ ByVal hWnd2 As Long, _ ByVal lpsz1 As String, _ ByVal lpsz2 As String) As Long  【VB声明】  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   【说明】 调用一个窗口的窗口函数，将一条消息发给那个窗口。除非消息处理完毕，否则该函数不会返回。SendMessageBynum， SendMessageByString是该函数的“类型安全”声明形式  【返回值】 Long，由具体的消息决定  【参数表】 hwnd ----------- Long，要接收消息的那个窗口的句柄  wMsg ----------- Long，消息的标识符  wParam --------- Long，具体取决于消息  lParam --------- Any，具体取决于消息  Private Declare Function SendMessage Lib "user32" Alias _ "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _ ByVal wParam As Integer, ByVal lParam As Any) As Long  设置工具栏为新的样式  Private Sub SetToolbar(tBar As Toolbar) Dim lngResult As Long Dim lngHWND As Long Dim lngStyle As Long   得到Toolbar的句柄  lngHWND = FindWindowEx(tBar.hwnd, 0&, "ToolbarWindow32", vbNullString)  得到原有的Toolbar的样式 lngStyle = SendMessage(lngHWND, TB_GETSTYLE, 0&, 0&)   设置一个图形在上、文字在下的平面工具栏  lngStyle = lngStyle Or TBSTYLE_FLAT   用API函数实现工具栏的新样式  lngResult = SendMessage(lngHWND, TB_SETSTYLE, 0, lngStyle)   刷新工具栏  tBar.Refresh End Sub  Private Sub exitfile_Click() Unload Me End Sub  Private Sub Form_Load()   调用函数改变工具栏  Call SetToolbar(Me.Toolbar1)  End Sub</内容>
 </数据>

解决方案 »

免费领取超大流量手机卡，每月29元包185G流量+100分钟通话, 中国电信官方发货

总共是6xx kb可惜没有办法写了
我帮你U P 一下，你就可以接着发了，要不发到我信箱里[email protected]
好像是用记事本打开了一个PowerPoint文件吧！
继续贴：<数据>
 <名称>模拟Windows的资源回收站</名称>
 <类别>系统</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 17:17:23</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>回收站</关键字1>
 <关键字2>Win系统</关键字2>
 <关键字3>模拟</关键字3>
 <内容简介>NULL</内容简介>
 <内容>您现在将屏幕上所有的视窗全部缩小，找到资源回收站，按鼠标右键，选择【属性】，便会出现【资源回收站】的属性问话框。 其中有几个选项如下： 1、不要将文件移到资源回收站，删除时立即移除文件。 2、显示删除确认对话框？ 根据以上之状况，文件之删除有三种情形： 1、删除文件，出现确认对话框，文件移到资源回收站。 2、删除文件，出现确认对话框，文件不移到资源回收站。 3、删除文件，不出现确认对话框，文件也不移到资源回收站。 模拟程序如下： ′在模组的声明区中加入以下声明： Public Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Long hNameMappings As Long lpszProgressTitle As Long End Type Public Declare Function SHFileOperation Lib "shell32.dll" Alias _ "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long Public Const FO_DELETE = &H3 Public Const FOF_ALLOWUNDO = &H40 ′可以还原 Public Const FOF_NOCONFIRMATION = &H10 ′不出现确认对话框 Public Const FOF_SILENT = &H4 ′在程序中之使用方法如下：  ′以下之例子会出现确认对话框，文件也会移到资源回收站。 Private Sub Command1_Click() Dim SHop As SHFILEOPSTRUCT Dim strFile As String ′要删除的文件(含全路径) strFile = "c:\test.txt" With SHop .wFunc = FO_DELETE .pFrom = strFile .fFlags = FOF_ALLOWUNDO End With SHFileOperation SHop End Sub ′若要调整，只要更改 fFlags 之值即可，如下： .fFlags = FOF_SILENT ′删除文件，出现确认对话框，文件不移到资源回收站。 .fFlags = FOF_NOCONFIRMATION ′删除文件，不出现确认对话框，文件也不移到资源回收站。</内容>
 </数据>
- <数据>
 <名称>四角形以外其他形状的Form</名称>
 <类别>界面</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 17:18:39</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>Form</关键字1>
 <关键字2>形状</关键字2>
 <关键字3>四角形</关键字3>
 <内容简介>NULL</内容简介>
 <内容>这个问题，您一定无法想像有多容易，您可以产生任何形状的 Form，但必须借助 CreateEllipticRgn 及 SetWindowRgn 二个 API ，例如：  Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As _ Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd _ As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Private Sub Form_Load() Dim lReturn As Long Me.Show lReturn = SetWindowRgn(hWnd, CreateEllipticRgn(10, 10, 340, 150), True) End Sub 执行结果图片 CreateEllipticRgn 之四个参数说明如下： X1：椭圆中心点之X轴位置，但以 Form 的实№边界为限。 Y1：椭圆中心点之Y轴位置，但以 Form 的实№边界为限。 X2：椭圆长边的长度 Y2：椭圆短边的长度的 25、如何让一个 Form 出现在另一个非 MDIForm 的 Form 中？ 假设要将 Form2 放在 Form1 中，请在宣告区中宣告：  Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, _ ByVal hWndNewParent As Long) As Long 在 Form2 中的 Form_Load 中加入 SetParent(Me.hWnd, Form1.hWnd) 即可。 但有一点要注意的是，在 Unload Form1 之前一定要先 Unload Form2</内容>
 </数据>
- <数据>
 <名称>移除Form右上方之X按钮</名称>
 <类别>界面</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 17:20:25</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>Form</关键字1>
 <关键字2>按钮</关键字2>
 <关键字3>关闭</关键字3>
 <内容简介>NULL</内容简介>
 <内容>其实 Form 右上方之三个按钮分别对应到 Form 左上方控制盒 (ControlBox) 中的几个选项 (缩到最小 / 放到最大 / 关闭)，而其中的最大化 (MaxButton) 及最小化 (Minbutton) 都可以直接在 Form 的属性中设定，但是 VB 并没有提供设定『X』按钮的功能！要达到这个功能，必须借助 API：  由于『X』按钮对应到 ControlBox 的关闭选项，所以我们只要移除系统 Menu (就是ControlBox) 的关闭选项即可！您自己可以先看看您现在使用的 Browser 左上方的系统 Menu，【关闭】选项是在第几个，不是第 6 个！是第 7 个，分隔线也算一个！分隔线才是第 6 个！ 当我们移除了关闭选项之後，会留下一条很奇怪的分隔线，所以最好连分隔线也一并移除。而 Menu 的 Index 是从 0 开始，分隔线是第 6 个，所以 Index = 5。 修正：为了让程序码在 Windows NT 也能运作正常，将各 Integer 型态改成 Long。 89.05.04 ′抓取系统 Menu 的 hwnd Private Declare Function GetSystemMenu Lib "user32" _ Alias "GetSystemMenu" (ByVal hwnd As Long, _ ByVal bRevert As Long) As Long ′移除系统 Menu 的 API Private Declare Function RemoveMenu Lib "user32" _ Alias "RemoveMenu" (ByVal hMenu As Long, _ ByVal nPosition As Long, ByVal wFlags As Long) As Long ′第一个参数是系统 Menu 的 hwnd ′第二个参数是要移除选项的 Index</内容>
 </数据>
- <数据>
 <名称>如何加长加宽ComboBox的下拉选单</名称>
 <类别>界面</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 17:24:22</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>选单</关键字1>
 <关键字2>下拉</关键字2>
 <关键字3>加长</关键字3>
 <内容简介 />
 <内容>Combo 预设的下拉长度只有 5,6 个选项，当选项很多时，要卷老半天才能找到资料，很不方便！要加长 ComboBox 的下拉选单，方法如下：  在声明区中放入以下声明及 Subroutine 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 Long Public Sub SetComboHeight(oComboBox As ComboBox, lNewHeight As Long) Dim oldscalemode As Integer  ′ This procedure does not work with frames: you ′ cannot set the ScaleMode to vbPixels, because ′ the frame does not have a ScaleMode Property. ′ To get round this, you could set the parent control ′ to be the form while you run this procedure. If TypeOf oComboBox.Parent Is Frame Then Exit Sub ′ Change the ScaleMode on the parent to Pixels. oldscalemode = oComboBox.Parent.ScaleMode oComboBox.Parent.ScaleMode = vbPixels ′ Resize the combo box window. MoveWindow oComboBox.hwnd, oComboBox.Left, _ oComboBox.Top, oComboBox.Width, lNewHeight, 1 ′ Replace the old ScaleMode oComboBox.Parent.ScaleMode = oldscalemode End Sub 在任何时候 (不一定是 Form_Load 或 Combo_DropDown)，想要加长 ComboBox 的下拉选单时，只要加入以下程序即可： Call SetComboHeight(Combo1, 270) ′设定的单位是 Pixels 如何加宽 ComboBox 的下拉选单？ 和 ListBox 一样， ComboBox 也会有宽度不够的情形， Combo 下拉之后资料看不完整，当 Form 上的物件不多时，还可以拉长一点，但有时候也没办法！这时候，还是得靠 API 了！  在声明区中放入以下声明及 Subroutine Private Declare Function SendMessage Lib "user32" _ Alias "SendMessageA" (ByVal hwnd As Long, _ ByVal wMsg As Long, ByVal wParam As Long, _ lParam As Long) As Long Const CB_SETDROPPEDWIDTH = &H160 Public Sub SetComboWidth(oComboBox As ComboBox, lWidth As Long) ′ lWidth 是宽度，单位是 pixels SendMessage oComboBox.hwnd, CB_SETDROPPEDWIDTH, lWidth, 0 End Sub 在任何时候 (不一定是 Form_Load 或 Combo_DropDown)，想要加宽 ComboBox 的下拉选单时，只要加入以下程序即可 (若设定的宽度小于 Combo 原来的宽度则无效)： Call SetComboWidth(Combo1, 270) ′设定的单位是 Pixels</内容>
 </数据>
- <数据>
 <名称>获得某一台网络打印机有几份等待打印的报表</名称>
 <类别>打印</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 17:29:39</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>打印机</关键字1>
 <关键字2>网络</关键字2>
 <关键字3>报表</关键字3>
 <内容简介>NULL</内容简介>
 <内容>当我们要打印报表时，如果打印机是本机的打印机的话，当然马上就会将报表打印出来，反正打印机就只有您一个人在使用而已！但是如果是在一个人数很多的公司或企业时，往往就必须很多人来分享某一部打印机了，而且打印机也不一定就放在举目可及之处！ 当您将报表丢到网络打印机之后，由于不一定看得到打印机，您必须特别到摆放打印机的地方去拿报表，这时候您最关心的，就是报表印了没有，如果还没有的话，那还有几份还没打印的报表排在您的报表之前呢？ 下面这一段程序，可以让您知道某一台网络打印机尚有几份等待打印的报表？在您的程序丢出报表的同时，您可以告诉您的 User，他的报表排在第几份！ ′在 .bas 文件中加入以下声明及模组： ′Constants Definition Public Const CCHDEVICENAME = 32 Public Const CCHFORMNAME = 32 Public Const PRINTER_ACCESS_ADMINISTER = &H4 Public Const PRINTER_ACCESS_USE = &H8 ′Types Definition Public Type DEVMODE dmDeviceName As String * CCHDEVICENAME 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 As String * CCHFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Long dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End Type Public Type PRINTER_DEFAULTS pDatatype As String pDevMode As DEVMODE DesiredAccess As Long End Type ′API Declarations Public Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" _ (ByVal pPrinterName As String, phPrinter As Long, _ pDefault As PRINTER_DEFAULTS) As Long Public Declare Function EnumJobs Lib "winspool.drv" Alias "EnumJobsA" _ (ByVal HPrinter As Long, ByVal FirstJob As Long, ByVal NoJobs As Long, _ ByVal Level As Long, pJob As Byte, ByVal cdBuf As Long, _ pcbNeeded As Long, pcReturned As Long) As Long Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long  ′取得指定的打印机，目前有多少 Jobs (最大值为 128) ′打印机的名称可以是 mapping 的网络路径名称，例如： "\\myserver\myprinter" Function GetPrinterQueue(PrinterName As String) As Long Dim PrinterStruct As PRINTER_DEFAULTS Dim HPrinter As Long Dim ret As Boolean Dim JobStruct(0 To 127) As Byte Dim pcbNeeded As Long Dim pcReturned As Long Dim TempByte As Byte ′设定 Printer structure 初值 PrinterStruct.pDatatype = vbNullString PrinterStruct.pDevMode.dmSize = Len(PrinterStruct.pDevMode) PrinterStruct.DesiredAccess = PRINTER_ACCESS_USE ′取得打印机的 Handle ret = OpenPrinter(PrinterName, HPrinter, PrinterStruct) ′取得打印机的 active jobs ret = EnumJobs(HPrinter, 0, 127, 1, TempByte, 0, pcbNeeded, pcReturned) If pcbNeeded = 0 Then GetPrinterQueue = 0 Else ret = EnumJobs(HPrinter, 0, 127, 1, JobStruct(0), pcbNeeded, pcbNeeded, pcReturned) GetPrinterQueue = pcReturned End If ′关闭打印机 ret = CloseHandle(HPrinter) End Function  ′在表单中放一个 CommandButton，程序码如下： Private Sub Command1_Click() ′测试预设打印机的 Queue (Printer.DeviceName) Msgbox "打印机中尚有 " & GetPrinterQueue(Printer.DeviceName) & " 份报表", 64, "讯息" End Sub</内容>
 </数据>
- <数据>
 <名称>ZOrder的使用</名称>
 <类别>界面</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 17:32:33</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>ZOrder</关键字1>
 <关键字2>坐标</关键字2>
 <关键字3>使用</关键字3>
 <内容简介>NULL</内容简介>
 <内容>ZOrder 拆开以后就是 Z 及 Order，其意义说明如下： Z：这里是指三度空间中的 Z 座标轴 (注一)，而不是指英文字母的第 26 个字母。 Order：排列顺序。 所以 ZOrder 就是指在 Z 座标轴上的排列顺序！ ZOrder 语法如下： object.ZOrder position  --------------------------------------------------------------------------- object 选择性引数。物件运算式，用来指定「适用于」清单中的物件。 如果省略 object，则假设具有驻点的 Form 物件为 object。  Position 选择性引数。整数，用以指示 object 相对于同一 object 其它执行个体的位置。 如果 position 为 0 或省略，则 object 放置在 z- 顺序前面 (上方)。 如果 position 为 1，则 object 放置在 z- 顺序后面 (下方)。  --------------------------------------------------------------------------- 在设计阶段选取快显功能表中的「移至顶层」或「移至底层」功能表指令，可以设定物件的 z- 顺序。 ZOrder 用在不同的地方，有二种不同的意义： 1、用于 MDIForm 中的 Child Form 时，指的是每一个 Child Form 的上下位置关系。 2、用于每一个 Form 中的所有控制项时，指的是每一个控制项间的上下位置关系。 (注二) 注一：一般我们的二度平面座标轴是指 X 座标轴 (东西向)及 Y 座标轴 (南北向)， 　　　二个轴构成一个平面，再加上垂直的 Z 座标轴，就构成了三度立体空间了！ 　　　所以 ZOrder 指的就是物件在垂直的 Z 座标轴上的上下位置关系。 注二：虽然 ZOrder 指的是物件在垂直的 Z 座标轴上的上下位置关系。 　　　但是很多人搞不清楚，为什么他已经设定了 ZOrder 了，为什么在某些控制项中是无效的？ 　　　原因是对单一 Form 或 单一 Container 而言，在垂直的 Z 座标轴上又分成三个层次： 　　　最下一层：显示图形方法结果的绘图空间。 　　　中间一层：用来显示图形物件(例如 Image) 和 Label 控制项。 　　　上面一层：显示所有非图形控制项，例如 CommandButton、CheckBox 或 ListBox。 　　　而 ZOrder 只对单一层次内的控制项有效而已！ 　　　例如：您如果设定 Label 及 Image 的 ZOrder 是有效的，因为它们都在中间一层！ 　　　　　　您如果设定 Label 及 CommandButton 的 ZOrder 是无效的，因为它们在不同层！ 　　　最重要的是：不管 ZOrder 如何设定， 　　　　　　　　　在上面一层的物件永远会在中间一层的物件的上方！ 　　　　　　　　　在中间一层的物件永远会在最下一层的物件的上方！ </内容>
 </数据>
- <数据>
 <名称>算出TextBox中目前光标位置</名称>
 <类别>文本处理</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 17:34:53</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>光标</关键字1>
 <关键字2>位置</关键字2>
 <关键字3>TextBox</关键字3>
 <内容简介>NULL</内容简介>
 <内容>在很多文字编辑器中，都可以告诉您，目前您的光标是在文字编辑器的第几行，我们也来实作一下！ 在 Form 中放入一个 TextBox 并将 Multiline 属性设为 True，放入一个 Label 用来显示目前光标所在的行数，在表单声明区中加入以下声明及模组： Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Const EM_LINEFROMCHAR = &HC9 Function LineNo(txthwnd As Long) As Long On Local Error Resume Next LineNo = SendMessageLong(txthwnd, EM_LINEFROMCHAR, -1&, 0&) + 1 LineNo = Format$(lineno, "##,###") End Function ′呼叫这个模组时要导入的是 TextBox 的 hwnd ′实际使用时，必须在 TextBox 的以下几个事件中呼叫这个模组，才会完全正确： ′1. Change事件：输入资料时可侦测计算 ′2. Click 事件：用鼠标移动光标时可侦测计算 ′3. KeyUp 事件：用上下左右键移动光标时可侦测计算 Sub Text1_Change() Label1 = LineNo(Text1.hwnd) End Sub Private Sub Text1_Click() Label1 = LineNo(Text1.hwnd) End Sub Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer) Label1 = LineNo(Text1.hwnd) End Sub</内容>
 </数据>
- <数据>
 <名称>动态新增、移除ODBC DSN</名称>
 <类别>数据库</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 17:37:06</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>动态</关键字1>
 <关键字2>DSN</关键字2>
 <关键字3>新增移除</关键字3>
 <内容简介>NULL</内容简介>
 <内容>一般我们建立 Client 端 DSN 都是在使用者的机器上进入【控制台】【ODBC 资料来源管理员】去建立，但是如果我们开发的 APP 使用者很多时，这就有点累人了，所以我们可以将这个动作放在程序中！ 新增 DSN 的方法有二种： 1、使用 DBEngine 物件的 RegisterDatabase 方法 2、呼叫 SQLConfigDataSource API 不管使用以上任何一种方法新增 DSN，一共会写入二个地方，一个是注册表，一个是 ODBC.INI。 而删除 DSN 的方法同上面的第二种方法，呼叫 SQLConfigDataSource API。 以下之模组以 Oracle73 Ver 2.5 为例，在 Form 的声明区中加入以下声明及模组： Private Const ODBC_ADD_DSN = 1 ′ Add data source Private Const ODBC_CONFIG_DSN = 2 ′ Configure (edit) data source Private Const ODBC_REMOVE_DSN = 3 ′ Remove data source Private Const vbAPINull As Long = 0& ′ NULL Pointer Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" _ (ByVal hwndParent As Long, ByVal fRequest As Long, _ ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long Public Sub CreateDSN(sDSN As String) Dim nRet As Long Dim sDriver As String Dim sAttributes As String sDriver = "Oracle73 Ver 2.5" sAttributes = "Server=Oracle8" & Chr$(0) sAttributes = sAttributes & "DESCRIPTION=" & sDSN & Chr$(0) ′sAttributes = sAttributes & "DSN=" & sDSN & Chr$(0) sAttributes = sAttributes & "DATABASE=DBFinance" & Chr$(0) sAttributes = sAttributes & "Userid=Scott" & Chr$(0) ′sAttributes = sAttributes & "PWD=myPassword" & Chr$(0) DBEngine.RegisterDatabase sDSN, sDriver, True, sAttributes ′注一 ′nRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, sDriver, sAttributes) ′注二 End Sub Public Sub DeleteDSN(sDSN As String) Dim nRet As Long Dim sDriver As String Dim sAttributes As String sDriver = "Oracle73 Ver 2.5" sAttributes = sAttributes & "DSN=" & sDSN & Chr$(0) nRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, sDriver, sAttributes) End Sub ′假设要产生的 DSN 为 Test，实际使用范例如下： Private Sub Command1_Click() CreateDSN "Test" End Sub Private Sub Command2_Click() DeleteDSN "Test" End Sub ′而写到系统的资料如下： 1、ODBC.INI [ODBC 32 bit Data Sources] Test=Oracle73 Ver 2.5 (32 bit) [Test] Driver32=C:\ORAWIN95\ODBC250\sqo32_73.dll 2、注册表 机码：HKEY_CURRENT_USER\Software\ODBC\ODBC.INI\ODBC Data Sources 名称：Test 资料：Oracle73 Ver 2.5 机码：HKEY_CURRENT_USER\Software\ODBC\ODBC.INI\Test 名称：Description 资料：Test 名称：Driver 资料：C:\ORAWIN95\ODBC250\sqo32_73.dll 名称：Server 资料：Oracle8 名称：UserId 资料：Scott ※注一及注二可任选一种，只要将不使用的方法 Mark 起来即可！ ※若您想使用其他之资料库，只要将以上模组稍作修改即可！</内容>
 </数据>
- <数据>
 <名称>取消TextBox鼠标右键的弹出菜单功能</名称>
 <类别>界面</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 17:41:09</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>TextBox</关键字1>
 <关键字2>PopupMenu</关键字2>
 <关键字3>鼠标</关键字3>
 <内容简介>NULL</内容简介>
 <内容>自从 Microsoft Windows 进入 Windows95 之后，有一个很方便的功能，很多软件都有提供，就是鼠标右键的 PopupMenu 功能，它确实很方便，但是有时却是梦魇，那就是您不需要它的时候，它还是会自动出现！本例中的 TextBox 就是明显的例子。 但是这个梦魇从 VB5.0 以后就可以解决了，因为 VB5.0 提供了 AdressOf 这个运算子，可以做回呼(callback)处理！ 请将以下的程序码放在 .bas 模组中，呼叫 Hook 这个 Sub 并传入 TextBox 的 hWnd 当作参数，但是切记您在 Unload Form 之前一定要呼叫 UnHook 这个 Sub，否则会产生一个 General Protection Fault！ Declare Function CallWindowProc Lib "user32" Alias _ "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _ ByVal hWnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Declare Function SetWindowLong Lib "user32" Alias _ "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex _ As Long, ByVal dwNewLong As Long) As Long Public Const GWL_WNDPROC = -4 Public Const WM_RBUTTONUP = &H205 Public lpPrevWndProc As Long Private lngHWnd As Long Public Sub Hook(hWnd As Long) lngHWnd = hWnd lpPrevWndProc = SetWindowLong(lngHWnd, GWL_WNDPROC, _ AddressOf WindowProc) End Sub Public Sub UnHook() Dim lngReturnValue As Long lngReturnValue = SetWindowLong(lngHWnd, GWL_WNDPROC, _ lpPrevWndProc) End Sub Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Select Case uMsg Case WM_RBUTTONUP ′Do nothing ′Or popup you own menuCase Else WindowProc = CallWindowProc(lpPrevWndProc, _ hw, uMsg, wParam, lParam) End Select End Function 在 Form_Load 事件中加入以下程序码： Call Hook(Text1.hWnd) 在 Form_Unload 中加入以下程序码： Call UnHook</内容>
 </数据>
- <数据>
 <名称>让ComboBox自动下拉</名称>
 <类别>控件特效</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 17:43:52</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>ComboBox</关键字1>
 <关键字2>自动</关键字2>
 <关键字3>API</关键字3>
 <内容简介>NULL</内容简介>
 <内容>以下状况假设我在 Form_Load 中自动下拉 Combo1.  ′以下声明用于16位 Const WM_USER = &H400 Const CB_SHOWDROPDOWN = (WM_USER + 15) Private Declare Function SendMessage Lib "User" (ByVal hwnd As Integer, _ ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long  ′以下声明用于32位 Const CB_SHOWDROPDOWN = &H14F 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 Form_Load() Combo1.AddItem "11111" Combo1.AddItem "22222" Combo1.AddItem "33333" Combo1.AddItem "44444" Combo1.AddItem "55555" Combo1.AddItem "66666" ′Form_Load 即自动下拉 Combo1 Dim nret As Long nret = SendMessage(Combo1.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0&) End Sub</内容>
 </数据>
<数据>
 <名称>实现网络连通检测</名称>
 <类别>网络</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:22:10</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>网络</关键字1>
 <关键字2>连通</关键字2>
 <关键字3>监测</关键字3>
 <内容简介>下面是实现网络连通检测的VB 6代码： </内容简介>
 <内容>Private Sub Form_Load()  If IsConnected = TRUE Then  MsgBox (“您已经连通了Internet!”)  End If  If IsConnected = FALSE Then  MsgBox (“您还没有连通 Internet!”)  End If  End Sub  　  Option Explicit  /＊有关的API声明和定义＊/  Public Declare Function RasEnumConnections Lib “RasApi32.dll” Alias “RasEnumConnectionsA” (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long  　  Public Declare Function RasGetConnectStatus Lib “RasApi32.dll” Alias “RasGetConnectStatusA” (ByVal hRasCon As Long, lpStatus As Any) As Long  　  /＊常数和变量的设定＊/  Public Const RAS95_MaxEntryName = 256  Public Const RAS95_MaxDeviceType = 16  Public Const RAS95_MaxDeviceName = 32  Public Type RASCONN95  dwSize As Long  hRasCon As Long  szEntryName(RAS95_MaxEntryName) As Byte  szDeviceType(RAS95_MaxDeviceType) As Byte  szDeviceName(RAS95_MaxDeviceName) As Byte  End Type  Public Type RASCONNSTATUS95  dwSize As Long  RasConnState As Long  dwError As Long  szDeviceType(RAS95_MaxDeviceType) As Byte  szDeviceName(RAS95_MaxDeviceName) As Byte  End Type  　  /＊函数IsConnected返回连通的状态，如果为True则表示已连通＊/  Public Function IsConnected() As Boolean  Dim TRasCon(255) As RASCONN95  Dim lg As Long  Dim lpcon As Long  Dim RetVal As Long  Dim Tstatus As RASCONNSTATUS95  TRasCon(0).dwSize = 412  lg = 256 ＊ TRasCon(0).dwSize  RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)  If RetVal <> 0 Then  MsgBox “错误”  Exit Function  End If  Tstatus.dwSize = 160  RetVal = RasGetConnectStatus(TRasCon(0)  .hRasCon,Tstatus)  If Tstatus.RasConnState = ＆H2000 Then  IsConnected = TRUE  Else  IsConnected = FALSE  End If  End Function</内容>
 </数据>
- <数据>
 <名称>启动拨号网络中的连接</名称>
 <类别>网络</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:22:57</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>拨号网络</关键字1>
 <关键字2>连接</关键字2>
 <关键字3>NULL</关键字3>
 <内容简介>NULL</内容简介>
 <内容>由于拨号网络不是一个可执行文件， 所以要启动拨号网络，需要借助 explorer.exe 。但若是要启动拨号网络中的某一个连接，则要借助rundll.exe 和 rnaui.dll两个文件。启动方法如下（假定此连接名称为163）：  Shell “rundll rnaui.dll，RnaDial 163”，vbNormalFocus  上面假定了连接名称，但在实际编程中我们是不知道连接名称的。在窗体上放置一个命令按钮（cmdCallConnect)，在其单击事件中进行连接处理。下面的代码介绍如何取得默认的连接名称并启动它：  Option Explicit  /＊有关的API声明＊/  Private Declare Function RegOpenKeyEx Lib “advapi32” Alias “RegOpenKeyExA” (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long  　  Private Declare Function RegQueryValueEx Lib “advapi32” Alias “RegQueryValueExA” (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long  　  Private Declare Function RegCloseKey Lib “advapi32”(ByVal hKey As Long) As Long  　  /＊常数的设定＊/  Const HKEY_CURRENT_USER = ＆H80000001  Const ERROR_SUCCESS = 0  在命令按钮（cmdCallConnect)中加入如下代码：  Private Sub cmdCallConnect_Click()  /＊启动默认拨号连接＊/  Shell “rundll rnaui.dll,RnaDial” ＋ GetConnect, vbNormalFocus  End Sub  　  /＊取得连接的函数（GetConnect）＊/  Public Function GetConnect() As String  Dim hKey As Long  Dim SubKey As String  /＊主键＊/  hKey = HKEY_CURRENT_USER  /＊子键＊/  SubKey = “RemoteAccess”  /＊取得默认连接名＊/  GetConnect=GetRegValue(hKey,SubKey, “Default”)  End Function  /＊取得注册的函数（GetRegValue）＊/  Public Function GetRegValue(hKey As Long，lpszSubKey As String，szKey As String) As Variant  On Error GoTo ErrorRoutineErr:  Dim phkResult As Long  Dim lResult As Long  Dim szBuffer As String  Dim lBuffSize As Long  /＊创建缓冲区＊/  szBuffer = Space(255)  lBuffSize = Len(szBuffer)  /＊打开注册键＊/  RegOpenKeyEx hKey, lpszSubKey, 0, 1,phkResult  /＊取得查询结果＊/  lResult = RegQueryValueEx(phkResult, szKey, 0, 0, szBuffer, lBuffSize)  /＊关闭注册键＊/  RegCloseKey phkResult  /＊返回结果＊/  If lResult = ERROR_SUCCESS Then  GetRegValue = Left(szBuffer, lBuffSize － 1)  Else  GetRegValue =“”  End If  Exit Function  /＊意外处理＊/  ErrorRoutineErr:  GetRegValue =“”  End Function</内容>
 </数据>
- <数据>
 <名称>设计E-mail的接发送收部分</名称>
 <类别>网络</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:25:41</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>Email</关键字1>
 <关键字2>接收</关键字2>
 <关键字3>发送</关键字3>
 <内容简介 />
 <内容>设计E-mail的接收部分  在VB 6菜单上点击“工程/部件...”，弹出“部件”对话框，在对话框的控件卡中选中Microsoft MAPI Controls 6.0控件，点击“确定”按钮后，工具箱上增加了MAPIMessage和MAPISession两个图标。  在Form上加入一个MAPIMessage控件，取名为MAPIMessage1；再加入一个MAPISession控件，取名为MAPISession1；再加入三个TextBox控件，分别取名为Subject、Content和Indexno， 将它们的Caption分别改为邮件标题、邮件内容和邮件索引号；在TextBox前各加入一个Label控件，将Caption分别改为标题、内容和索引号。  将MAPIMessage1的各项属性设置如下：  ●DownLoadMail=TRUE；  ●LogonUI=TRUE；  ●NewSession=FALSE；  ●UserName=“接收Email”。  在Form上加入一个按钮（Getmail），将其Caption改为取邮件。  在 Getmail_Click()事件中加入以下程序代码，程序的功能是使我们接收Email。  MAPIMessage1.Fetch  Form1.Caption=MAPIMessage1.MsgCount  MAPIMessage1.MsgIndex=CINT(Indexno.text)  Subject.Text = MAPIMessage1.MsgNoteText  Content.Text = MAPIMessage1.MsgSubject  其中Fetch命令用来将信件抓到系统存储器的inbuffer中。我们将信件抓回来后，可以通过MsgCount属性知道信件数量,接着可以用MsgIndex设置要看哪一封信件的内容、标题等。  设计E-mail的发送部分  1．参数设置  进入Exchange系统，选择新增设置文件后屏幕上会显示所需要的信息服务，选择Internet Mail。  把设置文件的名称设为test。屏幕会显示两个选项，您可以选择以Modem方式或以Network 方式连接。笔者所用的是Modem方式；假若您是使Internet专线，就要选择Network 方式。  选择Modem方式后，Exchange会要求我们输入邮件服务器的IP地址。接着将Transform Message的模式设置为Automatic，这样当我们连接到邮件服务器时，新的信息会自动下载到本地端。接下来，将您所使用的Email地址、全名、口令和下载路径等一一设置好。  2．程序设计  在Form上加入一个MAPIMessage控件，取名为MAPIMessage1；加入一个MAPISession控件，取名为MAPISession1；并加入三个TextBox控件，取名为Subject、Content和Addr。并在三个TextBox前各加入一个Label，将Caption分别改为标题、内容和地址。  将MAPIMessage1的各项属性设置如下：  ●DownLoadMail=TRUE；  ●LogonUI=TRUE；  ●NewSession=FALSE；  ●UserName=“发送Email”。  这里将DownLoadMail设置为TRUE，当程序和邮件服务器第一次连接时，会将新的邮件下载到本地端。将LogonUI设置为TRUE，则当您程序中Logon名称输入错误时，系统会显示一个Message Box来让您输入正确的名称。  由于这个程序仅使用一个Session，所以可将NewSession设置成FALSE。如果您有许多Session要建立的话，则将它设置成TRUE。UserName中所填的，是我们在Exchange中所新增的设置文件名称，如果没有填内容的话，系统将会显示一些Message Box请您输入文件。  在Form上加入三个按钮，Logon、Logoff和Send，并分别将它们的Caption改为登录、离网和发送。  在 Logon_Click()事件中加入以下程序代码，程序的功能是使我们登录到邮件服务器：  MAPISession1.SignOn  MAPIMessage1.SessionID=MAPISession1.SessionID  sgBox “Your ID is” ＋ Str  (MAPISession1.SessionID)  其中MAPISession1.SignOn是作登录的动作。在登录时，因为已经将MAPIMessage1控件的DownLoadMail属性设置为TRUE，所以可以在屏幕上看到Message Box，显示系统正在下载邮件。登录成功后，系统会传回一个SessionID，将该ID填入MAPIMessage1的SessionID中，这样就可以利用该Session来传送Email，同时用Message Box通知用户发送成功。  在Logoff_Click()事件中加入以下程序代码，程序的功能是使我们离开邮件服务器：  MAPIS1.SignOff  在Send_Click()事件中加入以下程序代码，程序的功能是使我们发送Email：  MAPIMessage1.Compose  MAPIMessage1.RecipDisplayName = Addr.text  MAPIMessage1.AddressResolveUI = TRUE  MAPIMessage1.MsgSubject = Subject.text  MAPIMessage1.MsgNoteText = Content.text  MAPIMessage1.Send  MsgBox “您发送成功啦！”  其中Compose命令的主要目的是使您可以改变RecipDisplayName的内容，将所需传送的Email地址、主题和文章内容分别填入RecipDisplayName、MsgSubject和MsgNoteText，接着用Send命令发送出去。</内容>
 </数据>
- <数据>
 <名称>访问因特网并调用Explorer </名称>
 <类别>网络</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:24:57</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>访问</关键字1>
 <关键字2>因特网</关键字2>
 <关键字3>Explorer</关键字3>
 <内容简介>访问Internet并调用Explorer</内容简介>
 <内容>1．实现方法和控件介绍  　　首先在VB 6菜单上点击“工程/部件...”，弹出“部件”对话框，在对话框的控件卡中选中Microsoft Internet Controls控件，点击“确定”按钮后工具箱上增加一个WebBrowser图标，将它加到Form中。  该控件有以下几个重要的方法和事件：  ●GoHome：装入IE设定的起始页；  ●Navigate：装入页面，如Object.Navigate url，其中url为URL地址，如http://www.microsoft.com；  ●GoBack：返回上一个页面；  ●GoForward：进入下一个页面；  ●Stop：停止载入页面；  ●BeforeNavigate Event：在每次装入页面前调用该事件；  ●StatusTextChange Event：每次浏览器的操作状态改变时调用该事件。  2．具体的访问方法  将WebBrowser图标添加到Form中。并在Form上添加4个命令按钮，Name属性分别为：GoButton、BackButton、ForwardButton和StopButton，通过这4个命令按钮可以实现对浏览器的操作。在Form上添加一个TextBox控件，用来输入和显示当前的页面地址。在Form上添加一个Label控件，用来显示当前浏览器操作状态。  /＊载入Form＊/  Private Sub Form_Load()  /＊程序装入后进入IE设定的起始页＊/  WebBrowser1.GoHome  End Sub  　  /＊改变Form尺寸＊/  Private Sub Form_Resize()  /＊改变窗口大小后同时改变控件的大小＊/  WebBrowser1.Width = Form1.ScaleWidth  WebBrowser1.Height = Form1.ScaleHeight － 900  Label1.Width = Form1.ScaleWidth  Label1.Top = Form1.ScaleHeight － 300  End Sub  　  Private Sub BackButton_Click()  /＊返回上一个页面＊/  WebBrowser1.GoBack  End Sub  　  Private Sub ForwardButton_Click()  /＊进入下一个页面＊/  WebBrowser1.GoForward  End Sub  　  Private Sub GoButton_Click()  /＊浏览输入的页面＊/  WebBrowser1.Navigate (Text1.Text)  End Sub  　  Private Sub StopButton_Click()  /＊停止浏览＊/  WebBrowser1.Stop  End Sub  　  Private Sub Text1_KeyPress(KeyAscii As Integer)  /＊输入地址后进行浏览＊/  If KeyAscii = 13 Then  WebBrowser1.Navigate (Text1.Text)  End If  End Sub  　  Private Sub WebBrowser1_BeforeNavigate(ByVal URL As String, ByVal Flags As Long, ByVal TargetFrameName As String, PostData As Variant, ByVal Headers As String, Cancel As Boolean)  /＊将当前显示的页面的URL地址显示在Text1上＊/ Text1.Text = URL  End Sub  　  Private Sub WebBrowser1_StatusTextChange(ByVal Text As String)  /＊Label1显示当前页面装入情况＊/  Label1.Caption = Text  End Sub</内容>
 </数据>
- <数据>
 <名称>禁止在TextBox中输入</名称>
 <类别>VB文件</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:29:59</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>TextBox</关键字1>
 <关键字2>输入</关键字2>
 <关键字3>禁止</关键字3>
 <内容简介>NULL</内容简介>
 <内容>禁止在TextBox中输入 作者：土人  方法一：(有光标闪烁，输入、删除等操作无效) Text1.Locked = True 方法二：(无光标闪烁，不能输入、删除，界面变色、文字反白) Text1.Enabled = False 方法三：(有光标闪烁，可删除，不能输入) 此法用两个API函数，略为复杂些。请在标准工程添加两个按钮和一个文本框： Option Explicit Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Const GWL_STYLE = (-16) Const ES_NUMBER = &H2000& Public Sub SetNumber(NumberText As TextBox, Flag As Boolean) Dim CurrentStyle As Long, NewStyle As Long '返回正常样式 CurrentStyle = GetWindowLong(NumberText.hwnd, GWL_STYLE) If Flag Then CurrentStyle = CurrentStyle Or ES_NUMBER Else CurrentStyle = CurrentStyle And (Not ES_NUMBER) End If '设置新样式 NewStyle = SetWindowLong(NumberText.hwnd, GWL_STYLE, CurrentStyle) NumberText.Refresh '刷新 End Sub Private Sub Command1_Click() SetNumber Text1, True Text1.SetFocus End Sub Private Sub Command2_Click() SetNumber Text1, False Text1.SetFocus End Sub Private Sub Form_Load() Command1.Caption = "禁止输入" Command2.Caption = "可以输入" End Sub</内容>
 </数据>
- <数据>
 <名称>在VB应用程序中巧用DLL上</名称>
 <类别>VBDll</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:31:32</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>应用程序</关键字1>
 <关键字2>DLL</关键字2>
 <关键字3>NULL</关键字3>
 <内容简介>NULL</内容简介>
 <内容>在使用VB开发多媒体应用程序时，如何合理地存放大量的多媒体资源，是一件十分棘手的事。如果将资源以文件形式存放在磁（光）盘上，使用时再从盘上读取，势必大大影响资源调用的速度。如果将资源直接编译在应用程序的可执行文件中，虽然可以获得令人满意的资源存取速度，但会导致最终的可执行文件尺寸大大膨胀。如何解决这个矛盾呢？笔者从Windows动态链接库的原理中得到启发，找到了一个结合二者优势的解决方法。 动态链接库是实现Windows应用程序共享资源、节省内存空间、提高使用效率的一个重要技术手段。常见的动态库包含外部函数和资源，也有一些动态库只包含资源，如Windows字体资源文件，我们将这类动态库称之为资源动态链接库。制作资源动态库的方法很多，笔者在此提供了一种无需编程、简单有效的方法。该方法利用了Borland C++的资源管理器Resource Workshop的反编译能力，借用现成的动态库，将其改制为自己的资源动态库。具体方法是，拷贝一个现成的资源动态库文件（如windows\system目录下的字体资源文件arial.fot）到应用程序工作目录，更改文件名，如改为DEMO.DLL。然后在Resource Workshop中打开该文件，选择其中原有的资源将其删除，再加入自己的资源，即可制成自己的资源动态库。由于篇幅所限，具体操作过程请读者参阅有关资料。不过有两个关键问题需要提请读者注意，其一，对于声音这类非Windows传统资源，在加入动态库之前，需要用户自定义一个资源类型以存放这类资源，如笔者在DEMO.DLL中为Windows音频文件定义了WAVE资源类型；其二，动态库中每一个资源的资源名十分重要，它是调用资源的关键，建议用户最好在加入资源后为其定义一个有意义的资源名。 通过上面介绍的资源动态库的简单制作方法，即使不熟悉C语言的读者也可以轻松地制作自己的资源动态库了。现在，让我们来看看如何在VB多媒体应用程序中调用资源动态库中的资源。VB本身并没有调用动态库的函数和语句，因此必须借助于Windows API函数。下面笔者将结合一个实例，具体介绍调用方法。实例中使用的是笔者通过上述方法制作的资源动态库DEMO.DLL，其中包含两个BITMAP（.bmp）类型资源B1和B2，两个WAVE（.wav）类型资源S1和S2。 首先，新建一个VB工程，其中包含一个窗体Form1和一个模块Module1。在窗体Form1中加入了一个图片框控件Picture1和四个命令按钮控件，Picture1用于显示动态库中的位图资源，四个命令按钮的属性设置和功能含义如下表： 属性 功能 Name Index Caption  cmdBitmap 0 BitmapA 在Picture1中显示DEMO.DLL中资源名为B1的位图资源 cmdBitmap 1 BitmapB 在Picture1中显示DEMO.DLL中资源名为B2的位图资源 cmdSound 0 SoundA 播放DEMO.DLL中资源名为S1的声音资源 cmdSound 1 SoundB 播放DEMO.DLL中资源名为S2的声音资源 接着在Module1和Form1中加入下列代码，便可完成实例程序： ※Moudle1.bas清单 '声明API函数 Declare Function LoadLibrary% Lib "Kernel" (ByVal lpLibFileName$) Declare Sub FreeLibrary Lib "Kernel" (ByVal hLibModule%) Declare Function LoadBitmap% Lib "User" (ByVal hInstance%, ByVal lpBitmapName As Any) Declare Function GetObj% Lib "GDI" Alias "GetObject" (ByVal hObject%, ByVal nCount%, lpObject As Any) Declare Function CreateCompatibleDC% Lib "GDI" (ByVal hDC%) Declare Function SelectObject% Lib "GDI" (ByVal hDC%, ByVal hObject%) Declare Function BitBlt% Lib "GDI" (ByVal hDestDC%, ByVal x%, ByVal y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal XSrc%, ByVal YSrc%, ByVal dwRop&) Declare Function DeleteDC% Lib "GDI" (ByVal hDC%) Declare Function DeleteObject% Lib "GDI" (ByVal hObject%) Declare Function FindResource% Lib "Kernel" (ByVal hInstance%, ByVal lpName$, ByVal lpType As Any) Declare Function LockResource& Lib "Kernel" (ByVal hResData%) Declare Function LoadResource% Lib "Kernel" (ByVal hInstance%, ByVal hResInfo%) Declare Function GlobalUnlock% Lib "Kernel" (ByVal hMem%) Declare Function sndPlaySound% Lib "MMSYSTEM" (ByVal lpszSoundName As Any, ByVal uFlags%) '位图数据结构类型 Type BITMAP bmType As Integer bmWidth As Integer bmHeight As Integer bmWidthBytes As Integer bmPlanes As String * 1 bmBitsPixel As String * 1 bmBits As Long End Type '光栅操作代码常量 Public Const SRCCOPY = &HCC0020 '声音播放状态常量 Public Const SND_SYNC = &H0 Public Const SND_MEMORY = &H4</内容>
 </数据>
- <数据>
 <名称>在VB应用程序中巧用DLL下</名称>
 <类别>VBDll</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:31:41</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>应用程序</关键字1>
 <关键字2>DLL</关键字2>
 <关键字3>NULL</关键字3>
 <内容简介>NULL</内容简介>
 <内容>'调用位图资源子例程 Sub load_pic(picName As String) Dim hDLL As Integer Dim hdcMemory, hLoadedbitmap, hOldBitmap As Integer Dim retVal As Integer Dim bmpInfo As BITMAP '安装动态链接库DEMO.DLL hDLL = LoadLibrary(App.Path & "\DEMO.DLL") '根据资源名从动态链接库中加载相应的位图资源 hLoadedbitmap = LoadBitmap(hDLL, picName) '获取位图信息 retVal = GetObj(hLoadedbitmap, Len(bmpInfo), bmpInfo) '创建一个与图片框控件的设备描述表兼容的内存设备描述表 hdcMemory = CreateCompatibleDC(Form1.Picture1.hDC) '将位图选入内存设备描述表 hOldBitmap = SelectObject(hdcMemory, hLoadedbitmap) '将位图从内存设备描述表中拷入图片框控件的设备描述表中 retVal = BitBlt(Form1.Picture1.hDC, 0, 0, bmpInfo.bmWidth, bmpInfo.bmHeight, hdcMemory, 0, 0, SRCCOPY) '将原始位图选入内存设备描述表 retVal = SelectObject(hdcMemory, hOldBitmap) '删除加载的位图，释放其占用的所有系统资源 retVal = DeleteObject(hLoadedbitmap) '删除内存设备描述表 retVal = DeleteDC(hdcMemory) '释放动态链接库 FreeLibrary (hDLL) End Sub '调用声音资源子例程 Sub load_sound(wavName As String) Dim hDLL As Integer Dim hloadwave As Integer Dim hwaveres As Integer Dim hsound As Long Dim hrelease As Integer Dim resVal As Integer hDLL = LoadLibrary(App.Path & "\DEMO.DLL") '在动态链接库中查找资源类型为WAVE，资源名为wavName的资源 hwaveres = FindResource(hDLL, wavName, "WAVE") '将该资源装入内存 hloadwave = LoadResource(hDLL, hwaveres) '锁定该资源 hsound = LockResource(hloadwave) '以同步方式播放内存中的声音资源 resVal = sndPlaySound(hsound, SND_SYNC + SND_MEMORY) '释放该资源占用的内存 hrelease = GlobalUnlock(hloadwave) FreeLibrary (hDLL) End Sub ※FORM1.FRM代码清单 Private Sub cmdBitmap_Click(Index As Integer) Picture1.Picture = LoadPicture("") '清空图片框控件 Select Case Index Case 0 load_pic ("B1") Case 1 load_pic ("B2") End Select End Sub Private Sub cmdSound_Click(Index As Integer) Select Case Index Case 0 load_sound ("S1") Case 1 load_sound ("S2") End Select End Sub 本实例程序已在Windows 3.X环境下通过测试。程序中的某些参数设置与特定需求（如资源动态库的内容等）有关，读者在开发实际应用时应做相应的改动。</内容>
 </数据>
- <数据>
 <名称>判断某一个连接是否保存在Cache中上</名称>
 <类别>网络</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 17:11:10</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>连接</关键字1>
 <关键字2>Cache</关键字2>
 <关键字3>保存</关键字3>
 <内容简介>在使用Microsoft IE在网上冲浪时，IE会把你浏览过的网页保存在Cache中以便你可以脱机浏览。下面这个程序可以判断一个URL是否在浏览器的Cache中。 </内容简介>
 <内容>判断某一个连接是否保存在Cache中  在使用Microsoft IE在网上冲浪时，IE会把你浏览过的网页保存在Cache中以便你可以脱机浏览。下面这个程序可以判断一个URL是否在浏览器的Cache中。  首先建立一个新的VB工程文件，在Form1中加入一个CommandButton控件和一个TextBox控件，然后在Form1的代码窗口中加入以下代码：  Option Explicit  Private Const ERROR_INSUFFICIENT_BUFFER = 122  Private Const eeErrorBase = 26720  Private Type FILETIME  dwLowDateTime As Long  dwHighDateTime As Long  End Type  Private Type INTERNET_CACHE_ENTRY_INFO  dwStructSize As Long  lpszSourceUrlName As String  lpszLocalFileName As String  CacheEntryType As String  dwUseCount As Long  dwHitRate As Long  dwSizeLow As Long  dwSizeHigh As Long  LastModifiedTime As FILETIME  ExpireTIme As FILETIME  LastAccessTime As FILETIME  LastSyncTime As FILETIME  lpHeaderInfo As Long  dwHeaderInfoSize As Long  lpszFileExtension As String  dwReserved As Long  End Type  Private Declare Function GetUrlCacheEntryInfo Lib "wininet.dll" Alias _  "GetUrlCacheEntryInfoA" _  (ByVal sUrlName As String, _  lpCacheEntryInfo As Any, _  lpdwCacheEntryInfoBufferSize As Long _  ) As Long  Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100  Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000  Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800  Private Const FORMAT_MESSAGE_FROM_STRING = &H400  Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000  Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200  Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF  Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _  (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, _  ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As _  Long, Arguments As Long) As Long  Public Function WinAPIError(ByVal lLastDLLError As Long) As String  Dim sBuff As String  Dim lCount As Long  ’获取错误消息  sBuff = String$(256, 0)  lCount = FormatMessage( _  FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, _  0, lLastDLLError, 0&, sBuff, Len(sBuff), ByVal 0)  If lCount Then  WinAPIError = Left$(sBuff, lCount)  End If  End Function </内容>
 </数据>
- <数据>
 <名称>判断某一个连接是否保存在Cache中下</名称>
 <类别>网络</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 17:11:17</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>连接</关键字1>
 <关键字2>Cache</关键字2>
 <关键字3>保存</关键字3>
 <内容简介>在使用Microsoft IE在网上冲浪时，IE会把你浏览过的网页保存在Cache中以便你可以脱机浏览。下面这个程序可以判断一个URL是否在浏览器的Cache中。 </内容简介>
 <内容>Public Function GetCacheEntryInfo(ByVal hWnd As Long, ByVal lpszUrl As String) As Boolean  Dim dwEntrySize As Long  Dim lpCacheEntry As INTERNET_CACHE_ENTRY_INFO  Dim dwTemp As Long  Dim lErr As Long  If (GetUrlCacheEntryInfo(lpszUrl, ByVal 0&, dwEntrySize)) = 0 Then  lErr = Err.LastDllError  If (lErr <> ERROR_INSUFFICIENT_BUFFER) Then  ’URL没有在Cache中  Err.Raise eeErrorBase + 1, App.EXEName & ".mCacheEntry", WinAPIError(lErr)  GetCacheEntryInfo = False  Exit Function  Else  ’URL保存在Cache中  GetCacheEntryInfo = True  End If  End If  End Function  Private Sub Command1_Click()  On Error GoTo ErrorHandler  If (GetCacheEntryInfo(Me.hWnd, Text1.Text)) Then  MsgBox "URL 保存在Cache中.", vbInformation  Else  MsgBox "URL 没有保存在Cache中.", vbInformation  End If  Exit Sub  ErrorHandler:  MsgBox "URL 没有保存在Cache中 [" & Err.Description & "]", vbInformation  End Sub  Private Sub Form_Load()  Form1.CurrentX = 150: Form1.CurrentY = 60  Form1.Print "在Text1中输入URL，按Command1检测"  Text1.Text = ""  Command1.Default = True  End Sub  运行程序，在TextBox中输入URL地址（例如http://member.netease.com/~blackcat），然后点击Command1  按钮，如果URL在Cache中，程序会弹出消息框显示URL 保存在Cache中</内容>
 </数据>
<数据>
 <名称>用VB制作IE工具条自定义按钮上</名称>
 <类别>界面</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 14:59:22</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>IE</关键字1>
 <关键字2>按钮</关键字2>
 <关键字3>工具条</关键字3>
 <内容简介>用VB制作IE工具条自定义按钮 作者：西安市含光门外中原小区1号楼3单元702(710068) 张庆 </内容简介>
 <内容>现在，有许多软件安装后会在 IE 浏览器的工具条上添加一个自定义按钮，为用户运行程序提供了方便，如“网络蚂蚁”、“金山词霸2000”等等。实际上添加这个自定义按钮并不难，只要找到了它在注册表中的位置和有关参数，通过手工或程序都可以轻易完成。而最方便的办法就是调用现成的 ActiveX 控件来完成这个功能，但 Windows 似乎没有提供这种控件。下面介绍如何开发和使用这种自定义控件。  实现方法  要添加这种自定义按钮，需要在 Windows 注册表的 HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions 子键下建立一个 GUID 项，然后在注册表的右栏建立相应的参数并赋值。这些参数及其含义如下：  ●ButtonText：自定义按钮上显示的文本字符串；  ●Clsid：IE 工具条的类标识码，为“{1FBA04EE－3024－11D2－8F1F0000F87ABD16}”；  ●Default Visible：自定义按钮是否可见，一般为 “Yes"；  ●Exec：自定义按钮执行的目标，为可执行文件或超文本链接等；  ●HotIcon：鼠标移上按钮时显示的图标，一般取自 EXE 文件或 DLL 文件；  ●Icon：按钮正常显示的图标，一般取自 EXE 文件或 DLL 文件；  ●MenuText：在 IE 的“工具”菜单中显示的菜单项；  ●MenuStatusBar：IE的“工具”菜单项的注释，在状态条上显示。  制作过程  在 VB 5.0/6.0 下建立新的“ActiveX 控件”工程。  首先，给控件 AddButton 的 Picture 属性添加一个微型 Icon 图片，这样当使用该控件时，会在控件工具箱上显示这个小图标。然后，再在设计窗口上放置一个 image 控件，给它也设置一个小图片，使用该控件时，会在其 Form 上显示该控件的外观。最后，调出代码编辑窗口，在该窗口中键入以下代码，其中 API 函数调用的代码可以直接从“API 文本浏览器”中获得。  Option Explicit  ……'Default Property Values  ……'Property Variables  '定义常量  Const HKEY_LOCAL_MACHINE = ＆H80000002  Const REG_SZ = 1  '声明存取注册表的 API 函数  Private Declare Function RegCloseKey Lib “advapi32.dll" (ByVal hKey As Long) As Long  Private Declare Function RegCreateKey Lib “advapi32.dll" Alias “RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long  Private Declare Function RegDeleteValue Lib “advapi32.dll" Alias “RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long  Private Declare Function RegOpenKey Lib “advapi32.dll" Alias “RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long  Private Declare Function RegSetValueEx Lib “advapi32.dll" Alias “RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String,ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long </内容>
 </数据>
- <数据>
 <名称>用VB制作IE工具条自定义按钮下</名称>
 <类别>界面</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 14:59:31</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>IE</关键字1>
 <关键字2>按钮</关键字2>
 <关键字3>工具条</关键字3>
 <内容简介>用VB制作IE工具条自定义按钮 作者：西安市含光门外中原小区1号楼3单元702(710068) 张庆 </内容简介>
 <内容>'定义注册表中的主键、子键  Const hKey = HKEY_LOCAL_MACHINE  Const subKey0=“Software\Microsoft\Internet Explorer\Extensions\"  ’把字符串值存入注册表  Private Sub SaveString(hKey As Long, strPath As String, strValue As String, strdata As String)  Dim keyhand As Long  Dim r As Long  r=RegCreateKey(hKey, strPath, keyhand)  r=RegSetValueEx(keyhand, strValue, 0,REG_SZ, ByVal strdata, Len(strdata))  r=RegCloseKey(keyhand)  End Sub  ’从注册表中删除字符串值  Private Function DeleteValue(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String)  Dim r, keyhand As Long  r = RegOpenKey(hKey, strPath, keyhand)  r = RegDeleteValue(keyhand, strValue)  r = RegCloseKey(keyhand)  End Function  '把设置写入注册表,定义按钮  Public Sub AddBtn2IEtoolbar()  Dim subKey As String  subKey = subKey0 ＆ Trim(GUID) ＆ “\"  Call SaveString(hKey, subKey, “ButtonText", ButtonText)  Call SaveString(hKey, subKey,“Clsid",  “{1FBA04EE－3024－11D2－8F1F0000F87ABD16}")  Call SaveString(hKey, subKey, “Default Visible", “Yes")  Call SaveString(hKey, subKey, “Exec", Exec)  Call SaveString(hKey, subKey, “HotIcon", HotIcon)  Call SaveString(hKey, subKey, “Icon", Icon)  Call SaveString(hKey, subKey, “MenuStatusBar",  MenuStatusBar)  Call SaveString(hKey,subKey,“MenuText", MenuText)End Sub  '从注册表中删除自定义按钮  Public Sub DelBtnFromIEtoolbar()  Dim subKey As String  subKey = subKey0 ＆ Trim(GUID) ＆ “\"  Call DeleteValue(hKey, subKey, “ButtonText")  Call DeleteValue(hKey, subKey, “Clsid")  Call DeleteValue(hKey, subKey, “Default Visible")  Call DeleteValue(hKey, subKey, “Exec")  Call DeleteValue(hKey, subKey, “HotIcon")  Call DeleteValue(hKey, subKey, “Icon")  Call DeleteValue(hKey, subKey, “MenuStatusBar")  Call DeleteValue(hKey, subKey, “MenuText")  End Sub  '初始化控件属性  Private Sub UserControl_InitProperties()  m_ButtonText = m_def_ButtonText  m_Exec = m_def_Exec  m_HotIcon = m_def_HotIcon  m_Icon = m_def_Icon  m_MenuText = m_def_MenuText  m_MenuStatusBar = m_def_MenuStatusBar  m_GUID = m_def_GUID  End Sub  '从存储器中加载属性值  Private Sub UserControl_ReadProperties(PropBag As PropertyBag)  m_ButtonText = PropBag.ReadProperty  (“ButtonText", m_def_ButtonText)  m_Exec = PropBag.ReadProperty(“Exec",  m_def_Exec)  m_HotIcon = PropBag.ReadProperty(“HotIcon",  m_def_HotIcon)  m_Icon = PropBag.ReadProperty(“Icon",  m_def_Icon)  m_MenuText = PropBag.ReadProperty  (“MenuText",m_def_MenuText)  m_MenuStatusBar =PropBag.ReadProperty  (“MenuStatusBar", m_def_MenuStatusBar)  m_GUID =PropBag.ReadProperty(“GUID",  m_def_GUID)  End Sub</内容>
 </数据>
- <数据>
 <名称>使用VB设计具有动感的命令图标栏</名称>
 <类别>界面</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:00:57</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>图标</关键字1>
 <关键字2>动感</关键字2>
 <关键字3>命令</关键字3>
 <内容简介>使用VB设计具有「动感」的命令图标栏 作者：张嵘 </内容简介>
 <内容>我们在使用Word、Excel等Windows应用程序时，经常会见到在程序界面顶端有一行“立体式”图标按钮。当用鼠标按下某一个图标按钮时，程序就执行相应的操作。这一行“立体式”图标按钮通常就称作命令图标栏或工具条。命令图标栏一般提供一些最常用的命令，供用户快速地取用，并且它设计时采用了“立体式”按钮，操作时会产生凹下去和凸出来的“动感”，笔者这里就谈谈如何用VB来建立具有“动感”的命令图标栏。 使命令图标具有“动感”是依靠对命令图标的不同状态的图像切换来获得的。当鼠标按下时，图标显示为凹入状态的图像；当松开时，图标显示为凸出状态的图像。通过图像切换就使命令图标具有了“动感”，具体设计步骤如下： 1首先在窗体中创建一个图片框（Picture Box），将其Align属性置为1，使图片框固定在窗体上端，调节其宽度使其能安置图像或命令按钮。 2在图标框内创建若干个图像框（Image Control），设置其Autosize＝True，Picture属性在程序运行中设置。 3编写程序代码。这里假设某个命令图标凸出状态的图像文件名为＂zrup.bmp＂，凹入状态的图像文件名为＂zrdown.bmp＂。 窗体装入时：Sub form－load（） Imagel.picture＝Loadpicture（＂zrup.bmp＂） ' 命令图标凸出 End sub 鼠标按下时：Sub Imagel－mousedown（Button As Integer Shift As Integer， X As single，Y As single） Imagel.picture＝Loadpicture（＂zrdown.bmp＂） ' 命令图标如下： End sub 鼠标松开时：Sub Imagel－mouseup（Button As Integer，Shift As Integer，X As single，Y As single）Imagel.picture＝Loadpicture（＂zrup.bmp＂） ' 命令图标凸出 End sub 以上只能使命令图标具备凹下去的功能，但当在按鼠标按钮不放，并拖曳鼠标使光标移到外头，原来图标仍然处于凹下状态。要使其自动凸起，就要编写如下代码： Sub Imagel-mouseup(Button As Integer,Shift As Integer,X As single,Y As single) Select Case Button Case 1 If X<=0 or X>Imagel.Width or Y<=0 or Y>Imagel.Height then Imagel.picture=Loadpicture("zrup.bmp") '凸出 else Imagel.picture=Loadpicture("zrdown.bmp") '凹入 End if End select End sub 通过以上三步骤就可以建立具有“动感”的命令图标，若具有多个命令图标时，可通过创建图像控制数组来实现。BMP是常见的一种图像格式，也可以使用VB提供的丰富的不同状态的命令图标位图文件，它在VB的子目录＼bitmaps＼中</内容>
 </数据>
- <数据>
 <名称>直接通过ODBCAPI访问SQL数据库一</名称>
 <类别>数据库</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:11:10</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>ODBC</关键字1>
 <关键字2>API</关键字2>
 <关键字3>SQL</关键字3>
 <内容简介 />
 <内容>********************************* ODBC - Open DataBase Connectivity ********************************* Basic Steps Connecting to the SQL Server DataBase for retrieving information from tables ************************************************************* The steps 1 - 3 are for connecting to the SQL Server Database ************************************************************* 1. Allocate ODBC Environment Handle If SQLAllocEnv(glEnv) <> 0 Then 　　MsgBox "Unable to initialize ODBC API drivers!" 　　End End If ______________________________________________________________ 2. Allocate ODBC Database Handle Dim iStatus As Integer If SQLAllocConnect(glEnv, glDbc) <> 0 Then 　　MsgBox "Could not allocate memory for connection Handle!" 　　ODBCInit = False 　　' Free the Environment 　　iStatus = SQLFreeEnv(lEnv) 　　If iStatus = SQL_ERROR Then 　　　　MsgBox "Error Freeing Environment From ODBC Drivers" 　　End If 　　' Quit the Application 　　End End If ______________________________________________________________  3. Connect using the sConnect string - SQLDriverConnect Dim sResult As String Dim iSize As Integer Dim sConnect As String sConnect = "DSN=" & gsDSN & ";UID=" & gsLoginID & ";PWD=" & gsPassword & ";APP=" & gsAppCode & ";DATABASE=" & gsDatabase If SQLDriverConnect(glDbc, Screen.ActiveForm.hWnd, sConnect, Len(sConnect), sResult, Len(sResult), iSize, 0) <= 0 Then 　　MsgBox "Could not establish connection to ODBC driver!" End If ______________________________________________________________ *************************************************** The steps 4 - 8 are for retrieving data from tables *************************************************** 4. Allocate ODBC Statement Handle If SQLAllocStmt(glDbc, glStmt) <> 0 Then 　　　MsgBox "Could not allocate memory for a statement handle!" End If ______________________________________________________________ 5. Execute ODBC Statement - SQLExecDirect Dim lRet As Long, lErrNo As Long Dim iLen As Integer Dim sSQLState As String * MAX_DATA_BUFFER Dim sErrorMsg As String * MAX_DATA_BUFFER Dim sMsg As String sSQL = "SELECT name, location FROM authors" If SQLExecDirect(glStmt, sSQL, Len(sSQL)) <> SQL_SUCCESS Then 　　' Also Check for ODBC Error message - SQLError 　　lRet = SQLError(glEnv, gldbc, glStmt, sSQLState, lErrNo, sErrorMsg, MAX_DATA_BUFFER, iLen) 　　sMsg = "Error Executing SQL Statement" & Chr$(13) & Chr$(10) 　　sMsg = sMsg & "ODBC State = " & Trim$(Left$(sSQLState, InStr(sSQLState, Chr$(0)) - 1)) & Chr$(13) & Chr$(10) 　　sMsg = sMsg & "ODBC Error Message = " & Left$(sErrorMsg, iLen) 　　MsgBox sMsg, vbInformation, "Execute Query" End If ______________________________________________________________ 6. Fetch one row of results from executed ODBC Statement - SQLFetch Code in Step 7. ______________________________________________________________</内容>
 </数据>
- <数据>
 <名称>直接通过ODBCAPI访问SQL数据库二</名称>
 <类别>数据库</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:10:29</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>ODBC</关键字1>
 <关键字2>API</关键字2>
 <关键字3>SQL</关键字3>
 <内容简介>NULL</内容简介>
 <内容>7. Get the Data in each field of the Fetched row - SQLGetData Dim bPerform As Integer, iStatus As Integer Dim sData As String * MAX_DATA_BUFFER Dim lOutLen As Long bPerform = SQLFetch(glStmt) Do While bPerform 　　bPerform = SQLFetch(lStmt)　　　　 ' Get the next row of data 　　If bPerform = SQL_SUCCESS Then　　　　‘ If rows of data available　　  　　　　bPerform = True 　　　　' Get Author Name -　iColumn = 1 for first field i.e. name in sSQL  　　　　iStatus = SQLGetData(glStmt, iColumn, 1, sData, MAX_DATA_BUFFER, lOutLen) 　　　　' lOutlen = length of the valid data in sData 　　　　' Data value will be = Left$(sData, lOutlen),　lOutlen = -1 if no data or Null data 　　　　' Get Location -　iColumn = 2 for second field i.e. location in sSQL 　　　　iStatus = SQLGetData(glStmt, iColumn, 1, sData, MAX_DATA_BUFFER, lOutLen) 　　　　 ' Add the Field Data to Correponding Data Display Controls for this row 　　Else 　　　　bPerform = False　　' No more rows available 　　End If Loop 'Release the ODBC Statement Handle bPerform = SQLFreeStmt(glStmt, SQL_DROP) ______________________________________________________________ 8. Release the ODBC Statement Handle - SQLFreeSTmt Code in Step 7. ______________________________________________________________ ******************************************************************* The steps 9 - 11 are for Disconnecting from the SQL Server DataBase ******************************************************************* 9. Disconnect from ODBC Database - SQLDisconnect iStatus = SQLDisconnect(glDbc) ______________________________________________________________ 10. Release the ODBC Database Handle - SQLFreeConnect iStatus = SQLFreeConnect(glDbc) ______________________________________________________________ 11. Release the ODBC Environment Handle - SQLFreeEnv iStatus = SQLFreeEnv(glEnv) ______________________________________________________________  *********************************************************************** The following entries are required in the ODBCAPI module *********************************************************************** ' ODBC Variables and Constants 　 Global glEnv As Long Global glDbc As Long Global sSQL As String 　 Global Const MAX_DATA_BUFFER = 255 Global Const SQL_SUCCESS = 0 Global Const SQL_SUCCESS_WITH_INFO = 1 Global Const SQL_ERROR = -1 Global Const SQL_NO_DATA_FOUND = 100 Global Const SQL_CLOSE = 0 Global Const SQL_DROP = 1 Global Const SQL_CHAR = 1 Global Const SQL_NUMERIC = 2 Global Const SQL_DECIMAL = 3 Global Const SQL_INTEGER = 4 Global Const SQL_SMALLINT = 5 Global Const SQL_FLOAT = 6 Global Const SQL_REAL = 7 Global Const SQL_DOUBLE = 8 Global Const SQL_VARCHAR = 12 Global Const SQL_DATA_SOURCE_NAME = 6 Global Const SQL_USER_NAME = 8 'ODBC Declarations 'The hWnd is a Long in Windows 95 & Windows NT</内容>
 </数据>
- <数据>
 <名称>直接通过ODBCAPI访问SQL数据库三</名称>
 <类别>数据库</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:10:56</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>ODBC</关键字1>
 <关键字2>API</关键字2>
 <关键字3>SQL</关键字3>
 <内容简介>NULL</内容简介>
 <内容>#If Win32 Then 　　Declare Function SQLAllocEnv Lib "odbc32.dll" (env As Long) As Integer 　　Declare Function SQLFreeEnv Lib "odbc32.dll" (ByVal env As Long) As Integer 　　Declare Function SQLAllocConnect Lib "odbc32.dll" (ByVal env As Long, ldbc As Long) As Integer 　　Declare Function SQLConnect Lib "odbc32.dll" (ByVal ldbc As Long, ByVal Server As String,ByVal serverlen As Integer, ByVal uid As String, ByVal 　　uidlen As Integer, ByVal pwd As String, ByVal pwdlen As Integer) As Integer 　　Declare Function SQLDriverConnect Lib "odbc32.dll" (ByVal ldbc As Long, ByVal hWnd As Long, ByVal szCSIn As String, ByVal cbCSIn As 　　Integer,ByVal szCSOut As String, ByVal cbCSMax As Integer, cbCSOut As Integer, ByVal f As Integer) As Integer 　　Declare Function SQLFreeConnect Lib "odbc32.dll" (ByVal ldbc As Long) As Integer 　　Declare Function SQLDisconnect Lib "odbc32.dll" (ByVal ldbc As Long) As Integer 　　Declare Function SQLAllocStmt Lib "odbc32.dll" (ByVal ldbc As Long, lStmt As Long) As Integer 　　Declare Function SQLFreeStmt Lib "odbc32.dll" (ByVal lStmt As Long, ByVal EndOption As Integer) As Integer 　　Declare Function SQLTables Lib "odbc32.dll" (ByVal lStmt As Long, ByVal q As Long, ByVal cbq As Integer, ByVal o As Long, ByVal cbo As Integer, 　　ByVal t As Long, ByVal cbt As Integer, ByVal tt As Long, ByVal cbtt As Integer) As Integer 　　Declare Function SQLExecDirect Lib "odbc32.dll" (ByVal lStmt As Long, ByVal sqlString As String, ByVal sqlstrlen As Long) As Integer 　　Declare Function SQLNumResultCols Lib "odbc32.dll" (ByVal lStmt As Long, NumCols As Integer) As Integer 　　Declare Function SQLDescribeCol Lib "odbc32.dll" (ByVal lStmt As Long, ByVal colnum As Integer, ByVal colname As String, ByVal Buflen As 　　Integer, colnamelen As Integer, dtype As Integer, dl As Long, ds As Integer, n As Integer) As Integer 　　Declare Function SQLFetch Lib "odbc32.dll" (ByVal lStmt As Long) As Integer 　　Declare Function SQLGetData Lib "odbc32.dll" (ByVal lStmt As Long, ByVal col As Integer, ByVal wConvType As Integer, ByVal lpbBuf As String, 　　ByVal dwbuflen As Long, lpcbout As Long) As Integer 　　Declare Function SQLGetInfo Lib "odbc32.dll" (ByVal ldbc As Long, ByVal hWnd As Long, ByVal szInfo As String, ByVal cbInfoMax As Integer, 　　cbInfoOut As Integer) As Integer 　　Declare Function SQLError Lib "odbc32.dll" (ByVal env As Long, ByVal ldbc As Long, ByVal lStmt As Long, ByVal SQLState As String, NativeError As 　　Long, ByVal Buffer As String, ByVal Buflen As Integer, Outlen As Integer) As Integer #Else </内容>
 </数据>
- <数据>
 <名称>直接通过ODBCAPI访问SQL数据库四</名称>
 <类别>数据库</类别>
 <数据来源>NULL</数据来源>
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:11:03</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>ODBC</关键字1>
 <关键字2>API</关键字2>
 <关键字3>SQL</关键字3>
 <内容简介>NULL</内容简介>
 <内容> 　　Declare Function SQLAllocEnv Lib "odbc.dll" (env As Long) As Integer 　　Declare Function SQLFreeEnv Lib "odbc.dll" (ByVal env As Long) As Integer 　　Declare Function SQLAllocConnect Lib "odbc.dll" (ByVal env As Long, ldbc As Long) As Integer 　　Declare Function SQLConnect Lib "odbc.dll" (ByVal ldbc As Long, ByVal Server As String, ByVal serverlen As Integer, ByVal uid As String, ByVal 　　uidlen As Integer, ByVal pwd As String, ByVal pwdlen As Integer) As Integer 　　Declare Function SQLDriverConnect Lib "odbc.dll" (ByVal ldbc As Long, ByVal hWnd As Integer, ByVal szCSIn As String, ByVal cbCSIn As Integer, 　　ByVal szCSOut As String, ByVal cbCSMax As Integer, cbCSOut As Integer, ByVal f As Integer) As Integer 　　Declare Function SQLFreeConnect Lib "odbc.dll" (ByVal ldbc As Long) As Integer 　　Declare Function SQLDisconnect Lib "odbc.dll" (ByVal ldbc As Long) As Integer 　　Declare Function SQLAllocStmt Lib "odbc.dll" (ByVal ldbc As Long, lStmt As Long) As Integer 　　Declare Function SQLFreeStmt Lib "odbc.dll" (ByVal lStmt As Long, ByVal EndOption As Integer) As Integer 　　Declare Function SQLTables Lib "odbc.dll" (ByVal lStmt As Long, ByVal q As Long, ByVal cbq As Integer, ByVal o As Long, ByVal cbo As Integer, 　　ByVal t As Long, ByVal cbt As Integer, ByVal tt As Long, ByVal cbtt As Integer) As Integer 　　Declare Function SQLExecDirect Lib "odbc.dll" (ByVal lStmt As Long, ByVal sqlString As String, ByVal sqlstrlen As Long) As Integer 　　Declare Function SQLNumResultCols Lib "odbc.dll" (ByVal lStmt As Long, NumCols As Integer) As Integer 　　Declare Function SQLDescribeCol Lib "odbc.dll" (ByVal lStmt As Long, ByVal colnum As Integer, ByVal colname As String, ByVal Buflen As Integer, 　　colnamelen As Integer, dtype As Integer, dl As Long, ds As Integer, n As Integer) As Integer 　　Declare Function SQLFetch Lib "odbc.dll" (ByVal lStmt As Long) As Integer 　　Declare Function SQLGetData Lib "odbc.dll" (ByVal lStmt As Long, ByVal col As Integer, ByVal wConvType As Integer, ByVal lpbBuf As String, ByVal 　　dwbuflen As Long, lpcbout As Long) As Integer 　　Declare Function SQLGetInfo Lib "odbc.dll" (ByVal ldbc As Long, ByVal hWnd As Integer, ByVal szInfo As String, ByVal cbInfoMax As 　　Integer,cbInfoOut As Integer) As Integer 　　Declare Function SQLError Lib "odbc.dll" (ByVal env As Long, ByVal ldbc As Long, ByVal lStmt As Long, ByVal SQLState As String, NativeError As 　　Long, ByVal Buffer As String, ByVal Buflen As Integer, Outlen As Integer) As Integer #End If</内容>
 </数据>
- <数据>
 <名称>功能强大的SendMessage函数上</名称>
 <类别>VB文件</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:14:03</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>SendMessag</关键字1>
 <关键字2>函数</关键字2>
 <关键字3>API</关键字3>
 <内容简介 />
 <内容> Windows API（应用程序接口）是Windows系列软件为程序开发人员提供的火力强大的“武器库”，在这个武器库中，有很多极具威力的武器，SendMessage就是其中之一，它的功能非常丰富，灵活使用这个函数，会给编程工作带来很多便利。本文以Visual Basic为例，结合几个具体的例子介绍该函数的功能。 一、SendMeaasge函数简介    顾名思义，SendMessage函数的功能是“发送消息”，即将一条消息发送到指定对象（操作系统、窗口或控件等）上，以产生特定的动作（如滚屏、修改对象外观等）。 SendMessage函数在VB中的函数说明如下： Declare Function SendMessage Lib "user32" Alias "SendMessageA" (Byval hwnd As Long, Byval wMsg As Long,Byval wParam As Long,lParam As Any) As Long 其中四个自变量的含义和说明如下： hWnd：对象的句柄。希望将消息传送给哪个对象，就把该对象的句柄作为实参传送，在VB中可以简单地用“对象.hWnd”获得某个对象的句柄，如Text1.hWnd和Form1.hWnd分别可以得到Text1和Form1的句柄。 wMsg：被发送的消息。根据具体需求和不同的对象，将不同的消息作为实参传送，以产生预期的动作。 wParam、lParam：附加的消息信息。这两个是可选的参数，用来提供关于wMsg消息更多的信息，不同的wMsg可能使用这两个参数中的0、1或2个，如果不需要哪个附加参数，则将实参赋为NULL（在VB中赋为0）。 在简单了解了SendMessage函数的格式和功能后，让我们以几个例子来看看它的威力。 二、SendMessage函数使用实例 例1  多行TextBox中的快速处理功能在处理多行TextBox时我们经常会碰到以下几种情况：    希望了解多行TextBox中目前共有多少行文字。    想快速返回第N行的文字。    对于上面的情况，如果用VB自身的语句或函数来实现的话，要写不短的代码，而且由于要采用顺序查找的办法来完成，因此代码的执行效率也很低。如果使用SendMessage函数则可以大大减少代码量，并大幅度的提高执行效率。    用SendMessage函数完成上面两个任务的方法非常简单，每个任务只需简单地发送一条消息给多行TextBox即可，两个消息分别为：EM_GETLINECOUNT、EM_GETLINE，其它参数和返回值见附表。    下面用一个简单的实例演示这两个功能： 新建工程，在Form1上添加三个TextBox（名称分别为Text1、txtLineCount、TxtString，将Text1的Multi Line属性置为True）、三个标签和一个命令按钮。为工程添加一个模块Moudle1，在其中写如下声明（其中 SendMessage函数的声明可以从VB的“API浏览器”中复制）： 消息常量名 消息值 wParam lParam 返回值  EM_GETLINECOUNT &HBA 未用 未用 行数  EM_GETLINE &HC4 要找的行号 存结果的字节串 结果字节串的字节数  Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long,lParam As Any) As Long Public Const EM_GETLINECOUNT=&HBA Public Const EM_GETLINE=&HC4 在Form1的代码模块中写如下代码：     Private Sub Command1_Click()     Dim str(256) As Byte     str(1)=1 '最大允许存放256个字符     '获取总行数，结果显示在文本框txtLineCount中     txtlineCount=SendMessage(Text1.hwnd,EM_GETLINECOUNT,0,0)     '获取第3行的数据放在str中，转换为字符串后显示在文本框txtString中     SendMessage Text1.hwnd,EM_GETLINE,2,str(0)     txtString= StrConv(str,vbUnicode) End Sub    之后，按F5运行程序，在多行文本框中随便键入几行文字，然后按下[确定]按钮，出现如图画面，说明程序正确统计出了总行数和第3行的文字。 两点补充说明：在调用SendMessage获取第N行字符串时，lParam需要说明为字节数组，在调用完成后，再将字节数组转换为字符串；另外，调用前必须在lParam的前两个字节指明允许存放的最大长度，其中第一个字节为低位，第二个字节为高位，本例将高位（即str(1)）置1．说明最大允许存放256个字符。</内容>
 </数据>
- <数据>
 <名称>功能强大的SendMessage函数中</名称>
 <类别>VB文件</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:14:10</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>SendMessag</关键字1>
 <关键字2>函数</关键字2>
 <关键字3>API</关键字3>
 <内容简介 />
 <内容>例2  程序控制拉下或收起组合框的下拉列来    一般情况下，为了拉下或收起组合框的下拉列表，需要用键盘或鼠标进行操作，而有时我们希望程序运行的某个时刻自动拉出下拉列表（比如在一些演示程序中），为了实现这个目的，我们也只有借助于SendMessage函数，方法是发一个CB_SHOWDROPDOWN(&H14F)消息给组合框。    在发CB_SHOWDROPDOWN消息时，wParam参数决定了是拉下列表（=True时）还是收起列表（＝False时），lParam无用（设为0）。    为说明具体的使用方法，下面提供简单的程序片段。首先在代码模块中做如下声明： 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 CB_SHOWDROPDOWN=&H14F    当程序中某处需要拉下组合框Combol的列表时，写如下调用语句： SendMessage Combol.hwnd,CB_SHOWDROPDOWN,True,0    当需要收起组合框Combol的列表时，写如下语句： SendMessage Combol.hwnd,CB_SHOWDROPDOWNN,False,0 例3  在列表框中查找匹配的项目    在Win95风格的帮助系统中一般都有一个“索引”页，索引页含有一个文本框和一个列表框，当用户在文本框中输入文字时，下拉列表会动态地显示与文本框中文字最匹配的项目，为用户提供了最大的方便。这种效果在应用程序的帮助系统中很容易实现（只要按照Win95帮助系统的正常制作过程制作就可以实现），如果想在应用程序的其它地方实现这种特性就需费一番心思了。    而使用SendMessage函数实现上述特性则非常简单，甚至只需一条语句就足够了，那就是在文本框的Change事件中给列表框发一条LB_FINDSTRING(&H18F）消息，该消息告诉列表框在列表中查找匹配的项目。    在发LB_FINDSTRING消息时，wParam参数代表从列表框的哪一个项目后面开始查找，一般情况下该参数可定为-1，表示从List1(0)即第一项开始向后循环查找，lParam则传进欲搜索的字符串（必须采用值传递）。    具体的代码和运行画面与后面的例4合并在一起演示。 例4  为ListBox添加水平滚动条    在VB中，列表框控件仅提供垂直滚动条，没有设置水平滚动条的能力，当某些项目的文本宽度较长时，超出列表框宽度部分的文本就无法显示出来，因此，很有必要为ListBox添加一个水平滚动条来方便操作。    为添加水平滚动条，只需发一条LB_SETHORIZONTALEXTENT(&H194)消息给列表框即可。发送消息时，wParam为滚动条的长度（以像素为单位，可通过计算得出准确的长度，也可随便给一个大于最大文本宽度的数字，如本例的250），lParam无用。下面是例3和例4合并在一起的代码和运行画面 Declare Function SendMessage Lib "user32" Alias "SendMessageA"(ByVal hwnd As Long,ByVal wMsg As Long,ByVal wParam As Long,lParam As Any) As Long Public Const LB_FINDSTRING=&H18F Public Const LB_SETHORIZONTALEXTENT=&H194 Private Sub Form_Load() List1.AddItem "软件" List1.AddItem "电脑游戏" List1.AddItem "电视机" List1.AddItem "电视台" List1.AddItem "电脑" List1.AddItem "电脑游戏软件" '下一句为列表框添加水平滚动条 SendMessage List1.hwnd,LB_SETHORIZONTALEXTENT,250,0 End Sub Private Sub Text1_Change() '注意！当lParam传入的是字符串时，必须用ByVal传递 List1.ListIndex ＝ SendMessage(List1.hwnd,LB_FINDSTRING,-1,ByVal Text1.Text) End Sub 通过上面几个例子，想必您已经对SendMessage函数的强大功能有了初步的了解。事实上利用该函数我们还可以完成更多更好的任务，如控制文本框的自动滚屏、实现文字编辑过程中的Undo功能、操纵应用程序的窗体控制菜单等等，感兴趣的读者请参阅有关Windows API的资料。 本文程序均用Visual Basic 5.0企业版编写，在Pwin95环境下运行正常。</内容>
 </数据>
- <数据>
 <名称>设置树型列表控件的背景颜色标题行高度</名称>
 <类别>界面</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:18:52</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>树型控件</关键字1>
 <关键字2>背景颜色</关键字2>
 <关键字3>标题行高度</关键字3>
 <内容简介 />
 <内容>首先做如下的定义： Private Declare Function SendMessage Lib "user32" Alias "Send MessageA" (ByVal hwnd As Long,ByVal wMsg As Long, ByVal wParam As Long,ByVal lParam As Long) As Long Const TV－FIRST = ＆H1100 Const TVM－SETBKCOLOR = TV_FIRST ＋ 29 然后再作如下调用： Call SendMessage(TreeView1.hwnd, TVM－SETBKCOLOR, 0, RGB(255, 0, 0)) 上面的SendMessage调用将TreeView1的背景颜色设置为红色。 大家可能注意到了。在上面的Sendmessage函数定义中，我们将lParam定义为 ByVal lParam As Long，而不是象前面的那些范例那样定义为Any或者String类型，关于这个问题，我会在最后的一章中做介绍。 2、设置树型列表控件标题行高度 利用TVM_SETITEMHEIGHT消息可以设定控件的标题行的高度，该消息的定义及调用方法如下： 定义： Const TV_FIRST = ＆H1100 Const TVM－SETITEMHEIGHT = TV_FIRST ＋ 27 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 调用： CallSendMessage(TreeView1.hwnd, TVM－SETITEMHEIGHT, 60, 0) 上面的代码将TreeView1的标题行高度设置到60像素高</内容>
 </数据>
- <数据>
 <名称>为树型列表控件中不同标题行设置不同提示</名称>
 <类别>界面</类别>
 <数据来源 />
 <来源时间>NULL</来源时间>
 <保存时间>2002-01-08 15:19:00</保存时间>
 <删除>False</删除>
 <删除时间>NULL</删除时间>
 <关键字1>树型控件</关键字1>
 <关键字2>标题行</关键字2>
 <关键字3>提示</关键字3>
 <内容简介 />
 <内容>在第一期的ListBox控件介绍中，我向大家介绍了如何为列表中的每一个标题行设置不同的提示(ToolTips)，在这里为要向大家介绍如何为树型列表控件中的每一个标题设置不同的提示。 同ListBox控件不通，树型列表控件中并没有根据光标位置获得标题行索引的消息，我们需要另外想办法。在TVM类消息中有一个TVM_HITTEST消息，发送该消息可以检测控件表面上的某一点，如果该点位于一个标题上，则返回该标题的句柄。而利用TVM_GETITEM消息，则可以根据标题句柄返回该标题行的文本。所以结合利用这两个消息可以获取光标所在标题行的标题文本。具体的范例代码如下： Option Explicit Private Type TPoint x As Long y As Long End Type Private Type TVHITTESTINFO pt As TPoint flags As Long hItem As Long End Type Private Type TVITEM mask As Long HTreeItem As Long state As Long stateMask As Long pszText As Long cchTextMax As Long iImage As Long iSelectedImage As Long cChildren As Long lParam As Long End Type Const TV－FIRST = ＆H1100 Const TVM_HITTEST = TV－FIRST ＋ 17 Const TVM_GETITEM = TV－FIRST ＋ 12 Const TVHT－ONITEMLABEL = ＆H4 Const TVIF－TEXT = ＆H1 Const GMEM－FIXED = ＆H0 Private Declare Function Send MessageRef Lib"user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long,ByVal wParam As Long,lParam As Any) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As String，ByVal Source As Long,ByVal Length As Long) Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long Dim hItemPrv As Long Private Sub Form_Load() Dim ndX As Node `加入若干Item Set ndX = TreeView1.Nodes.Add(, , "R", "Root") Set ndX = TreeView1.Nodes.Add("R", tvwChild, "Key1", "Node1") Set ndX = TreeView1.Nodes.Add("Key1", tvwChild, "SubKey1", "SubNode1") Set ndX = TreeView1.Nodes.Add("SubKey1", tvwChild, "SubKeys1", "SubNode1") Set ndX = TreeView1.Nodes.Add("Key1", tvwChild, "SubKey2", "SubNode2") Set ndX = TreeView1.Nodes.Add("Key1", tvwChild, "SubKey3", "SubNode3") Set ndX = TreeView1.Nodes.Add("Key1", tvwChild, "SubKey4", "SubNode4") End Sub Private Sub TreeView1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)  Dim ptA As TPoint Dim tf As TVHITTESTINFO Dim tv As TVITEM Dim hStr As Long Dim hItem As Long Dim astr As String ＊ 1024 Dim bstr On Error GoTo errLab `获得当前光标所在的位置坐标 ptA.x = Int(x / Screen.TwipsPerPixelX) ptA.y = Int(y / Screen.TwipsPerPixelY) tf.pt = ptA tf.flags = TVHT_ONITEMLABEL `获得光标所在的Item的句柄 hItem = SendMessageRef(TreeView1.hwnd, TVM_HITTEST, 0, tf) `如果未获得句柄或者同上一次是同一个Item的句柄则退出 If ((hItem <= 0) Or (hItem = hItemPrv)) Then Exit Sub hItemPrv = hItem `分配一定的内存空间用以存储Item的标题 hStr = GlobalAlloc(GMEM－FIXED, 1024) If hStr > 0 Then tv.mask = TVIF_TEXT  `获取标题文本 tv.HTreeItem = hItem `Item句柄 tv.pszText = hStr tv.cchTextMax = 1023 `发送TVM_GETITEM获得标题文本 CallSendMessageRef(TreeView1.hwnd, TVM－GETITEM, 0, tv) `将标题文本拷贝到字符串astr中 CopyMemory astr, hStr, 1024 bstr = Left＄(astr, (InStr(astr, Chr(0)) － 1)) TreeView1.ToolTipText = bstr `释放分配的内存空间 GlobalFree hStr End If Exit Sub errLab: Resume Next End Sub 运行上面的程序，当光标在TreeView1上面移动时，TreeView1的ToolTips就会根据光标所在的不同标题行而变动。 以上程序在Win98、Win2000，VB6下运行通过</内容>
 </数据>
泪了，睡觉！