BarTender ActiveX 在Delphi和VB下调用数据库的实例

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 键

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，虽然我提供的源代码中没有真正的这两个事件，但的确提供了这两个事件所具备的功能。好了！让我们实现吧。

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返回值相减有可能得到负值).

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

本文来源：https://www.bwwdw.com/article/e8tv.html