Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal 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
返回

在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("E:\cli.bmp")
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("e:\cli2.BitMap")

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 "user32" (ByVal hwnd As Long) As Long
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Declare Function GetMenuCheckMarkDimensions Lib "user32" () As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
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 StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
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("e:\cli.bmp")
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("e:\cli.bmp")
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 "user32" (lpRect As Any) As Long
Declare Function ClipCursorClear Lib "user32" Alias "ClipCursor" (ByVal lpRect As Long) As Long
Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
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 事件来补充 MouseMove 事件的不足（MouseMove 事件不能有效的捕获鼠标是否已在控件外），但是这些控件或要注册，或集合了其他实际没有什么作用控件，另外在程序中加入太多的控件也会影响程序的性能，利用 Windows 的 API 函数，我们可以在 MouseMove 中模拟 MouseEnter 和 MouseExit，虽然我提供的源代码中没有真正的这两个事件，但的确提供了这两个事件所具备的功能。好了！让我们实现吧。

首先加载一个模块，在模块中声明以下两个 API 函数：

Public Declare Function SetCapture Lib "user32" _
(ByVal hwnd As Long) As Long
Public Declare Function ReleaseCapture Lib "user32" () As Long

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 <> "outside" Then
.Caption = "outside"
End If

'鼠标指针在按钮上，捕获他但鼠标移出是我们将收到鼠标事件
SetCapture .hwnd

Else
.Caption = "inside"
End If
End With
End Sub
返回

我们一般是用鼠标按住窗口的标题栏，然后移动窗口，当窗口没有标题栏时，我们可以用下面的方法来移动窗口：
在 BAS 文件中声明：
Declare Function ReleaseCapture Lib "user32" () 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 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 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) <> "\" Then

filePath = App.Path & "\"

Else

filePath = App.Path

End If

'窗体初始显示由Tiles.bmp基本图案组成的背景

pictfile = "c:\windows\Tiles.bmp"

backpict (pictfile)

End Sub

　

7.退出程序命令按钮

　

Private Sub SSCommand1_Click()

End

End Sub

　

8.演示不同的底纹图案

　

Private Sub SSCommand2_Click()

'两种背景图案交替演示

If pictfile = filePath & "Pict1.bmp" Then

pictfile = "c:\windows\Tiles.bmp"

Else

pictfile = filePath & "Pict1.bmp"

End If

Backpict (pictfile)

End Sub
返回

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 "In KeyPress"
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 "user32" (ByVal hwnd&, ByVal nIndex&, ByVal wNewWord&) As Long
Private lngOrigParenthWnd&

Sub Command1_click
form2.Show

End Sub
返回

Back to top