用Visial Basic 在菜单栏实现超链接

 

 

---

如何在菜单栏上实现超链接                       和尚  2001/11/13   笔者突发奇想，在菜单栏上写点版权信息多好！可是vb内置事件检测不到菜单栏消息。只好求助于win32API。窗口工作区以外的MouseMove消息表示为WM_NCMOUSEMOVE,所以设置窗口过程截取并处理这条消息，同样可以处理鼠标点击消息了,同样您也可以把超链接放在标题栏上,。啊，反正鄙人表达能力有限，代码都在这里，相信你一看就明白了。拿去用好了，不过如果你想转载的话还需要注名 "来自和尚在线" 。也欢迎大家访问我的主页：http://handsomge.yeah.net 那里都是鄙人的作品。
以下内容放在窗体                    Private Sub Form_Activate() title End Sub Private Sub Form_Load() Dim ret As Long '记录原本的Window Procedure的位址 preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC) '设定Combo1的window Procedure到wndproc ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf wndproc) End Sub Private Sub Form_Paint() title End Sub Private Sub Form_Resize() title 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 Sub title()  Dim fr1 As RECT  GetWindowRect Me.hwnd, fr1  d1 = GetWindowDC(Me.hwnd)  SetBkMode d1, 0  SetTextColor d1, RGB(235, 235, 235)  fon = CreateFont(14, 8, 0, 0, 100, 0, 0, 0, 0, 0, 0, 0, 0, "隶书")  SelectObject d1, fon  v = "和尚在线极力推荐 "  TextOut d1, fr1.Right - 130 - Me.Left / Screen.TwipsPerPixelX, fr1.Top -     Me.Top  / Screen.TwipsPerPixelY + 25, v, Len(v)  SetTextColor d1, RGB(70, 70, 70)  TextOut d1, fr1.Right - 129 - Me.Left / Screen.TwipsPerPixelX, fr1.Top -    Me.Top  / Screen.TwipsPerPixelY + 26, v, Len(v) End Sub 以下内容放在 标准模块中 Public Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long Public Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal h As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long Public Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Public Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long Public Const WM_NCLBUTTONUP = &HA2 Public Const WM_NCMOUSEMOVE = &HA0 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 Function GetMenuString Lib "user32" Alias "GetMenuStringA" (ByVal hMenu As Long, ByVal wIDItem As Long, ByVal lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) As Long Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long Public Const GWL_WNDPROC = (-4) Public Const WM_MENUSELECT = &H11F Public preWinProc As Long Private Type tLong ll As Long End Type Private Type TwoWord LowWord As Integer HiWord As Integer End Type Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Public 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 Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Public 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 wndproc(ByVal hwnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Dim MenuItemStr As String, SubMenuStr As String Dim hSubmenu As Long, MenuId As Long, i As Long Dim ad As tLong, tmpt2 As TwoWord '截取WM_ncmousemove处理完後，再将之送往原来的Window Procedure If Msg = WM_NCMOUSEMOVE Then ad.ll = lParam LSet tmpt2 = ad If (tmpt2.LowWord > (frMain.Left + frMain.Width) / Screen.TwipsPerPixelX - 130) And (tmpt2.HiWord > frMain.Top / Screen.TwipsPerPixelY + 25 And tmpt2.HiWord <= frMain.Top / Screen.TwipsPerPixelY + 36) Then Screen.MouseIcon = frMain.MouseIcon Screen.MousePointer = 99 Else Screen.MousePointer = 0 End If End If '如果在超链接上空点击鼠标左键,就打开URL If Msg = WM_NCLBUTTONUP And Screen.MousePointer = 99 Then ShellExecute frMain.hwnd, "open", "http://handsomge.yeah.net/", "", "", vbNormalFocus '将之送往原来的Window Procedure wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam) End Function

　 详细内容参看作者主页