在菜單欄上實現超鏈接上

領測軟件測試網 以下內容放在窗體
                   
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



       以上代碼來自： 源代碼數據庫(SourceDataBase)
           當前版本： 1.0.531
               作者： Shawls
           個人主頁： Http://Shawls.Yeah.Net
             E-Mail： ShawFile@163.Net
                 QQ： 9181729



在菜單欄上實現超鏈接下

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://Shawls.Yeah.Net/", "", "", vbNormalFocus
'將之送往原來的Window Procedure
wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
End Function

文章來源于領測軟件測試網 http://www.kjueaiud.com/