在菜单栏上实现超链接上
以下内容放在窗体 Private Sub Form_Activate()titleEnd Sub
Private Sub Form_Load()Dim ret As Long'记录原本的Window Procedure的位址preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)'设定Combo1的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'取消Message的截取，而使之又只送往原来的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, 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 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 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 LongPublic 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 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 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 nShowCmd 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'截取WM_ncmousemove处理完後，再将之送往原来的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.TwipsPerPixelY + 36) ThenScreen.MouseIcon = frMain.MouseIconScreen.MousePointer = 99ElseScreen.MousePointer = 0End IfEnd If'如果在超链接上空点击鼠标左键,就打开URLIf Msg = WM_NCLBUTTONUP And Screen.MousePointer = 99 Then ShellExecute frMain.hwnd, "open", "Http://Shawls.Yeah.Net/", "", "", vbNormalFocus'将之送往原来的Window Procedurewndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)End Function
以上代码来自： 源代码数据库(SourceDataBase) 当前版本： 1.0.531 作者： Shawls 个人主页： Http://Shawls.Yeah.Net E-Mail： ShawFile@163.Net QQ： 9181729
