VB入门技巧50例(四)

作者：佚名来源：不详整理日期：2007-4-14

41.如何在小画面上显示大图片
方法一：
一个picturebox控件，一个image控件（以picturebox为容器），图片加载在image中，一个HScroll1，VScroll1（以picturebox为容器）。
Private Sub Bar1_Change()
Image1.Left = -bar1.Value
End Sub

Private Sub Bar2_Change()
Image1.Top = -Bar2.Value
End Sub

Private Sub Form_Load()
Image1.Left = 0
Image1.Top = 0
bar1.SmallChange = 300
Bar2.SmallChange = 300
bar1.Max = Image1.Width - Picture1.Width
Bar2.Max = Image1.Height - Picture1.Height
bar1.Min = 0
Bar2.Min = 0
End Sub

方法二：利用鼠标移动图片
一个picturebox控件，一个image控件（以picturebox为容器），图片加载在image中
Dim ix As Integer
Dim iy As Integer
Private Sub Form_Load()
Image1.Left = 0
Image1.Top = 0
End Sub
Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
ix = X
iy = Y
End If
End Sub
Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim ipx As Integer
Dim ipy As Integer
If Button = vbLeftButton Then
ipx = Image1.Left + X - ix
ipy = Image1.Top + Y - iy
If ipx > 0 Then
Image1.Left = 0
Else
If ipx < Picture1.Width - Image1.Width Then
ipx = Picture1.Width - Image1.Width
Else
Image1.Left = ipx
End If
End If
If ipy > 0 Then
Image1.Top = 0
Else
If ipy < Picture1.Height - Image1.Height Then
ipy = Picture1.Height - Image1.Height
Else
Image1.Top = ipy
End If
End If
End If
End Sub
Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.MousePointer = 0
End Sub

42. 使窗体不出屏幕左边界
module:
Option Explicit
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) 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 Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Public Const GWL_WNDPROC = (-4)
Public Const WM_WINDOWPOSCHANGING = &H46
Type WINDOWPOS
hwnd As Long
hWndInsertAfter As Long
x As Long
y As Long
cx As Long
cy As Long
flags As Long
End Type
Public preWinProc As Long
而重点就在於Window重新定位之前会传
出WM_WINDOWPOSCHANGING这个讯息，而lParam指向一个WINDOWPOS的STRUCTURE。
Public Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lwd As Long, hwd As Long
If Msg = WM_WINDOWPOSCHANGING Then
Dim WPOS As WINDOWPOS
CopyMemory WPOS, ByVal lParam, Len(WPOS)
If WPOS.x < 0 Then
WPOS.x = 0
CopyMemory ByVal lParam, WPOS, Len(WPOS)
End If
End If
将之送往原来的Window Procedure
wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
End Function
窗体中
Sub Form_Load()
Dim ret As Long
记录原本的Window Procedure的位址
preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf wndproc)
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim ret As Long
取消Message的截取，而使之又只送往原来的Window Procedure
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc)
End Sub

43.打开指定的窗体
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const SW_SHOWNORMAL = 1
Private Sub Command1_Click() 我的文档
ShellExecute Me.hwnd, "open", "explorer", vbNullString, vbNullString, 1
End Sub
Private Sub Command2_Click() 我的电脑
ShellExecute Me.hwnd, "open", "explorer", "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}", vbnulstring, 1
End Sub
Private Sub Command3_Click() 网上邻居
ShellExecute Me.hwnd, "open", "explorer", "::{208d2c60-3aea-1069-a2d7-08002b30309d}", vbNullString, 1
End Sub
Private Sub Command4_Click() 回收站
ShellExecute Me.hwnd, "open", "explorer", "::{645ff040-5081-101b-9f08-00aa002f954e}", vbNullString, 1
End Sub
Private Sub Command5_Click() 控制面板
ShellExecute Me.hwnd, "open", "explorer", "::{21ec2020-3aea-1069-a2dd-08002b30309d}", vbNullString, 1
End Sub
Private Sub Command6_Click() 打开指定的路径
ShellExecute Me.hwnd, "open", "D:\vb练习事例", vbNullString, vbNullString, 1
End Sub
Private Sub Command7_Click() 音量控制
Shell "sndvol32.exe", vbNormalFocus
End Sub

44.窗体分割条

