BarTender ActiveX 在Delphi和VB下调用数据库的实例(转贴)
BarTender ActiveX封装了大量的函数和属性，其中包括对数据库的调用。下面通过在Delphi和VB下的实例给出其调用方法。 先看Delphi的例子。
1. 首先打开BarTender生成一个标签，并正确添加数据库，设置其子串共享名为domain1。
2. 打开Delphi，创建一个工程。
3. 声明全局变量btapp，btformat，btdb。 4. 在FormCreate过程中引用BarTender。
btapp:=createoleobject('Bartender.application.7'); btapp.visible:=false;
５．向窗体中加入一个button，设置其Caption值为“打印”，其name为“print”，为其click过程添加代码：
btformat:=btapp.formats.open('d:\\bartender\\format1.btw', true, ''); btdb:= btformat.databases.item(1); btformat.printout(0,0); btformat.close(1);
6. 向FormCloseQuery中加入代码： try
btapp.quit(1) except
application.terminate end;
７．保存并运行。 源代码如下:
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, DB, OleCtrls, DBOleCtl, BARCODELib_TLB, ComObj,OleCtnrs, ExtCtrls, ComCtrls, DBCtrls;
type
TForm1 = class(TForm) print: TButton; Label1: TLabel;
procedure FormCreate(Sender: TObject); procedure printClick(Sender: TObject); private
{ Private declarations } public
{ Public declarations } btapp:variant; btformat:variant; btdb:variant; end;
var
Form1: TForm1; implementation {$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject); begin
btapp:=createoleobject('Bartender.application.7'); btapp.visible:=false; end;
procedure TForm1.printClick(Sender: TObject); begin
btformat:=btapp.formats.open('d:\\bartender\\format1.btw', true, ''); btdb:= btformat.databases.item(1); btformat.printout(0,0); btformat.close(1); end;
procedure TForm1.FormCloseQuery(Sender: Tobject; CanClose: Boolean); begin try
btapp.quit(1) except
application.terminate end; end; end.
下面我们再通过一个简单的例子说明BarTender ActiveX在VB下如何调用数据库，因此在此例中我们直接为format1.btw指定了数据库域，并指定了文件存放的路径。 1. 首先打开BarTender生成一个标签，并正确添加数据库，设置其子串共享名为domain1。
2. 在VB中新建一个工程，保存。“工程|引用”中选中BarTender7.0，然后打开代码窗口，选择“通用/声明”，添加下列声明：
Dim btapp As BarTender.Application Dim btformat As BarTender.Format Dim btdb As BarTender.Database
3. 在“Form/Load”中加入代码： Private Sub Form_Load()
Set btapp = CreateObject(\ btapp.Visible = False End Sub
4. 在对象窗口向Form中放入一个Command按钮，其Caption属性赋为“打印”，name属性为“print” ，双击为其添加代码： Private Sub print_Click()
Set btformat = btapp.Formats.Open(\ Set btdb = btformat.Databases(1)
'Set btdb = btformat.Databases.Item(1) 'Set btdb = btformat.Databases(\ btformat.PrintOut End Sub
5. 在“Form/Unload”中添加： btapp.Quit
按F5运行，单击打印按钮，通过连接的打印机即可打印所需的标签。
VB 中的文本框输入完后按ENTER键就触发下一事件那个叫什么过程?
Private Sub Text1_KeyPress(KeyAscii As Integer) If KeyAscii = 13 Then MsgBox \ End If End Sub
KeyAscii
KeyAscii是键盘输入后传递给程序的ASCII码，关于ASCII码，各种电脑书籍一般都有附录，网络上搜索也很多。
常规ASCII码是0～127，一般可以显示的是32～127
关于KeyAscii的使用，主要是拦截判断键盘输入的键值，比如，只允许输入数字，就可以在文本框的KeyPress中输入：
If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0 KeyAscii键码 常数 值 描述
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 键
VB中防止将重复项目添加到列表框控件中
2000-09-04· ·谭翁··VB编程乐园
isualBasic的列表框控件中包含项目的列表，本文介绍如何检查列表中项目是否已 经存在，以及如何将新的项目添加到列表框控件中。
使用SendMessage函数搜寻重复的项目
在VisualBasic中开发应用程序时，可以使用列表框控件来创建一个项目的列表。要将 新的项目添加到列表中，可以使用AddItem方法，该方法不能自动地报告在列表框控件中是否 有重复的信息存在，所以必须在将新项目添加到列表之前首先检查一下。
可以通 过使用Windows应用程序编程接口（API）的SendMessage函数来在列表框控件中搜寻指定的项 目，它函数允许向操作系统中发送消息。在本文的例子里，我们让SendMessage函数往列表框 控件中执行一个LB_FINDSTRING消息。 LB_FINDSTRING消息允许在一个列表框控 件中搜索同目标字符串相匹配的项目。该消息的第一个参数是希望进行的搜索类型，须将该 值设为0，表示从列表框控件中的第一个项目开始搜索。第二个参数是一个NULL结束的字符串， 它是实际希望搜索的项目。
如果该LB_FINDSTRING消息返回值-1，则表明在列表 框控件中没有找到目标字符串，此时可以使用AddItem方法来将新的项目添加到列表框控件 中。如果该项目已经在列表中存在，则可以简单地显示一个信息框或是执行一些其它的过程， 来通知用户一个重复的项目已经在列表框控件中存在。
样例程序
该程序显示了如何确定在一个列表框控件中是否已经包含了一个要添加到控件中的项 目。
1.在VisualBasic中开始一个新的工程，采用缺省的方法建立Form1。
2.将如下常量和声明语句添加到Form1的通用声明部分中（注意该声明语句需要被书 写在一行内）：
PrivateDeclareFunctionSendMessageFindLib\(ByValhwndAsLong,ByValwMsgAsLong,ByValwParamAsInteger,ByVallParam AsString)AsLong
ConstWM_USER=&H400 ConstLB_ERR=(-1)
ConstLB_FINDSTRING=&H18F
3.将如下代码添加到Form1的Form_Load 事件中： PrivateSubForm_Load() List1.AddItem\List1.AddItem\
List1.AddItem\List1.AddItem\EndSub
4.在Form1上添加一个文本框控件，采用缺省的方法建立Text1。 5.在Form1上添加一个列表框控件，采用缺? 方法建立List1。
6.在Form1上添加一个命令按钮控件，采用缺省的方法建立Command1，将起Caption属 性设置为“重复”。
7.将如下代码添加到Command1的单击事件中： PrivateSubCommand1_Click() CheckForDupes EndSub
8.创建一个新的名为CheckForDupes的函数，将如下代码添加到该函 数中： SubCheckForDupes() DimRetAsLong DimAAsString A=Text1.TEXT
Ret=SendMessageFind(List1.hwnd,LB_FINDSTRING,0,(A)) IfRet=LB_ERRThen
List1.AddItemText1.TEXT Else
List1.ListIndex=Ret
MsgBox\重复项目－不能被添加到列表框中\错误\EndIf EndSub
按下F5键来执行本程序。在列表框控件中有5个项目。在文本框控件中 键入一个新的项目，单击重复命令按钮。程序将在列表框控件中搜索刚刚键入到文本框控件 中的项目。如果该项目未被找到，则程序将把该项目添加到列表框控件中。相反，如果该项目 已经在列表框中存在了，则将显示出一个信息框以通知项目已经存在。
使整个屏幕变暗，如同关机画面 Private Type RECT Left As Long Top As Long Right As Long Bottom As Long
End Type
Private Declare Function GetDC Lib \
Private Declare Function ReleaseDC Lib \Private Declare Function CreatePatternBrush Lib \
Private Declare Function PatBlt Lib \nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long Private Declare Function DeleteObject Lib \
Private Declare Function CreateBitmap Lib \nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SelectObject Lib \Private Declare Function InvalidateRect Lib \bErase As Long) As Long
Private bybits(1 To 16) As Byte
Private hBitmap As Long, hBrush As Long Private hDesktopWnd As Long '将图变暗，如同待关机一般 Private Sub Command1_Click() Dim rop As Long, res As Long
Dim hdc5 As Long, width5 As Long, height5 As Long
'如果只要让Picture1有效果将底下叁行unMark取代 hdc5, width5, height5叁个值 'hdc5 = Picture1.hdc
'width5 = Picture1.ScaleWidth 'height5 = Picture1.ScaleHeight
'底下叁行设定整个萤幕都暗下来 hdc5 = GetDC(0)
width5 = Screen.Width \\ Screen.TwipsPerPixelX height5 = Screen.Height \\ Screen.TwipsPerPixelY
rop = &HA000C9 '与原图做and运算 Call SelectObject(hdc5, hBrush)
res = PatBlt(hdc5, 0, 0, width5, height5, rop) Call DeleteObject(hBrush)
'如果只暗picture1则底下这一行要mark起来 res = ReleaseDC(0, hdc5) End Sub '回复原本的画面
Private Sub Command2_Click() Dim aa As Long
'如果只暗picture1则底下这一行要unMark起来 'Picture1.Refresh
'如果只暗picture1则底下这一行要mark起来 aa = InvalidateRect(0, 0, 1) End Sub
Private Sub Form_Load() Dim ary Dim i As Long
ary = Array(&H55, &H0, &HAA, &H0, _ &H55, &H0, &HAA, &H0, _ &H55, &H0, &HAA, &H0, _ &H55, &H0, &HAA, &H0) For i = 1 To 16 bybits(i) = ary(i - 1) Next i
hBitmap = CreateBitmap(8, 8, 1, 1, bybits(1)) hBrush = CreatePatternBrush(hBitmap) Picture1.ForeColor = RGB(0, 0, 0) Picture1.BackColor = RGB(255, 255, 255) Picture1.ScaleMode = 3 End Sub 返回
有 BitMap 之Menu
在Window API中，有一些名词要先清楚，假设有一功能表如下：
档案 编辑 选项 --> hMenu (功能表) +-------+
|复制 |---------> hSubMenu (子功能表) |贴上 |
|减下 -------------> MenuID (功能表项目) | | +-------+
如果，我们使用vb的功能表编辑器做出上面的Menu，那 hMenu的取得使用GetMenu() API ，而hSubMenu 的取得是 GetSubMenu，而GetSubMenu()的第二个参数指的是功能表的第 几个子功能表，以上例来说，编辑子功能表是第1个子功能表(以0为基准)，所以编辑子 功能表的取得应用以下的呼叫 ：
hMenu = GetMenu(Me.hwnd)
hSubMenu = GetSubMenu(hMenu, 1) '取得编辑子功能表的hSubMenu
而功能表项目则由以下的呼叫取得，第二参数指的是该子功能表的第几个项目(以0 开始)，故复制 功能表项目 = 0 减下 = 2
MenuId = GetMenuItemID(hSubMenu, 0) '取得复制 的hMenuId
接着便是以ModifyMenu来更动MenuId成BitMap的方式
Set Pic1 = LoadPicture(\
ModifyMenu hSubMenu, 0, MF_BITMAP Or MF_BYPOSITION, MenuId, pic1.Handle
ModifyMenu 第二个参数 表示更动hSubMenu所指的子功能表中第几个功能表项目 第叁个参数 MF_BITMAP 表示用BitMap的方式显示 MF_STRING 表示用字串方式显示
MF_BYPOSITION 表示第二个参数的值代表是依位置来算 第四个参数 MenuId
第五个参数 显示图的hBitMap
另外，如何做到MenuItem的左方有一小Bitmap，右方仍是字串呢，使用以下的API
SetMenuItemBitmaps(
hSubMenu as Long , // handle of 子功能表 uItem as Long , // 更动第几个Menu Item fuFlags as Long, // menu item flags
hbmUnchecked as Long, // handle of unchecked bitmap hbmChecked as Long // handle of checked bitmap )
Set Pic2 = LoadPicture(\
Call SetMenuItemBitmaps(hSubMenu, 1, MF_BYPOSITION,pic2.Handle, Pic2.Handle)
这里有一个地方要特别注意，到底hbmUnchecked/hbmchecked 所指的BitMap图有多大呢， 如果pic2所放入的BitMap太大，那不会出现我们想要的图，那得自己想办法缩图；而使 用以下的API可以取得Menu Item左边Bitmap图的大小(By Pixels)
i = GetMenuCheckMarkDimensions wd5 = i Mod 2 ^ 16 '宽 hi5 = i / 2 ^ 16 '高
而我们Load进来的图之宽 Me.ScaleX(pic2.Width, vbHimetric, vbPixels) 高 Me.ScaleY(pic2.Height, vbHimetric, vbPixels)
於是呢，我写了一个GetBitMapHandle 来取得hbmUnchecked/hbmchecked所需的BitMap Handle，而且该hBitMap所指的图，大小刚好是系统内定的大小，而不必在乎原始的图 有多大，当然了，一定要使用BitMap图，不可使用icon/gif等之类的图，这是什麽原 因呢，这是因为我使用StdPicture物件来开启图形档，如果图形档是BitMap图，那麽，
stdPicture物件的Handle属性便是hBitmap。
'以下在.bas Option Explicit
Public Const MF_BYCOMMAND = &H0& Public Const MF_BYPOSITION = &H400& Public Const MF_BITMAP = &H4& Public Const MF_STRING = &H0&
Declare Function GetMenu Lib \
Declare Function GetSubMenu Lib \Declare Function DeleteDC Lib \
Declare Function GetMenuItemID Lib \Declare Function ModifyMenu Lib \Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
Declare Function SetMenuItemBitmaps Lib \wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long Declare Function GetMenuCheckMarkDimensions Lib \
Declare Function CreateCompatibleBitmap Lib \nHeight As Long) As Long
Declare Function CreateCompatibleDC Lib \
Declare Function SelectObject Lib \Declare Function DeleteObject Lib \
Declare Function StretchBlt Lib \ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, _
ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Const SRCCOPY = &HCC0020 Public TheForm As Form
Public Function GetBitMapHandle(ByVal FileName As String) Dim dstWidth As Long, dstHeight As Long Dim srcWidth As Long, srcHeight As Long Dim x As Long, y As Long Dim pic As New StdPicture Dim hDc5 As Long, i As Long Dim hBitmap As Long Dim hDstDc As Long
Set pic = LoadPicture(FileName) '读取图形档 hDc5 = CreateCompatibleDC(0) '建立Memory DC
i = SelectObject(hDc5, pic.Handle) '在该memoryDC上放上bitmap图
i = GetMenuCheckMarkDimensions '取得SetMenuItemBitmaps 所需Bitmap大小 dstWidth = i Mod 2 ^ 16 dstHeight = i / 2 ^ 16
'建一个大小为dstWidh * dstHeight大小的Bitmap
hBitmap = CreateCompatibleBitmap(TheForm.hdc, dstWidth, dstHeight) hDstDc = CreateCompatibleDC(TheForm.hdc) '建memory dc
'设该memory dc的绘图区大小=该bitmap大小，且在该memory dc上的绘图便是在 '该bitmap图上画图 SelectObject hDstDc, hBitmap
srcHeight = TheForm.ScaleY(pic.Height, vbHimetric, vbPixels) srcWidth = TheForm.ScaleX(pic.Width, vbHimetric, vbPixels)
Call StretchBlt(hDstDc, 0, 0, dstWidth, dstHeight, hDc5, 0, 0, srcWidth, srcHeight, SRCCOPY) GetBitMapHandle = hBitmap Call DeleteDC(hDc5) Call DeleteDC(hDstDc) End Function
'以下在Form Option Explicit Private hMenu As Long Private hSubMenu As Long Private MenuId As Long Private pic1 As New StdPicture Private pic2 As New StdPicture Dim hBitmap As Long
Private Sub Form_Load() Set TheForm = Me
Set pic1 = LoadPicture(\hMenu = GetMenu(Me.hwnd) hSubMenu = GetSubMenu(hMenu, 1) MenuId = GetMenuItemID(hSubMenu, 1)
ModifyMenu hSubMenu, 0, MF_BITMAP Or MF_BYPOSITION, MenuId, pic1.Handle hBitmap = GetBitMapHandle(\
Call SetMenuItemBitmaps(hSubMenu, 1, MF_BYPOSITION, hBitmap, hBitmap) End Sub
Private Sub Form_Unload(Cancel As Integer) DeleteObject hBitmap
End Sub 返回
怎样限制鼠标移动
本文介绍如何限制鼠标在窗口的指定范围内移动。这个技术在需要防止用户鼠标在指定区域内活动时非常 有用。例如在一个射击游戏中，需要限制鼠标在射击区内移动。 操作步骤
1、建立一个新工程项目，缺省建立窗体FORM1 2、添加一个新模体 3、粘贴下面代码到新模体
Option ExplicitDeclare Function ClipCursor Lib \
Declare Function ClipCursorClear Lib \Declare Function ClientToScreen Lib \Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Type POINTAPI X As Long Y As Long End Type
Public RetValue As Long Public ClipMode As Boolean
Public Sub SetCursor(ClipObject As Object, Setting As Boolean) ' used to clip the cursor into the viewport and ' turn off the default windows cursor
Dim CurrentPoint As POINTAPI Dim ClipRect As RECT
If Setting = False Then ' set clip state back to normal RetValue = ClipCursorClear(0) Exit Sub End If
' set current position With CurrentPoint .X = 0 .Y = 0 End With
' find position on the screen (not the window)
RetValue = ClientToScreen(ClipObject.hwnd, CurrentPoint) ' designate clip area With ClipRect .Top = CurrentPoint.Y .Left = CurrentPoint.X
.Right = .Left + ClipObject.ScaleWidth .Bottom = .Top + ClipObject.ScaleHeight End With ' clip it
RetValue = ClipCursor(ClipRect) End Sub
4、添加一个图片框控件（PICTURE1）到窗体（FORM1） 5、设置PICTURE1的尺寸和FORM1的一样大 6、在PICTURE1的CLICK事件中添加以下代码：
Private Sub Picture1_Click() ClipMode = Not ClipMode SetCursor Picture1, ClipMode End Sub
7、保存工程项目
8、运行程序。在图片框单击鼠标，鼠标将被包含在图片框控件的区域内。要释放限制状态只需再次单击鼠标。
注意：如果释放限制状态失败，鼠标将被永久限制，只能用重新启动机器来解决。 另一个限制鼠标活动范围的方法是关闭鼠标，用其他图象代替光标，例如手枪。 返回
自己编程模拟 MouseEnter,MouseExit 事件
很多第三方的控件都提供的 MouseEnter 和 MouseExit 事件来补充 MouseMove 事件的不足（MouseMove 事件不能有效的捕获鼠标是否已在控件外），但是这些控件或要注册，或集合了其他实际没有什么作用控件，另外在程序中加入太多的控件也会影响程序的性能，利用 Windows 的 API 函数，我们可以在 MouseMove 中模拟 MouseEnter 和 MouseExit，虽然我提供的源代码中没有真正的这两个事件，但的确提供了这两个事件所具备的功能。好了！让我们实现吧。
首先加载一个模块，在模块中声明以下两个 API 函数：
Public Declare Function SetCapture Lib \(ByVal hwnd As Long) As Long
Public Declare Function ReleaseCapture Lib \
SetCapture 的功能是：设置鼠标捕获指定的窗口（Windows 每个控件都是一个窗口。比如桌面上显示的图标就是一个窗口，其实是两个，另一个显示描述这个图标的文本），系统将收到这个窗口所有的鼠标移动或击按的所有信息。
ReleaseCapture 的功能是：取消捕获鼠标信息。
Windows 系统就是一个消息系统，系统一直在等待用户的消息，并加一相应，但处理完一个消息后，系统有处以下一轮的等待。消息传递是 Windows 的核心。
让我们在 Form1 中放置一个按钮或其他控件，但此控件必须具有窗口句柄（hWnd），比如 VB 提供的 Image 控件是一个次图形控件，没有窗口句柄，而 Picture，Command Button 等控件就有窗口句柄，我们就拿 Command Button 来作示范，在 Form1 上放置一个 Command Button，在 Command1_MouseMove()事件内加入以下代码：
Private Sub Command1_MouseMove(Button As Integer, _ Shift As Integer, X As Single, Y As Single) With Command1
'当鼠标在越出控件外 If Not ((X < 0) Or (Y < 0) Or _ (X > .Width) Or (Y > .Height)) Then
'鼠标指针在按钮外时，让其他控件也收到标事件 ReleaseCapture
'为了不让 MouseMove 事件反复触发 If .Caption <> \.Caption = \End If
'鼠标指针在按钮上，捕获他但鼠标移出是我们将收到鼠标事件 SetCapture .hwnd Else
.Caption = \End If End With
End Sub 返回
移动没有标题栏的窗口
我们一般是用鼠标按住窗口的标题栏，然后移动窗口，当窗口没有标题栏时，我们可以用下面的方法来移动窗口：
在 BAS 文件中声明：
Declare Function ReleaseCapture Lib \\As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1 然后，在 Form_MouseDown 事件中：
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ReleaseCapture SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& End Sub 返回
Visual Basic窗体背景花纹的实现
我们在开发软件过程中，为提高软件的商品化程度，感觉到界面的美观程度是一个软件能否获得成功的一个重要因素，我们仔细研究了一些成功的商品化软件，从这些软件上可以看到,程序窗口背景能显示出非常美丽的、富有立体感的花纹。而采用Visual Basic 3.0或4.0进行窗体设计，若只按照系统提供的功能，只能从有限的几种颜色中选择一种颜色或采用程序绘制一些简单的线条。而想实现立体感很强的纹理图案，一般只能采用窗体的PICTURE属性调用位图文件，使用这种方法实现有许多缺点 ,其一是窗体大小受位图大小的限制，调整起来麻烦，不具有通用性和灵活性；其二是浪费资源，因为花纹图案基本上是重复图案，采用与窗体同样大小的位图是一种浪费。
下面介绍一种窗体背景花纹实现的方法。在窗体上建立一个网格控件，设定网格行不可见，去掉固定行和固定列，用程序实现网格控件与窗体同样大小，并随窗体大小的改变而改变。然后设计一个花纹图案，形成BMP位图文件(本文程序使用文件Pict1.bmp)，或者从其它图象中截取一段图案,也可以利用Windows系统提供的图案（如c:\\windows\\Tiles.bmp)，将其调入Picture控件。设定网格的每个单元与该图案大小相同，使单元的数量正好覆盖整个窗体背景，再将所有单元均显示该图案。通过子程序Backpict()实现以上过程，不论图案大小、窗体大小，程序都能自动调整网格控件大小和网格单元大小及单元数量。该程序在Visual Basic 4.0上调试成功。
1.新建窗体Form1,属性如下：
Caption =“背景花纹的实现”
Borderstyle=3(无最大、最小化按钮）
2.建网格控件Grid1,它的位置和大小将在程序中设置（与Form1同样大）,属性为：
Enabled = False（焦点不会落在网格控件Grid1上）
Fillstyle=1（改变所有单元Text特性）
Fixedcols=0（无固定行）
Fixedrows=0（无固定列）
Gridlines = False（网格行不可见），
Visible = True
3.建立图象控件Picture1,程序运行时将背景花纹基本图案放入其中，属性为
Visible = False（不可见）
Autosize = True（自动调整大小）
4.控件中加入Sheridan 3D Controls,选取其中的三维命令按钮SSCommand,建立两个按钮
SSCommand1.Caption=“退出”
SSCommand2.Caption=“更换背景”（演示不同的背景图案）
它们的属性Picture可调用与背景相同或不同的图案，如果使用普通的命令按钮控件Command也可，只是命令按钮无背景图案。
5.建立背景图案形成子程序：
Dim pictfile As String '位图文件名
Dim FILEPATH As String '文件路径
Sub Backpict(pictfile)
picture1.ScaleMode = 3
Form1.ScaleMode = 3
picture1.Picture = LoadPicture(pictfile)
'网格控件覆盖整个窗体背景
grid1.Top = -1
grid1.Left = -1
grid1.Width = Width
grid1.Height = Height
grid1.Cols=Int(Form1.ScaleWidth/picture1.ScaleWidth) + 1
grid1.Rows=Int(Form1.ScaleHeight/picture1.ScaleHeight) + 1
'所有单元大小等于基本图案大小
For i = 0 To grid1.Cols - 1
For j = 0 To grid1.Rows - 1
grid1.ColWidth(i) = picture1.ScaleWidth * 15
grid1.RowHeight(j) = picture1.ScaleHeight * 15 Next j Next I
'选定所有单元
grid1.SelStartCol = 0
grid1.SelStartRow = 0
grid1.SelEndCol = grid1.Cols - 1
grid1.SelEndRow = grid1.Rows - 1
grid1.Picture = Picture1.Picture End Sub
6.窗体主程序
Private Sub Form_Load()
Private Sub Form_Load()
'得到运行程序路径名，路径名后带反斜杠
If Right(App.Path, 1) <> \
filePath = App.Path & \ Else
filePath = App.Path End If
'窗体初始显示由Tiles.bmp基本图案组成的背景
pictfile = \
backpict (pictfile) End Sub
7.退出程序命令按钮
Private Sub SSCommand1_Click() End End Sub
8.演示不同的底纹图案
Private Sub SSCommand2_Click()
'两种背景图案交替演示
If pictfile = filePath & \
pictfile = \ Else
pictfile = filePath & \ End If
Backpict (pictfile) End Sub 返回
如何在 MIDForm 中控制 KeyPress 事件?
MDIForm 中是没有 KeyPress 事件的， 而在 MDIForm 中加入的 Picture 有， 那么只要在 MDIForm 中动手脚：
Private Sub MDIForm_Activate() Picture1.SetFocus End Sub
Private Sub MDIForm_Click() Picture1.SetFocus End Sub
Private Sub Picture1_KeyPress(KeyAscii As Integer) Debug.Print \End Sub 返回
建立无模式窗口
'make a new project; two forms 'on form1 a command button 'put the code in the right places 'press F5
Sub Form2_load() 'in the form2_load event
'be sure to make the form2 smaller then form1!
lngOrigParenthWnd = SetWindowWord(Me.hwnd, -8, mdiMain.hwnd) End Sub
Private Sub Form_Unload(Cancel As Integer) 'in the form2_unload event Dim lngResult&
lngResult = SetWindowWord(Me.hwnd, -8, lngOrigParenthWnd) End Sub
'in the form2_general section
Private Declare Function SetWindowWord Lib \As Long
Private lngOrigParenthWnd&
Sub Command1_click form2.Show End Sub
vb sendmessage 用法
在Windows编程中，向文本框控件、列表控件、按钮控件等是我们最常接触的控件了。但是在VB中这些控件有时无法实现我们的需要。在这时，我们只要简单的利用Windows API函数就可以扩充这些控件的功能了。
顾名思义，SendMessage函数就是向窗口（这里的窗口指的是向按钮、列表框、编辑框等具有hWnd属性的控件）发送消息的函数，该函数的定义如下:
Declare Function SendMessage Lib \(ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) As Long
其中hwnd指定接受消息的窗口，参数wMsg指定消息值，参数wParam lParam分别定义传递到窗口的附加参数。而在Windows系统的很多消息中，有一些不仅仅是提供一个窗口消息那么简单。它们可以控制窗口的动作和属性。下面我将分次向向大家介绍SendMessage函数在扩充基本控件功能方面的应用。 一、列表（ListBox）控件
在Windows中，有一系列的以LB_开头的列表消息，这里介绍的就是利用LB消息控制的ListBox的应用
1、使列表中光标移动到不同的列表项上有不同的提示（ToolTip） 在列表框控件中有一个ToolTipText属性，该属性决定了当光标在列表框上移动时出现的提示文字。但是如何使得当光标在不同的列表项上移动时的提示文字也不同呢？问题的关键是要知道在光标移动时光标所在的列表项的索引，使用SendMessage函数发送LB_ITEMFROMPOINT消息就可以获得。下面是程序范例： Option Explicit
Const LB_ITEMFROMPOINT = &H1A9
Private Declare Function SendMessage Lib \(ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) As Long Private Sub Form_Load() Dim i
For i = 1 To 200
List1.AddItem Str(i) + \Next i End Sub
Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lXPoint As Long Dim lYPoint As Long Dim lIndex As Long
If Button = 0 Then '确定在移动鼠标的同时没有按下功能键或者鼠标键 '获得光标的位置，以像素为单位
lXPoint = CLng(X / Screen.TwipsPerPixelX) lYPoint = CLng(Y / Screen.TwipsPerPixelY) '
With List1
'获得 光标所在的标题行的索引
lIndex = SendMessage(.hwnd, LB_ITEMFROMPOINT, 0, _ ByVal ((lYPoint * 65536) + lXPoint))
'将ListBox的Tooltip设置为该标题行的文本 If (lIndex >= 0) And (lIndex <= .ListCount) Then
.ToolTipText = .List(lIndex) 'Return the text = .list(lIndex) Else
.ToolTipText = \End If End With End If End Sub
首先在Form1中加入一个ListBox控件，然后再将上面的代码加入到Form1的代码窗口中。运行程序，当光标在列表中移动时，可以看到根据光标所在的不同的列表项，提示文字也不相同。
2、向列表中加入横向滚动条使得可以浏览长列表项 当向列表中加入的列表项超出了列表的显示范围后，列表并不会出现横向滚动条让你可以通过滚动来浏览项目的全部内容。利用LB_SETHORIZONTALEXTENT消息可以设置列表的横向滚动条以及滚动长度。下面是范例程序： Option Explicit Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type
Private Declare Function DrawText Lib \(ByVal hdc As Long, _ ByVal lpStr As String, _ ByVal nCount As Long, _
lpRect As RECT, _
ByVal wFormat As Long) As Long
Private Declare Function SendMessage Lib \(ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) As Long
Const LB_SETHORIZONTALEXTENT = &H194 Const DT_CALCRECT = &H400
Public Function ListTextWidth(ByRef lstThis As ListBox) As Long Dim i As Long Dim tR As RECT Dim lW As Long Dim lWidth As Long Dim lHDC As Long With lstThis.Parent.Font .Name = lstThis.Font.Name .Size = lstThis.Font.Size .Bold = lstThis.Font.Bold .Italic = lstThis.Font.Italic End With
lHDC = lstThis.Parent.hdc
'便历所有的列表项以找到最长的项 For i = 0 To lstThis.ListCount - 1
DrawText lHDC, lstThis.List(i), -1, tR, DT_CALCRECT lW = tR.Right - tR.Left + 8 If (lW > lWidth) Then lWidth = lW End If Next i
'返回最长列表项的长度（像素） ListTextWidth = lWidth End Function
Private Sub Form_Load() Dim astr As String Dim i
Dim l As Long
l = List1.FontSize * 20 / Screen.TwipsPerPixelX For i = 1 To 10
astr = astr + \我们This is a very long item \Next i
List1.AddItem astr + \'加入一个很长的列表项 l = ListTextWidth(List1)
SendMessage List1.hwnd, LB_SETHORIZONTALEXTENT, l, 0 End Sub
首先在Form1中加入一个ListBox控件，然后再将上面的代码加入到Form1的代码窗口中。运行程序，可以看到列表中出现了横向滚动条，而且滚动范围正好是列表项的长度。 3、使列表可以响应用户击键
有时我们需要列表根据用户的敲入字符串自动调整列表的ListIndex到最接近的列表项，就象VB中动态感应用户输入控件属性的编辑器一样。问题的关键是如何在列表中查找含有指定字符串的列表项，使用LB_FINDSTRING消息可以在列表中查找指定字符串。下面是范例：
Private Declare Function SendMessageStr Lib \(ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _
ByVal lParam As String) As Long Const LB_FINDSTRING = &H18F Dim astr As String
Private Sub Form_KeyPress(KeyAscii As Integer) Dim l As Long
astr = astr + Chr(KeyAscii)
l = SendMessageStr(List1.hwnd, LB_FINDSTRING, -1, astr) If l Then
List1.ListIndex = l End If End Sub
Private Sub Form_Load() '向List中加入列表项 For i = 65 To 85 For j = 65 To 85
List1.AddItem Chr(i) + Chr(j) Next j
Next i End Sub
Private Sub List1_DblClick() '清除原来的查找字符串 astr = \End Sub
Private Sub List1_KeyPress(KeyAscii As Integer) '如果按下的是字母键就将击键消息传递到Form1
If ((KeyAscii >= 65 And KeyAscii <= 90) Or (KeyAscii >= 97 _ Or KeyAscii <= 122)) Then KeyAscii = 0 End If End Sub
首先在Form1中加入一个ListBox控件，然后再将上面的代码加入到Form1的代码窗口中。并将List1的Sorted属性设置为True。运行程序，在列表中敲入字符，例如\，列表就会高亮显示相近的列表项，双击列表就可以清除原来的输入。
在上一篇文章中我向大家介绍了关于ListBox类控件消息的应用，在这一章我将向大家介绍如何利用消息操控TextBox类控件。
1、获得光标所在的行和列
一般的比较完善的文本编辑器一般都有在状态栏中显示当前光标所在行和列的功能。利用SendMessage向TextBox控件发送编辑控件类型消息。也可以实现这样的功能。下面首先来看程序，然后再分析。
首先在VB中建立一个新工程，并在Form1中加入一个TextBox控件和两个Label控件。将TextBox控件的MultiLine属性设置为True。然后在Form1的代码窗口中加入如下代码： Option Explicit
Private Declare Function SendMessage Lib \(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _ lParam As Any) As Long
Private Declare Function SendMessageByRef Lib \(ByVal hwnd As Long, ByVal wMsg As Long, wParam As Long, _ lParam As Long) As Long
Const EM_LINEFROMCHAR = &HC9 Const EM_LINEINDEX = &HBB Const EM_GETLINE = &HC4 Const EM_GETSEL = &HB0 Dim iLineX, iLineY As Long
Sub GetCurPos(txtA As TextBox) Dim l, l1, l2 As Long Dim astr As String * 256
l = SendMessage(txtA.hwnd, EM_LINEINDEX, -1, 0)
iLineY = SendMessage(txtA.hwnd, EM_LINEFROMCHAR, l, 0) SendMessageByRef txtA.hwnd, EM_GETSEL, l1, l2 iLineX = l1 - l
Label1.Caption = \列：\Label2.Caption = \行：\End Sub
Private Sub Form_Load() Dim iFile
Dim astr As String
Label1.Height = 300: Label2.Height = 300 Text1.Left = 0: Text1.Top = 0 Text1.Text = \
Label1.Caption = \Label2.Caption = \
iFile = FreeFile
Open \Do
Line Input #iFile, astr
Text1.Text = Text1.Text + astr + vbCrLf Loop Until EOF(iFile) Close iFile End Sub
Private Sub Form_Resize()
Label1.Top = Me.ScaleHeight - 300 Label2.Top = Me.ScaleHeight - 300 Label1.Left = 0: Label2.Left = 1200 Label1.Width = 1200 Label2.Width = 1200
Text1.Width = Me.ScaleWidth
Text1.Height = Me.ScaleHeight - Label1.Height End Sub
Private Sub Text1_Click() GetCurPos Text1 End Sub
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer) GetCurPos Text1 End Sub
在运行程序前，确保在你的硬盘上有 c:\\windows\\readme.txt 这个文件。否则程序会出错。然后运行程序。当在编辑文本时，可以看到在窗口底部可以显示当前光标所在的行、列值。在上面的程序中。我们首先发送EM_LINEINDEX消息，发送该消息可以返回某一行的第一个字符在整个文本控件中的位置，如果wParam参数设置为-1，则返回当前行的字符位置。然后发送EM_LINEFROMCHAR，发送该消息可以根据参数wParam指定的字符位置返回该字符所在的行号，文本第一行的位置为0。这样使用这两个消息就获得当前光标所在的行号。要取得列号，首先发送EM_GETSEL消息，发送该消息返回当前被选中文本的起始位置，如果没有文本被选中，则返回当前光标所在字符在文本中的位置。由于上面的
EM_LINEINDEX消息返回的是当前行的第一个字符在文本中的位置。所以将两值相减，就是光标所在字符的列位置。在上面的程序中，如果你的文本中有中文字符的话，当你的光标在中文字符中移动一个位置，你会看到标签中的列位置增加了2，这是由于SendMessage发送的消息所得到的结果是不支持中文的，它将一个中文字算做两个字符。这也算是程序中的一个Bug吧（这也就是为什么我要使用EM_GETSEL消息而不直接使用TextBox控件的SelStart属性来获取光标所在字符位置了，因为如果使用SelStart返回的值将一个中文算一个字符，同EM_LINEINDEX返回值相减有可能得到负值).