VB6 DeskTool 窗体代码

'************************* DeskTool 窗体代码

'要换图片的话,调整窗体大小刚好容下图片
'有两张图片背景色不同,一为蓝色(TransColor=QbColor(9)),一为紫色(TransColor=QbColor(13))
'如果Me.Picture使用了 .gif 的话（背景透明图片),则Transcolor = Rgb(66,66,66) 随你设

Option Explicit
Private Sub Form_Load()
   If App.PrevInstance Then Call MsgBox("对不起本程序已在运行中, 不得重复加载!!", vbCritical, "桌面工具"): End
   '将本地路径赋值给变量 AppDisk
   AppDisk = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\")
   '****************************************** 透明窗体背景 ************
   TransColor = QBColor(9) 'vbBlue
   Me.BorderStyle = 0: Me.Caption = ""
   Me.BackColor = TransColor
   Rtn = GetWindowLong(hWnd, GWL_EXSTYLE)
   Rtn = Rtn Or WS_EX_LAYERED
   SetWindowLong hWnd, GWL_EXSTYLE, Rtn
   SetLayeredWindowAttributes hWnd, TransColor, 150, LWA_ALPHA Or LWA_COLORKEY '透明度 150
   '将窗体居中显示 (屏幕宽度减去窗体的宽度)除以2 , (屏幕高度减去窗体的高度)除以2
   Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
   SetWindowPos Me.hWnd, -1, 0, 0, 0, 0, 3 '设定总在最前
   '******************* 注册Wshom.ocx
   WinSys = GETSYS
   aa = WinSys & "wshom.ocx"
   If Dir(aa) <> "" Then Shell "regsvr32 /s " & WinSys & "wshom.ocx"
   Call PutDeskTop '设置桌面快捷键
End Sub

Private Sub Form_Unload(Cancel As Integer)
   Call CleanAll
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
   On Error Resume Next
   If Button = 1 Then
      Dim lngReturnValue As Long  '移动窗体
      Call ReleaseCapture
      lngReturnValue = SendMessage(Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
   Else
      If Button = 2 Then PopupMenu Mform.Pmenu
   End If
End Sub

Private Sub Form_DblClick()
   Call MessageBox(Me.hWnd, "Hello!", "桌面工具", vbOKOnly)
End Sub

Public Sub PutDeskTop() '设置桌面快捷键
   On Error Resume Next
   Dim WshShell, MYKJJ, MYKJJ2
   '**********************桌面快捷键与开始菜单********************************
   aa = AppDisk & "Tool.exe" '设定快捷方式指向的对象
   If Dir(aa) = "" Then Exit Sub
   '************** 桌面
   Set WshShell = CreateObject("Wscript.shell")
   DeskPath = WshShell.SpecialFolders("Desktop")
   Set MYKJJ = WshShell.CreateShortcut(DeskPath & "\桌面工具.lnk") '快捷名称
   MYKJJ.TargetPath = aa '源文件
   MYKJJ.Hotkey = "Ctrl+Alt+F10" '快捷热键
   MYKJJ.Save
End Sub



'************************************* Mform 窗体代码

Option Explicit
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
   If Button = 1 Then '在托盘里按了左键
      WinShow_Click
   Else
      If Button = 2 Then PopupMenu Pmenu '在托盘里按右键弹出菜单
   End If
End Sub

Private Sub WinTop_Click() '窗体置顶
   SetWindowPos DeskTool.hWnd, -1, 0, 0, 0, 0, 3 '设定总在最前
End Sub

Private Sub WinButtom_Click() '窗体置底
   SetWindowPos DeskTool.hWnd, -2, 0, 0, 0, 0, 3 '取消总在最前
End Sub

Private Sub WinTray_Click() '窗体放进托盘
   nfIconData.hWnd = Me.hWnd
   nfIconData.uID = Me.Icon
   nfIconData.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
   nfIconData.uCallbackMessage = WM_MOUSEMOVE
   nfIconData.hIcon = Me.Icon.Handle
   nfIconData.szTip = "桌面工具" & vbNullChar
   nfIconData.cbSize = Len(nfIconData)
   Call Shell_NotifyIcon(NIM_ADD, nfIconData)
   DeskTool.Visible = False
End Sub

Private Sub WinShow_Click() '显示窗体
   Call Shell_NotifyIcon(NIM_DELETE, nfIconData) '退出图标
   DeskTool.Show
End Sub

Private Sub WinExit_Click() '退出程序
   Call CleanAll
End Sub



'************** Module1.bas 模块代码

Option Explicit
Public Const MOD_ALT = &H1
Public Const MOD_CONTROL = &H2
Public Const MOD_SHIFT = &H4
Public Const WM_HOTKEY = &H312
Public Const GWL_WNDPROC = (-4)
'*************************** 托盘
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public nfIconData As NOTIFYICONDATA
Public Const MAX_TOOLTIP As Integer = 64
Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIM_DELETE = &H2
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBLCLK = &H206
Public Const SW_RESTORE = 9
Public Const SW_HIDE = 0
Public Const LB_ITEMFROMPOINT = &H1A9
Public Type NOTIFYICONDATA
   cbSize           As Long
   hWnd             As Long
   uID              As Long
   uFlags           As Long
   uCallbackMessage As Long
   hIcon            As Long
   szTip            As String * MAX_TOOLTIP
End Type
'*****************************************************************************************
Public Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
'*****************************************移动窗体
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Public Const WM_NCLBUTTONDOWN = &HA1, HTCAPTION = 2
'**********************************************************************************
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex 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
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Const WS_EX_LAYERED = &H80000
Public Const GWL_EXSTYLE = (-20)
Public Const LWA_ALPHA = &H2
Public Const LWA_COLORKEY = &H1
Global i%, j%, Rtn&, aa$, Fname$, TransColor&, AppDisk$, WinSys$, DeskPath$

Public Sub CleanAll()
   '*****************************
   Dim TmpFrm As Form
   For Each TmpFrm In Forms
      Unload TmpFrm
      Set TmpFrm = Nothing
   Next
   End
End Sub

Public Function GETSYS() As String
   On Error Resume Next
   '获取system32路径
   aa = Trim(Environ("ComSpec"))
   Rtn = InStrRev(aa, "\")
   GETSYS = Mid(aa, 1, Rtn)
End Function