???托盘???
我的程序添加了托盘图标部分的代码后，在vb的调试环境中只能按结束按钮结束程序，否则就会连同程序和vb一起关掉！我用的代码论坛上都有人贴过了，大家一看就知道了，虽然可以正常用，但是实在是太麻烦了！我翻了翻原来的帖子，没有提到这种情况的，请大家帮我一把。
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.
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
让图标接受信息只能用他这个么？有没有别的方法（不过我觉得他的不错，就是在我的程序上不行）
问题点数：0、回复次数：5Top
1 楼zyl910（编程的乐趣在于编程控制硬件，与用图形学实现绚丽效果）回复于 2003-08-01 20:44:36 得分 0
http://expert.csdn.net/Expert/topic/2082/2082509.xml?temp=.1619074
http://www.fantasiasoft.net/Zyl910/ZSubClass.zip
项目名：zSubClass
作者：zyl910
功能：专门用来处理SubClass操作
特点：
1.同一个ISubClass类能同时检测多个窗口的消息
2.使用计数访问技术，所以对同一个窗口进行多次SubClass也不会出错
3.自定义了一个ZM_UnSubClass外部消息，彻底解决取消SubClass时的顺序问题
4.允许以 接口函数、事件 两种方法接受消息
5.允许设定接受级别（能让自己的类最先或最后得到消息），这样有助于处理通知消息
6.由于封装成了ActiveX DLL，所以可以在调试环境下随意中断
7.有MsgIn、MsgOut两个接口，你可以选择在下级处理程序处理 之前 或 之后 处理消息
与vbaccelerator.com的SubClass DLL的区别：
1.它只支持接口方式，不支持事件，在某些时候有点不方便
2.它是用窗口属性函数保存信息的。窗口属性函数涉及到字符串，而字符串传递、查找是最花时间的，所以降低了效率。而我呢，专门将他们的hWnd保存在一个排好序的数组，再用二分法查找，效率高多了
3.用窗口属性函数还有一个缺点，就是它的信息可以被外部程序得到。万一外部程序不小心（或是故意的）修改的话，立即非法操作。我的程序是完全隐藏，安全性极佳
4.它是以消息为单位处理的，我是以窗口为单位处理的。对于需要拦截某个窗口的多个消息时，我的更方便
5.它不支持级别设置，这样对于处理通知消息很不方便
Top
2 楼zyl910（编程的乐趣在于编程控制硬件，与用图形学实现绚丽效果）回复于 2003-08-01 20:45:08 得分 0
6.由于封装成了ActiveX DLL，所以可以在调试环境下随意中断Top
3 楼csdngoodnight（居然比我还快，你真行！）回复于 2003-08-01 21:21:37 得分 0
'-------------------------------------------------------------------
'类模块:托盘图标的添加
'-------------------------------------------------------------------
Option Explicit
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias _
"Shell_NotifyIconA" (ByVal dwMessage As Long, _
pNid As NOTIFYICONDATA) As Boolean
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206
Private Type NOTIFYICONDATA
lSize As Long
hWnd As Long
lId As Long
lFlags As Long
lCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Private mNID As NOTIFYICONDATA
Private WithEvents mPic As PictureBox
Public Event RButtonDown() '鼠标右键按下
Public Event RButtonUp() '鼠标右键放开
Public Event RButtonDblClick() '鼠标右键双击
Public Event LButtonDown() '鼠标左键按下
Public Event LButtonUp() '鼠标左键放开
Public Event LButtonDblClick() '鼠标左键双击
Private Sub Class_Initialize()
With mNID
.lSize = Len(mNID)
.lCallBackMessage = WM_MOUSEMOVE
.lFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.lId = 1&
End With
End Sub
Private Sub Class_Terminate()
DeleteIcon
Set mPic = Nothing
End Sub
Public Property Let PicBox(ByVal PicBox As PictureBox)
Set mPic = PicBox
With mNID
.hWnd = mPic.hWnd
.hIcon = mPic
End With
End Property
Public Property Get TipText() As String
TipText = mNID.szTip
End Property
Public Property Let TipText(ByVal TipText As String)
mNID.szTip = TipText & Chr$(0)
Shell_NotifyIcon NIM_MODIFY, mNID
End Property
Public Function ShowIcon() As Boolean
If mPic Is Nothing Then
ShowIcon = False
Else
Shell_NotifyIcon NIM_ADD, mNID
ShowIcon = True
End If
End Function
Public Sub DeleteIcon()
Shell_NotifyIcon NIM_DELETE, mNID
End Sub
Private Sub mPic_Change()
mNID.hIcon = mPic
Shell_NotifyIcon NIM_MODIFY, mNID
End Sub
Private Sub mPic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Static bRec As Boolean
Dim lMsg As Long
lMsg = X / Screen.TwipsPerPixelX
If bRec = False Then
bRec = True
Select Case lMsg
Case WM_LBUTTONDBLCLK:
'左键双击
RaiseEvent LButtonDblClick
Case WM_LBUTTONDOWN:
'左键按下
RaiseEvent LButtonDown
Case WM_LBUTTONUP:
'左键放开
RaiseEvent LButtonUp
Case WM_RBUTTONDBLCLK:
'右键双击
RaiseEvent RButtonDblClick
Case WM_RBUTTONDOWN:
'右键按下
RaiseEvent RButtonDown
Case WM_RBUTTONUP:
'右键放开
RaiseEvent RButtonUp
End Select
bRec = False
End If
End Sub
'窗体代码--------------------------------------------
Dim WithEvents Tray As CTray '托盘图标变量
Private Sub Form_Load()
'托盘图标
Set Tray = New CTray
With Tray
.TipText = Me.Caption
.PicBox = picChange '一个用于托盘的图标(PictureBox)
End With
Tray.ShowIcon '添加图标在托盘
End Sub
'以下为托盘图标事件=========================================================
Private Sub Tray_LButtonDblClick()
Text1.Text = "左键双击" '& vbCrLf
End Sub
Private Sub Tray_LButtonDown()
Text1.Text = "左键按下"
End Sub
Private Sub Tray_LButtonUp()
Text1.Text = "左键放开"
End Sub
Private Sub Tray_RButtonDblClick()
Text1.Text = "右键双击"
End Sub
Private Sub Tray_RButtonDown()
Text1.Text = "右键按下"
End Sub
Private Sub Tray_RButtonUp()
Text1.Text = "右键放开"
End Sub
private sub form_unload()
'删除托盘图标
Tray.DeleteIcon
Set Tray = Nothing
end subTop
4 楼since1990（level）回复于 2003-08-02 00:15:47 得分 0
upTop
5 楼kingxing（在江湖上混口饭吃）回复于 2003-08-05 23:10:14 得分 0
不好意思，这个问题我自己解决了
方法是
我在Form_Unload中有个end把它去了就可以了
Top
