Implement hyperlink on the menu bar
The following content is placed in the form private sub form_activate () Titleend Sub
Private Sub Form_Load () Dim ret As Long 'Window Procedure of recording the original address preWinProc = GetWindowLong (Me.hwnd, GWL_WNDPROC)' Combo1 set to the window Procedure wndprocret = SetWindowLong (Me.hwnd, GWL_WNDPROC, AddressOf wndproc) End Sub
Private sub form_paint () Titleend Sub
PRIVATE SUB FORM_RESize () Titleend Sub
Private Sub Form_Unload (Cancel AS Integer) Dim Ret As Long 'Cancels the interception of Message, and makes it only to the original window procedureret = setwindowlong (me.hwnd, gwl_wndproc, prewinproc)
End subsub 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, "Lishu") SelectObject D1, FON V = "Highly recommended" 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 The following content is placed in the standard module
Public Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As LongPublic 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 Op As Long, Byval cp as long Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As LongPublic Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As LongPublic Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As LongPublic Const WM_NCLBUTTONUP = & HA2Public Const WM_NCMOUSEMOVE = & HA0Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongDeclare Function GetWindowLong Lib "User32" Alias "getWindowlonga" _ (Byval Hwnd As Long, Byval Nindex As Long) As LongDeclare 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 LongDeclare Function GetMenuString Lib "user32" Alias "getmenustringa" (Byval Hmenu As Long, Byval LPSTRING AS STRING, BYVAL NMAXCOUNT AS Long, BYVAL WFLAG AS Long) As long
The above code from: the source code database (SourceDataBase) Current Version: 1.0.531 Author: Shawls profile: Http://Shawls.Yeah.Net E-Mail: ShawFile@163.Net QQ: 9181729 realize Hyperlinks on the menu bar under
Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As LongDeclare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As LongPublic Const GWL_WNDPROC = (-4) Public Const WM_MENUSELECT = & H11FPublic preWinProc As LongPrivate Type tLongll As LongEnd TypePrivate Type TwoWordLowWord As IntegerHiWord As IntegerEnd TypePublic Type RECTLeft As LongTop As LongRight As LongBottom As LongEnd TypePublic Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As LongPublic 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 LongPublic Declare Function SelectObject Lib" gdi32 "(ByVal hdc As Long, ByVal hObject As Long) As LongPublic 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 n ShowCmd As Long) As LongPublic Function wndproc (ByVal hwnd As Long, ByVal Msg As Long, _ByVal wParam As Long, ByVal lParam As Long) As LongDim MenuItemStr As String, SubMenuStr As StringDim hSubmenu As Long, MenuId As Long, i As LongDim ad As tLong, tmpt2 As TwoWord 'taken WM_ncmousemove processed, and then sent to the original Window ProcedureIf Msg = WM_NCMOUSEMOVE Thenad.ll = lParamLSet tmpt2 = adIf (tmpt2.LowWord> (frMain.Left frMain.Width) / Screen. Twipsperpixelx - 130) and (tmpt2.hiword> frMain.top / screen.twipsperpixely 25 and tmpt2.hiWord <= frMain.top / screen.twipsperpixly 36) Tenscreen.Mouseicon =
frMain.MouseIconScreen.MousePointer = 99ElseScreen.MousePointer = 0End IfEnd If 'if the hyperlinks above click the left mouse button to open URLIf Msg = WM_NCLBUTTONUP And Screen.MousePointer = 99 Then ShellExecute frMain.hwnd, "open", "Http: / /Shawls.yeah.net/ "," "," ", VBNORMALFOCUS 'will be sent to the original Window ProCedureWndProc = CallWindowProc (PrewinProc, HWND, MSG, WPARAM, LPARAM) end function above: SourceDatabase (SourceDatabase) current version: 1.0.531 author: Shawls profile: Http://Shawls.Yeah.Net E-Mail: ShawFile@163.Net QQ: 9181729
