vb实例

实现托盘程序的例子 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

屏蔽系统热键
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

使用AppendMenu添加菜单并且相应Click事件
Private Sub Form_Load()
    Dim mSysMenu As Long
    Dim mMenu As Long
    Dim mSubMenu As Long
   
    mSysMenu = GetSystemMenu(Me.hwnd, False)
    AppendMenu1 mSysMenu, MF_SEPARATOR, 0, "-" '因为本工程名字也是AppendMenu,所以只好改函数名了
    AppendMenu1 mSysMenu, MF_STRING, mAddItemId, "VB广场"
   
    mMenu = GetMenu(Me.hwnd)
    mSubMenu = GetSubMenu(mMenu, 0)
    AppendMenu1 mSubMenu, MF_SEPARATOR, 0, "-"
    AppendMenu1 mSubMenu, MF_STRING, mFileId, "文件"
    AppendMenu1 mSubMenu, MF_STRING + MF_GRAYED + MF_CHECKED, mSaveId, "保存"
   
    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
   
    mSysMenu = GetSystemMenu(Me.hwnd, False)
    AppendMenu1 mSysMenu, MF_SEPARATOR, 0, "-" '因为本工程名字也是AppendMenu,所以只好改函数名了
    AppendMenu1 mSysMenu, MF_STRING, mAddItemId, "VB广场"
   
    mMenu = GetMenu(Me.hwnd)
    mSubMenu = GetSubMenu(mMenu, 0)
    AppendMenu1 mSubMenu, MF_SEPARATOR, 0, "-"
    AppendMenu1 mSubMenu, MF_STRING, mFileId, "文件"
    AppendMenu1 mSubMenu, MF_STRING + MF_GRAYED + MF_CHECKED, mSaveId, "保存"
   
    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() 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

窗体启动特效
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
   
    GetWindowRect f.hwnd, myRect
    formWidth = (myRect.Right - myRect.Left)
    formHeight = myRect.Bottom - myRect.Top
    TheScreen = GetDC(0)
    Brush = CreateSolidBrush(f.BackColor)
   
        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

使窗体的关闭按钮无效
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

制作屏幕保护程序
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

为窗体添加透明阴影
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

历史记录 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

文本环绕效果
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

建立透明的窗口
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
   
    '获得窗口矩形区域
    GetWindowRect frm.hWnd, rctFrame
    GetClientRect frm.hWnd, rctClient
   
    '将窗口矩形坐标转换为屏幕坐标
    Dim lpTL As POINTAPI, lpBR As POINTAPI
    lpTL.x = rctFrame.Left
    lpTL.Y = rctFrame.Top
    lpBR.x = rctFrame.Right
    lpBR.Y = rctFrame.Bottom
    ScreenToClient frm.hWnd, lpTL
    ScreenToClient frm.hWnd, lpBR
    rctFrame.Left = lpTL.x
    rctFrame.Top = lpTL.Y
    rctFrame.Right = lpBR.x
    rctFrame.Bottom = lpBR.Y
    rctClient.Left = Abs(rctFrame.Left)
    rctClient.Top = Abs(rctFrame.Top)
    rctClient.Right = rctClient.Right + Abs(rctFrame.Left)
    rctClient.Bottom = rctClient.Bottom + Abs(rctFrame.Top)
    rctFrame.Right = rctFrame.Right + Abs(rctFrame.Left)
    rctFrame.Bottom = rctFrame.Bottom + Abs(rctFrame.Top)
    rctFrame.Top = 0
    rctFrame.Left = 0
   
   
    hClient = CreateRectRgn(rctClient.Left, rctClient.Top, rctClient.Right, rctClient.Bottom)
    hFrame = CreateRectRgn(rctFrame.Left, rctFrame.Top, rctFrame.Right, rctFrame.Bottom)
   
    CombineRgn hFrame, hClient, hFrame, RGN_XOR
   
    SetWindowRgn frm.hWnd, hFrame, True
End Sub
Private Sub Form_Click()
    MakeTransparent Me
End Sub

呵呵！怎么总感觉这个不应该是在论坛里出现的呢？
那里出了问题吗？？？

不错!
可以让vb初学者参考.

屏蔽热键根本屏不住W2000以上的系统