splitter为一picturebox控件。
Option Explicit
Private Const SPLT_WDTH As Integer = 35
Private currSplitPosX As Long
Dim CTRL_OFFSET As Integer
Dim SPLT_COLOUR As Long
Private Sub Form_Load()
CTRL_OFFSET = 5
SPLT_COLOUR = &H808080
currSplitPosX = &H7FFFFFFF
ListLeft.AddItem "VB俱乐部"
ListLeft.AddItem "VB动画篇"
ListLeft.AddItem "VB网络篇"
ListLeft.AddItem "VB控件类"
ListLeft.AddItem "VB界面类"
TextRight = "经常见到窗体上有二个相邻的列表框，可以用鼠标任意拉动中间分割条，改变列表框大小。"
End Sub
Private Sub Form_Resize()
Dim x1 As Integer
Dim x2 As Integer
Dim height1 As Integer
Dim width1 As Integer
Dim width2 As Integer
On Error Resume Next
height1 = ScaleHeight - (CTRL_OFFSET * 2)
x1 = CTRL_OFFSET
width1 = ListLeft.Width
x2 = x1 + ListLeft.Width + SPLT_WDTH - 1
width2 = ScaleWidth - x2 - CTRL_OFFSET
ListLeft.Move x1% - 1, CTRL_OFFSET, width1, height1
TextRight.Move x2, CTRL_OFFSET, width2 + 1, height1
Splitter.Move x1 + ListLeft.Width - 1, CTRL_OFFSET, SPLT_WDTH, height1
End Sub
Private Sub Splitter_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
Splitter.BackColor = SPLT_COLOUR
currSplitPosX = CLng(X)
Else
If currSplitPosX <> &H7FFFFFFF Then Splitter_MouseUp Button, Shift, X, Y
currSplitPosX = &H7FFFFFFF
End If
End Sub
Private Sub Splitter_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If currSplitPosX& <> &H7FFFFFFF Then
If CLng(X) <> currSplitPosX Then
Splitter.Move Splitter.Left + X, CTRL_OFFSET, SPLT_WDTH, ScaleHeight - (CTRL_OFFSET * 2)
currSplitPosX = CLng(X)
End If
End If
End Sub
Private Sub Splitter_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If currSplitPosX <> &H7FFFFFFF Then
If CLng(X) <> currSplitPosX Then
Splitter.Move Splitter.Left + X, CTRL_OFFSET, SPLT_WDTH, ScaleHeight - (CTRL_OFFSET * 2)
End If
currSplitPosX = &H7FFFFFFF
Splitter.BackColor = &H8000000F
If Splitter.Left > 60 And Splitter.Left < (ScaleWidth - 60) Then
ListLeft.Width = Splitter.Left - ListLeft.Left
ElseIf Splitter.Left < 60 Then
ListLeft.Width = 60
Else
ListLeft.Width = ScaleWidth - 60
End If
Form_Resize
End If

End Sub

44.托盘程序
module:
Option Explicit
Public preWinProc As Long
Public NewForm As Form
Public NewMenu As Menu
Public Const WM_USER = &H400
Public Const WM_LBUTTONUP = &H202
Public Const WM_MBUTTONUP = &H208
Public Const WM_RBUTTONUP = &H205
Public Const TRAY_CALLBACK = (WM_USER + 1001&)
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIF_MESSAGE = &H1
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
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
Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Private NOTI As NOTIFYICONDATA
Public Function NewWindone(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = TRAY_CALLBACK Then

If lParam = WM_LBUTTONUP Then
单击左键，弹出窗口
If NewForm.WindowState = vbMinimized Then _
NewForm.WindowState = NewForm.LastState
NewForm.SetFocus
Exit Function
End If
If lParam = WM_RBUTTONUP Then
单击右键，弹出菜单
NewForm.PopupMenu NewMenu
Exit Function
End If
End If
NewWindone = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
End Function
Public Sub AddToTray(frm As Form, mnu As Menu)
Set NewForm = frm
Set NewMenu = mnu
preWinProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf NewWindone)
With NOTI
.uID = 0
.hwnd = frm.hwnd
.cbSize = Len(NOTI)
.hIcon = frm.Icon.Handle
.uFlags = NIF_ICON
.uCallbackMessage = TRAY_CALLBACK
.uFlags = .uFlags Or NIF_MESSAGE
.cbSize = Len(NOTI)
End With
Shell_NotifyIcon NIM_ADD, NOTI
End Sub
屏蔽托盘
Public Sub RemoveFromTray()
With NOTI
.uFlags = 0
End With
Shell_NotifyIcon NIM_DELETE, NOTI
SetWindowLong NewForm.hwnd, GWL_WNDPROC, preWinProc
End Sub

Public Sub SetTrayTip(tip As String)
With NOTI
.szTip = tip & vbNullChar
.uFlags = NIF_TIP
End With
Shell_NotifyIcon NIM_MODIFY, NOTI
End Sub

Public Sub SetTrayIcon(pic As Picture)
If pic.Type <> vbPicTypeIcon Then Exit Sub
With NOTI
.hIcon = pic.Handle
.uFlags = NIF_ICON
End With
Shell_NotifyIcon NIM_MODIFY, NOTI
End Sub
窗体中

Private Sub Form_Load()
AddToTray Me, Tray
SetTrayTip "托盘演示"
End Sub
Private Sub Form_Unload(Cancel As Integer)
RemoveFromTray
End Sub

【相关文章】