实现托盘程序的例子
Private Sub Form_Load()
If WindowState = vbMinimized Then
LastState = vbNormal
Else
LastState = WindowState
End If
AddToTray Me, mnuTray
SetTrayTip "VB Helper tray icon program"
End Sub
' Enable the correct tray menu items.
Private Sub Form_Resize()
Select Case WindowState
Case vbMinimized
mnuTrayMaximize.Enabled = True
mnuTrayMinimize.Enabled = False
mnuTrayMove.Enabled = False
mnuTrayRestore.Enabled = True
mnuTraySize.Enabled = False
Case vbMaximized
mnuTrayMaximize.Enabled = False
mnuTrayMinimize.Enabled = True
mnuTrayMove.Enabled = False
mnuTrayRestore.Enabled = True
mnuTraySize.Enabled = False
Case vbNormal
mnuTrayMaximize.Enabled = True
mnuTrayMinimize.Enabled = True
mnuTrayMove.Enabled = True
mnuTrayRestore.Enabled = False
mnuTraySize.Enabled = True
End Select
If WindowState <> vbMinimized Then _
LastState = WindowState
End Sub
' Important! Remove the tray icon.
Private Sub Form_Unload(Cancel As Integer)
RemoveFromTray
End Sub
Private Sub mnuFileExit_Click()
Unload Me
End Sub
Private Sub mnuTrayClose_Click()
Unload Me
End Sub
Private Sub mnuTrayMaximize_Click()
WindowState = vbMaximized
End Sub
Private Sub mnuTrayMinimize_Click()
WindowState = vbMinimized
End Sub
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
'模块部份
Option Explicit
Public OldWindowProc As Long
Public TheForm As Form
Public TheMenu As Menu
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 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
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 TheData As NOTIFYICONDATA
' *********************************************
' The replacement window proc.
' *********************************************
Public Function NewWindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = TRAY_CALLBACK Then
' The user clicked on the tray icon.
' Look for click events.
If lParam = WM_LBUTTONUP Then
' On left click, show the form.
If TheForm.WindowState = vbMinimized Then _
TheForm.WindowState = TheForm.LastState
TheForm.SetFocus
Exit Function
End If
If lParam = WM_RBUTTONUP Then
' On right click, show the menu.
TheForm.PopupMenu TheMenu
Exit Function
End If
End If
' Send other messages to the original
' window proc.
NewWindowProc = CallWindowProc( _
OldWindowProc, hwnd, Msg, _
wParam, lParam)
End Function
' *********************************************
' Add the form's icon to the tray.
' *********************************************
Public Sub AddToTray(frm As Form, mnu As Menu)
' ShowInTaskbar must be set to False at
' design time because it is read-only at
' run time.
' Save the form and menu for later use.
Set TheForm = frm
Set TheMenu = mnu
' Install the new WindowProc.
OldWindowProc = SetWindowLong(frm.hwnd, _
GWL_WNDPROC, AddressOf NewWindowProc)
' Install the form's icon in the tray.
With TheData
.uID = 0
.hwnd = frm.hwnd
.cbSize = Len(TheData)
.hIcon = frm.Icon.Handle
.uFlags = NIF_ICON
.uCallbackMessage = TRAY_CALLBACK
.uFlags = .uFlags Or NIF_MESSAGE
.cbSize = Len(TheData)
End With
Shell_NotifyIcon NIM_ADD, TheData
End Sub
' *********************************************
' Remove the icon from the system tray.
' *********************************************
Public Sub RemoveFromTray()
' Remove the icon from the tray.
With TheData
.uFlags = 0
End With
Shell_NotifyIcon NIM_DELETE, TheData
' Restore the original window proc.
SetWindowLong TheForm.hwnd, GWL_WNDPROC, _
OldWindowProc
End Sub
' *********************************************
' Set a new tray tip.
' *********************************************
Public Sub SetTrayTip(tip As String)
With TheData
.szTip = tip & vbNullChar
.uFlags = NIF_TIP
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Sub
' *********************************************
' Set a new tray icon.
' *********************************************
Public Sub SetTrayIcon(pic As Picture)
' Do nothing if the picture is not an icon.
If pic.Type <> vbPicTypeIcon Then Exit Sub
' Update the tray icon.
With TheData
.hIcon = pic.Handle
.uFlags = NIF_ICON
End With
Shell_NotifyIcon NIM_MODIFY, TheData
End Sub作者: winggd 时间: 2004-3-22 11:24 标题: vb实例
屏蔽系统热键
Const SPI_SCREENSAVERRUNNING = 97
Private Declare Function SystemParametersInfo Lib "User32" Alias _
"SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As _
Any, ByVal fuWinIni As Long) As Long
Private Sub Command1_Click()
Dim pOld As Boolean
Call SystemParametersInfo(SPI_SCREENSAVERRUNNING, True, pOld, 0)
End Sub
Private Sub Command2_Click()
Dim pOld As Boolean
Call SystemParametersInfo(SPI_SCREENSAVERRUNNING, False, pOld, 0)
End Sub
Private Sub Form_Load()
End Sub作者: winggd 时间: 2004-3-22 11:27 标题: vb实例
使用AppendMenu添加菜单并且相应Click事件
Private Sub Form_Load()
Dim mSysMenu As Long
Dim mMenu As Long
Dim mSubMenu As Long
OldWinProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
End Sub
Private Sub Open_Click()
MsgBox "打开"
End Sub
Public mAddItemId As Long
Public mFileId As Long
Public mSaveId As Long
Public OldWinProc As Long
Public Const MF_STRING = &H0&
Public Const MF_DISABLED = &H2&
Public Const MF_SEPARATOR = &H800&
Public Const MF_CHECKED = &H8&
Public Const MF_GRAYED = &H1&
Public Const GWL_WNDPROC = (-4)
Public Const WM_COMMAND = &H111
Public Const WM_SYSCOMMAND = &H112
Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Declare Function AppendMenu1 Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public 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
Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
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
Public Function NewWindowProc(ByVal inHWND As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = WM_COMMAND Then
If wParam = mFileId Then
MsgBox "文件"
Exit Function
End If
ElseIf Msg = WM_SYSCOMMAND Then
If wParam = mAddItemId Then
ShellExecute 0, "open", "http://majifeng.topcool.net", vbNullString, vbNullString, vbNormalFocus
Exit Function
End If
End If
NewWindowProc = CallWindowProc(OldWinProc, inHWND, Msg, wParam, lParam)
End Function
Private Sub Form_Load()
Dim mSysMenu As Long
Dim mMenu As Long
Dim mSubMenu As Long
OldWinProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
End Sub
Private Sub Open_Click()
MsgBox "打开"
End Sub
Public mAddItemId As Long
Public mFileId As Long
Public mSaveId As Long
Public OldWinProc As Long
Public Const MF_STRING = &H0&
Public Const MF_DISABLED = &H2&
Public Const MF_SEPARATOR = &H800&
Public Const MF_CHECKED = &H8&
Public Const MF_GRAYED = &H1&
Public Const GWL_WNDPROC = (-4)
Public Const WM_COMMAND = &H111
Public Const WM_SYSCOMMAND = &H112
Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Declare Function AppendMenu1 Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public 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
Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
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
Public Function NewWindowProc(ByVal inHWND As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = WM_COMMAND Then
If wParam = mFileId Then
MsgBox "文件"
Exit Function
End If
ElseIf Msg = WM_SYSCOMMAND Then
If wParam = mAddItemId Then
ShellExecute 0, "open", "http://majifeng.topcool.net", vbNullString, vbNullString, vbNormalFocus
Exit Function
End If
End If
NewWindowProc = CallWindowProc(OldWinProc, inHWND, Msg, wParam, lParam)
End Function作者: winggd 时间: 2004-3-22 11:28 标题: vb实例
调用打开和保存对话框
Private Sub Form_Load()
End Sub
Private Sub mnuFileExitApp_Click()
On Error GoTo mnuFileExitApp_Click_Error
Unload Me
End
mnuFileExitApp_Click_Exit:
Exit Sub
mnuFileExitApp_Click_Error:
MsgBox "Error: " & Format$(Err) & " " & Error$, , "mnuFileExitApp_Click"
Resume mnuFileExitApp_Click_Exit
End Sub
Private Sub mnuFileOpenDialog_Click()
On Error GoTo mnuFileOpenDialog_Click_Error
Dim file As OPENFILENAME, sFile As String, sFileTitle As String, lResult As Long, iDelim As Integer
file.lStructSize = Len(file)
file.hwndOwner = Me.hWnd
file.flags = OFN_HIDEREADONLY + OFN_PATHMUSTEXIST + OFN_FILEMUSTEXIST
'wildcard to display, returns with selected path\file
file.lpstrFile = "*.exe" & String$(250, 0)
file.nMaxFile = 255
'returns with just file name
file.lpstrFileTitle = String$(255, 0)
file.nMaxFileTitle = 255
'set the initial directory, otherwise uses current
file.lpstrInitialDir = Environ$("WinDir")
'file type filter
file.lpstrFilter = "Programs" & Chr$(0) & "*.EXE;*.COM;*.BAT" & Chr$(0) & "MS Word Documents" & Chr$(0) & "*.DOC" & Chr$(0) & Chr$(0)
file.nFilterIndex = 1
'dialog title
file.lpstrTitle = "Open"
lResult = GetOpenFileName(file)
If lResult <> 0 Then
iDelim = InStr(file.lpstrFileTitle, Chr$(0))
If iDelim > 0 Then
sFileTitle = Left$(file.lpstrFileTitle, iDelim - 1)
End If
iDelim = InStr(file.lpstrFile, Chr$(0))
If iDelim > 0 Then
sFile = Left$(file.lpstrFile, iDelim - 1)
End If
'file.nFileOffset is the number of characters from the beginning of the
' full path to the start of the file name
'file.nFileExtension is the number of characters from the beginning of the
' full path to the file's extention, including the (.)
MsgBox "File Name is " & sFileTitle & Chr$(13) & Chr$(10) & "Full path and file is " & sFile, , "Open"
End If
mnuFileOpenDialog_Click_Exit:
Exit Sub
mnuFileOpenDialog_Click_Error:
MsgBox "Error: " & Format$(Err) & " " & Error$, , "mnuFileOpenDialog_Click"
Resume mnuFileOpenDialog_Click_Exit
End Sub
Private Sub mnuFileSaveAsDialog_Click()
On Error GoTo mnuFileSaveAsDialog_Click_Error
Dim file As OPENFILENAME, sFile As String, sFileTitle As String, lResult As Long, iDelim As Integer
file.lStructSize = Len(file)
file.hwndOwner = Me.hWnd
file.flags = OFN_HIDEREADONLY + OFN_PATHMUSTEXIST + OFN_OVERWRITEPROMPT
'If you have a starting file name, put it here, padded with Chr$(0) to make
'a buffer large enough for return
file.lpstrFile = String$(255, 0)
file.nMaxFile = 255
'returns with just file name
file.lpstrFileTitle = String$(255, 0)
file.nMaxFileTitle = 255
'set the initial directory, otherwise uses current
file.lpstrInitialDir = Environ$("WinDir")
'file type filter
file.lpstrFilter = "Text Files" & Chr$(0) & "*.TXT" & Chr$(0) & Chr$(0)
file.nFilterIndex = 1
'dialog title
file.lpstrTitle = "Save As…"
'you can provide a default extension; appended if user types none
file.lpstrDefExt = "TXT"
lResult = GetSaveFileName(file)
If lResult <> 0 Then
'file.nFileOffset is the number of characters from the beginning of the
' full path to the start of the file name
'file.nFileExtension is the number of characters from the beginning of the
' full path to the file's extention, including the (.)
iDelim = InStr(file.lpstrFileTitle, Chr$(0))
If iDelim > 0 Then
sFileTitle = Left$(file.lpstrFileTitle, iDelim - 1)
End If
iDelim = InStr(file.lpstrFile, Chr$(0))
If iDelim > 0 Then
sFile = Left$(file.lpstrFile, iDelim - 1)
End If
MsgBox "File Name is " & sFileTitle & Chr$(13) & Chr$(10) & "Full path and file is " & sFile, , "Save As…"
End If
mnuFileSaveAsDialog_Click_Exit:
Exit Sub
mnuFileSaveAsDialog_Click_Error:
MsgBox "Error: " & Format$(Err) & " " & Error$, , "mnuFileSaveAsDialog_Click"
Resume mnuFileSaveAsDialog_Click_Exit
End Sub
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer
Public Const OFN_READONLY = &H1
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_SHOWHELP = &H10
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOLONGNAMES = &H40000 ' force no long names for 4.x modules
Public Const OFN_EXPLORER = &H80000 ' new look commdlg
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_LONGNAMES = &H200000 ' force long names for 3.x modules
Public Const OFN_SHAREFALLTHROUGH = 2
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREWARN = 0作者: winggd 时间: 2004-3-22 11:29 标题: vb实例
窗体启动特效
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
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 Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Sub FormEffect(f As Form, Movement As Integer)
Dim myRect As RECT
Dim formWidth%, formHeight%, I%, X%, Y%, Cx%, Cy%
Dim TheScreen As Long
Dim Brush As Long
GetWindowRect f.hwnd, myRect '获得窗体四角的坐标
'计算窗体的高与宽
formWidth = myRect.Right - myRect.Left
formHeight = myRect.Bottom - myRect.Top
'得到屏幕的设备描述表句柄
TheScreen = GetDC(0)
'创建实色画刷
Brush = CreateSolidBrush(f.BackColor)
'将创建的画刷选入设备描述表中
SelectObject TheScreen, Brush
'从小到大依次绘制矩形，直到与窗体大小相同为止
For I = 1 To Movement
Cx = formWidth * (I / Movement)
Cy = formHeight * (I / Movement)
X = myRect.Left + (formWidth - Cx) / 2
Y = myRect.Top + (formHeight - Cy) / 2
Rectangle TheScreen, X, Y, X + Cx, Y + Cy
Next I
'释放
X = ReleaseDC(0, TheScreen)
'从内存中删除创建的画刷
DeleteObject (Brush)
End Sub
Public Sub ImplodeForm(f As Form, Direction As Integer, Movement As Integer, ModalState As Integer)
Dim myRect As RECT
Dim formWidth%, formHeight%, I%, X%, Y%, Cx%, Cy%
Dim TheScreen As Long
Dim Brush As Long
For I = Movement To 1 Step -1
Cx = formWidth * (I / Movement)
Cy = formHeight * (I / Movement)
X = myRect.Left + (formWidth - Cx) / 2
Y = myRect.Top + (formHeight - Cy) / 2
Rectangle TheScreen, X, Y, X + Cx, Y + Cy
Next I
X = ReleaseDC(0, TheScreen)
DeleteObject (Brush)
End Sub
Private Sub Form_Load()
FormEffect Me, 3000
End Sub作者: winggd 时间: 2004-3-22 11:30 标题: vb实例
使窗体的关闭按钮无效
Private Declare Function GetSystemMenu Lib "User32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "User32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemCount Lib "User32" (ByVal hMenu As Long) As Long
Private Const MF_BYPOSITION = &H400&
Private Sub Command1_Click()
DisableClose Me
End Sub
Private Sub DisableClose(Frm As Form)
Dim hMenu As Long, nCount As Long
'获取系统菜单的句柄
hMenu = GetSystemMenu(Frm.hwnd, 0)
'得到系统菜单的菜单项目
nCount = GetMenuItemCount(hMenu)
'将关闭按钮置为无效
Call RemoveMenu(hMenu, nCount - 1, MF_BYPOSITION)
'重画系统菜单
DrawMenuBar Frm.hwnd
End Sub
Private Sub Command2_Click()
End
End Sub作者: winggd 时间: 2004-3-22 11:30 标题: vb实例
制作屏幕保护程序
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Sub Form_load()
'form1窗体大小、位置与屏幕重合
Form1.Width = Screen.Width
Form1.Height = Screen.Height
Form1.Left = 0
Form1.Top = 0
'图片框的窗体大小、位置与屏幕重合
Picture1.Width = Screen.Width
Picture1.Height = Screen.Height
Picture1.Left = 0
Picture1.Top = 0
'隐藏鼠标
ShowCursor False
'将整屏画面抓到图片框中
ScreenhWnd = GetDesktopWindow()
ScreenDC = GetDC(ScreenhWnd)
BitBlt Picture1.hdc, I, j, Picture1.ScaleWidth, Picture1.ScaleHeight, ScreenDC, 0, 0, vbSrcCopy
ReleaseDC ScreenhWnd, ScreenDC
Form1.Show
'左右移动图片框
While True
Picture1.Left = Picture1.Left + 1
'超出窗体右边则重新回到最左边
If Picture1.Left > Form1.Width Then
Picture1.Left = -Form1.Width
End If
DoEvents '响应其它事件
Wend
End Sub
'点击鼠标结束滚幕
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
End
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
End
End Sub
Private Sub Form_Unload(Cancel As Integer)
'显示鼠标
ShowCursor True
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
End
End Sub作者: winggd 时间: 2004-3-22 11:31 标题: vb实例
为窗体添加透明阴影
Form1内容
Private Sub Form_Load()
Init frmShadow, Form1, Form1.Left, Form1.Top, Form1.Width, Form1.Height
Call Hook(Me.hwnd)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call UnHook(Me.hwnd)
Unload frmShadow
End Sub
Form2内容
Option Explicit
Private Sub Form_Activate()
Form1.Zorder 0
End Sub
'设置图片框与窗体一样大
Private Sub Form_Resize()
picShadow.Left = 0
picShadow.Top = 0
picShadow.Width = Me.ScaleWidth
picShadow.Height = Me.ScaleHeight
End Sub
'模块部份
Option Explicit
Private Declare Function CreateDC Lib "Gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare Function BitBlt Lib "Gdi32.dll" (ByVal hDestDC 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 dwRop As Long) As Long
Private Declare Function DeleteDC Lib "Gdi32.dll" (ByVal hdc As Long) As Long
Public 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
Public Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC = -4
Private Const WM_MYMSG = &H232
Private Const WM_MOVE = &H3
Private Const WM_SIZE = &H5
Private Const SIZE_MINIMIZED = 1
Public defWndProc As Long
Public Sub Init(ShadowFrm As Form, Frm As Form, iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer)
Dim IsLoad As Boolean
On Error Resume Next
With ShadowFrm
.Visible = False
.ScaleMode = 3 'Pixel
.Left = iLeft + 90
.Top = iTop + 90
.Width = iWidth
.Height = iHeight
CaptureScreen ShadowFrm, ShadowFrm.picShadow
.Visible = True
End With
Form1.Zorder 0
End Sub
Private Sub CaptureScreen(Frm As Form, Pic As PictureBox)
Dim hDCscr As Long
Pic.Cls
'创建屏幕句柄
hDCscr = CreateDC("DISPLAY", "", "", 0)
'将屏幕拷贝的图片框中
BitBlt Pic.hdc, 0, 0, Frm.Width, Frm.Height, hDCscr, Frm.Left / Screen.TwipsPerPixelX, Frm.Top / Screen.TwipsPerPixelX, vbSrcErase
Pic.Refresh
'删除创建的句柄
DeleteDC hDCscr
End Sub
Public Sub Hook(hwnd As Long)
If defWndProc = 0 Then
defWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End If
End Sub
Public Sub UnHook(hwnd As Long)
If defWndProc > 0 Then
Call SetWindowLong(hwnd, GWL_WNDPROC, defWndProc)
defWndProc = 0
End If
End Sub
'自定义窗口过程
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg
'改变窗口的大小
Case WM_SIZE
'窗口被最小化
If wParam = SIZE_MINIMIZED Then
'隐藏阴影窗体
frmShadow.Hide
Else
'重新产生阴影效果
Init frmShadow, Form1, Form1.Left, Form1.Top, _
Form1.Width, Form1.Height
End If
'移动或改变窗体大小
Case WM_MYMSG
frmShadow.Hide
DoEvents
Init frmShadow, Form1, Form1.Left, Form1.Top, _
Form1.Width, Form1.Height
Case Else
'其他消息由默认窗口过程处理
WindowProc = CallWindowProc(defWndProc, hwnd, uMsg, wParam, _
lParam)
End Select
End Function作者: winggd 时间: 2004-3-22 11:32 标题: vb实例
历史记录
Option Explicit
Dim A_Name As String
Dim S_Name As String
Const MaxRFiles = 4
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Command2_Click()
ClearRecentFiles
End Sub
Private Sub Command3_Click()
Text1 = GetSetting(A_Name, S_Name, "File0", "")
Text2 = GetSetting(A_Name, S_Name, "File1", "")
Text3 = GetSetting(A_Name, S_Name, "File2", "")
Text4 = GetSetting(A_Name, S_Name, "File3", "")
Text5 = GetSetting(A_Name, S_Name, "FirstFile", "")
End Sub
Private Sub Form_Load()
A_Name = "Demo"
S_Name = "Rfile"
ReadRecentFiles
End Sub
Private Sub mExit_Click()
Unload Me
End Sub
Private Sub mLastFile_Click(Index As Integer)
UpdateRecentFiles Index
End Sub
Private Sub mOpen_Click()
Dim fIndex As Integer
On Error Resume Next
CommonDialog2.CancelError = True ' Causes a trappable error to occur when the user hits the 'Cancel' button
CommonDialog2.DialogTitle = "打开文件"
CommonDialog2.FileName = ""
CommonDialog2.Filter = "Executables(*.*)|*.*"
CommonDialog2.FilterIndex = 1
CommonDialog2.Flags = cdlOFNCreatePrompt + cdlOFNHideReadOnly
CommonDialog2.ShowOpen
If Err = cdlCancel Then ' 'Cancel' button was hit
' Add your own code here when the user hits the 'Cancel' button
Else
fIndex = InRecentFiles(CommonDialog2.FileName)
If fIndex > MaxRFiles Then
WriteRecentFiles CommonDialog2.FileName
Else
UpdateRecentFiles fIndex
End If
End If
End Sub
Private Sub WriteRecentFiles(FileName As String)
Dim fileptr As Integer
If Len(Trim(FileName)) Then
fileptr = Val(GetSetting(A_Name, S_Name, "FirstFile", "0"))
fileptr = Iif(fileptr - 1 >= 0, fileptr - 1, MaxRFiles - 1)
SaveSetting A_Name, S_Name, "FirstFile", fileptr & ""
SaveSetting A_Name, S_Name, "File" & fileptr, FileName
ReadRecentFiles
End If
End Sub
Private Sub ReadRecentFiles()
Dim I As Integer
Dim fileptr As Integer
Dim rFile As String
Dim rCount As Integer
'第一个文件的位置
fileptr = Val(GetSetting(A_Name, S_Name, "FirstFile", "0"))
rFile = GetSetting(A_Name, S_Name, "File" & fileptr, "")
rCount = 0
Do While Len(rFile) And rCount < MaxRFiles
mLastFile(rCount).Caption = "&" & (rCount + 1) & " " & rFile
mLastFile(rCount).Visible = True
fileptr = Iif(fileptr + 1 < MaxRFiles, fileptr + 1, 0)
rFile = GetSetting(A_Name, S_Name, "File" & fileptr, "")
rCount = rCount + 1
Loop
If rCount = 0 Then
mLastFile(rCount).Visible = True
mLastFile(rCount).Caption = "无历史文件"
rCount = 1
End If
For I = rCount To MaxRFiles - 1
mLastFile(I).Visible = False
Next
End Sub
Private Function InRecentFiles(strFile As String) As Integer
Dim I As Integer
Dim bFound As Boolean
'Look for the file specified in strFile
For I = 0 To MaxRFiles - 1
If mLastFile(I).Visible And strFile = Mid$(mLastFile(I).Caption, 4) Then
InRecentFiles = I
Exit Function
End If
Next
InRecentFiles = MaxRFiles + 1
End Function
Public Sub ClearRecentFiles()
On Error Resume Next
Dim I As Integer
DeleteSetting A_Name, S_Name, "FirstFile"
For I = 0 To MaxRFiles
DeleteSetting A_Name, S_Name, "File" & I
Next
mLastFile(0).Visible = True
mLastFile(0).Caption = "无历史文件"
For I = 1 To MaxRFiles - 1
mLastFile(I).Visible = False
Next
End Sub
Public Sub UpdateRecentFiles(fIndex As Integer)
Dim I As Integer
Dim fileptr As Integer, FirstPtr As Integer
Dim FilePtr1 As Integer
Dim rFile As String, OldFile As String
Dim rCount As Integer
If fIndex = 0 Then Exit Sub
'第一个文件的位置
FirstPtr = Val(GetSetting(A_Name, S_Name, "FirstFile", "0"))
'FirstPtr = Iif(FirstPtr - 1 >= 0, FirstPtr - 1, MaxRFiles - 1)
If fIndex = MaxRFiles - 1 Then
FirstPtr = Iif(FirstPtr - 1 >= 0, FirstPtr - 1, MaxRFiles - 1)
SaveSetting A_Name, S_Name, "FirstFile", CStr(FirstPtr)
ReadRecentFiles
Exit Sub
End If
fileptr = fIndex + FirstPtr
If fileptr >= MaxRFiles Then fileptr = fileptr - MaxRFiles
OldFile = GetSetting(A_Name, S_Name, "File" & fileptr, "")
FilePtr1 = Iif(fileptr - 1 >= 0, fileptr - 1, MaxRFiles - 1)
'FilePtr1 = Iif(fileptr + 1 < MaxRFiles, fileptr + 1, 0)
rFile = GetSetting(A_Name, S_Name, "File" & FilePtr1, "")
Do While FirstPtr <> fileptr And Len(rFile) > 0
SaveSetting A_Name, S_Name, "File" & fileptr, rFile
fileptr = FilePtr1
FilePtr1 = Iif(fileptr - 1 >= 0, fileptr - 1, MaxRFiles - 1)
'FilePtr1 = Iif(fileptr + 1 < MaxRFiles, fileptr + 1, 0)
rFile = GetSetting(A_Name, S_Name, "File" & FilePtr1, "")
Loop
SaveSetting A_Name, S_Name, "File" & FirstPtr, OldFile
'SaveSetting A_Name, S_Name, "FirstFile", CStr(fileptr)
ReadRecentFiles
' WriteRecentFiles OldFile
End Sub作者: winggd 时间: 2004-3-22 11:33 标题: vb实例
文本环绕效果
Option Explicit
Const SRCCOPY = &HCC0020
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Dim AF As APIFont
Dim X, Y As Integer
Private Sub Command1_Click()
Dim I As Integer
Set AF = Nothing
Set AF = New APIFont
Picture2.Cls
For I = 0 To 3600 Step 360
AF.Escapement = I
AF.SelectFont Picture2
X = Picture2.ScaleWidth / 2
Y = Picture2.ScaleHeight / 2
AF.FontOut "http://coolbasic.yeah.net ", Picture2, X, Y
AF.SelectOrg Picture2
Next I
End Sub
Private Sub Form_Load()
'Picture2.Left = Picture1.Left
'Picture2.Top = Picture1.Top
'Picture2.Width = Picture1.Width
'Picture2.Height = Picture1.Height
Picture2.ScaleMode = 3
'Picture1.AutoRedraw = True
End Sub
'模块内容
Option Explicit
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal _
X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont _
As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, _
ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetTextAlign Lib "gdi32" (ByVal hdc As Long, ByVal wFlags As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const TA_LEFT = 0
Private Const TA_RIGHT = 2
Private Const TA_CENTER = 6
Private Const TA_TOP = 0
Private Const TA_BOTTOM = 8
Private Const TA_BASELINE = 24
Private 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 As String * 50
End Type
Private m_LF As LOGFONT
Private NewFont As Long
Private OrgFont As Long
Public Sub CharPlace(o As Object, txt$, X, Y)
Dim Throw As Long
Dim hregion As Long
Dim R As RECT
R.Left = X
R.Right = X + o.TextWidth(txt$) * 2
R.Top = Y
R.Bottom = Y + o.TextHeight(txt$) * 2
hregion = CreateRectRgn(R.Left, R.Top, R.Right, R.Bottom)
Throw = SelectClipRgn(o.hdc, hregion)
Throw = TextOut(o.hdc, X, Y, txt$, Len(txt$))
DeleteObject (hregion)
End Sub
Public Sub SetAlign(o As Object, Top, BaseLine, Bottom, Left, Center, Right)
Dim Vert As Long
Dim Horz As Long
If Top = True Then Vert = TA_TOP
If BaseLine = True Then Vert = TA_BASELINE
If Bottom = True Then Vert = TA_BOTTOM
If Left = True Then Horz = TA_LEFT
If Center = True Then Horz = TA_CENTER
If Right = True Then Horz = TA_RIGHT
SetTextAlign o.hdc, Vert Or Horz
End Sub
Public Sub setcolor(o As Object, Cvalue As Long)
Dim Throw As Long
Throw = SetTextColor(o.hdc, Cvalue)
End Sub
Public Sub SelectOrg(o As Object)
Dim Throw As Long
NewFont = SelectObject(o.hdc, OrgFont)
Throw = DeleteObject(NewFont)
End Sub
Public Sub SelectFont(o As Object)
NewFont = CreateFontIndirect(m_LF)
OrgFont = SelectObject(o.hdc, NewFont)
End Sub
Public Sub FontOut(text$, o As Control, XX, YY)
Dim Throw As Long
Throw = TextOut(o.hdc, XX, YY, text$, Len(text$))
End Sub
Public Property Get Width() As Long
Width = m_LF.lfWidth
End Property
Public Property Let Width(ByVal W As Long)
m_LF.lfWidth = W
End Property
Public Property Get Height() As Long
Height = m_LF.lfHeight
End Property
Public Property Let Height(ByVal vNewValue As Long)
m_LF.lfHeight = vNewValue
End Property
Public Property Get Escapement() As Long
Escapement = m_LF.lfEscapement
End Property
Public Property Let Escapement(ByVal vNewValue As Long)
m_LF.lfEscapement = vNewValue
End Property
Public Property Get Weight() As Long
Weight = m_LF.lfWeight
End Property
Public Property Let Weight(ByVal vNewValue As Long)
m_LF.lfWeight = vNewValue
End Property
Public Property Get Italic() As Byte
Italic = m_LF.lfItalic
End Property
Public Property Let Italic(ByVal vNewValue As Byte)
m_LF.lfItalic = vNewValue
End Property
Public Property Get UnderLine() As Byte
UnderLine = m_LF.lfUnderline
End Property
Public Property Let UnderLine(ByVal vNewValue As Byte)
m_LF.lfUnderline = vNewValue
End Property
Public Property Get StrikeOut() As Byte
StrikeOut = m_LF.lfStrikeOut
End Property
Public Property Let StrikeOut(ByVal vNewValue As Byte)
m_LF.lfStrikeOut = vNewValue
End Property
Public Property Get FaceName() As String
FaceName = m_LF.lfFaceName
End Property
Public Property Let FaceName(ByVal vNewValue As String)
m_LF.lfFaceName = vNewValue
End Property
Private Sub Class_Initialize()
m_LF.lfHeight = 30
m_LF.lfWidth = 10
m_LF.lfEscapement = 0
m_LF.lfWeight = 400
m_LF.lfItalic = 0
m_LF.lfUnderline = 0
m_LF.lfStrikeOut = 0
m_LF.lfOutPrecision = 0
m_LF.lfClipPrecision = 0
m_LF.lfQuality = 0
m_LF.lfPitchAndFamily = 0
m_LF.lfCharSet = 0
m_LF.lfFaceName = "Arial" + Chr(0)
End Sub作者: winggd 时间: 2004-3-22 11:34 标题: vb实例
建立透明的窗口
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As _
Long, lpRECT As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As _
Long, lpRECT As RECT) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As _
Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal _
nCombineMode As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As _
Long, lpPoint As POINTAPI) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As _
Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Const RGN_AND = 1
Const RGN_COPY = 5
Const RGN_DIFF = 4
Const RGN_OR = 2
Const RGN_XOR = 3
Private Type POINTAPI
x As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Sub DataSamp()
Dim ad As Database
Dim aserch As QueryDef
End Sub
Public Sub MakeTransparent(frm As Form)
Dim rctClient As RECT, rctFrame As RECT
Dim hClient As Long, hFrame As Long
