用 SetParent Command1.hwnd, 0 SetWindowLong Command1.hwnd, -8, Me.hwnd 把command1分离窗口出来,使之能自由移动 对me做子类处理,捕获WM_MOVE消息,处理command1的位置需要注意的是如果希望command1响应事件,需要把它放在一个容器内 如frame1,然后对frame1使用上面的那两个函数。 可以参考 http://expert.csdn.net/Expert/FAQ/FAQ_Index.asp?id=7691下面是个简单的例子: 在窗体中放上一个frame,在frame中放上一个commandbutton '窗体代码 Private Sub Command1_Click() Debug.Print "Click the title button" End SubPrivate Sub Form_Load() Frame1.BorderStyle = 0 Command1.Left = 0 Command1.Top = 0 Command1.Width = 240 Command1.Height = 210 moveHwnd = Frame1.hwnd SetParent moveHwnd, 0 SetWindowLong moveHwnd, -8, Me.hwnd gHW = Me.hwnd hook End SubPrivate Sub Form_Unload(Cancel As Integer) Unhook End Sub'模块部分的代码Option Explicit Public moveHwnd As LongPublic Const GWL_WNDPROC = -4 Global lpPrevWndProc As Long Global gHW 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long Public Const WM_MOVE As Long = &H3 Public Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Public Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd Type
Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongSelect Case uMsg Case WM_MOVE Dim t As RECT GetWindowRect hw, t MoveWindow moveHwnd, t.Right - 72, t.Top + 6, 16, 14, 1 Case Else End Select WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam) End Function
Public Sub hook() lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc) End Sub
Public Sub Unhook() Dim temp As Long temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc) End Sub
Private Sub Form_Activate() title End SubPrivate 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 SubPrivate Sub Form_Paint() title End SubPrivate Sub Form_Resize() title End SubPrivate 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 以上代码保存于: SourceCode Explorer(源代码数据库) 复制时间: 2002-10-24 21:19 软件版本: 1.0.745 软件作者: Shawls 个人主页: Http://Shawls.Yeah.Net E-Mail: [email protected] QQ: 9181729
[名称] 在菜单栏上实现超链接下[语言种类] Visual Basic[类别一] 界面[类别二] 空[类别三] 空[数据来源] 来自和尚在线[保存时间] 2002-03-19[关键字一] 超链接[关键字二] 菜单[关键字三] API[内容简介] 空[源代码内容]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 以上代码保存于: SourceCode Explorer(源代码数据库) 复制时间: 2002-10-24 21:20 软件版本: 1.0.745 软件作者: Shawls 个人主页: Http://Shawls.Yeah.Net E-Mail: [email protected] QQ: 9181729
方法比你好的多
使用这两句
SetParent Command1.hwnd, 0
SetWindowLong Command1.hwnd, -8, Me.hwnd
SetParent Command1.hwnd, 0
SetWindowLong Command1.hwnd, -8, Me.hwnd
把command1分离窗口出来,使之能自由移动
对me做子类处理,捕获WM_MOVE消息,处理command1的位置需要注意的是如果希望command1响应事件,需要把它放在一个容器内
如frame1,然后对frame1使用上面的那两个函数。
可以参考
http://expert.csdn.net/Expert/FAQ/FAQ_Index.asp?id=7691下面是个简单的例子:
在窗体中放上一个frame,在frame中放上一个commandbutton
'窗体代码
Private Sub Command1_Click()
Debug.Print "Click the title button"
End SubPrivate Sub Form_Load()
Frame1.BorderStyle = 0
Command1.Left = 0
Command1.Top = 0
Command1.Width = 240
Command1.Height = 210
moveHwnd = Frame1.hwnd
SetParent moveHwnd, 0
SetWindowLong moveHwnd, -8, Me.hwnd
gHW = Me.hwnd
hook
End SubPrivate Sub Form_Unload(Cancel As Integer)
Unhook
End Sub'模块部分的代码Option Explicit
Public moveHwnd As LongPublic Const GWL_WNDPROC = -4
Global lpPrevWndProc As Long
Global gHW 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Const WM_MOVE As Long = &H3
Public Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As LongEnd Type
Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongSelect Case uMsg
Case WM_MOVE
Dim t As RECT
GetWindowRect hw, t
MoveWindow moveHwnd, t.Right - 72, t.Top + 6, 16, 14, 1
Case Else
End Select
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End Function
Public Sub hook()
lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub Unhook()
Dim temp As Long
temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
End Sub
[名称] 在菜单栏上实现超链接上[语言种类] Visual Basic[类别一] 界面[类别二] 空[类别三] 空[数据来源] 来自和尚在线[保存时间] 2002-03-19[关键字一] 超链接[关键字二] 菜单[关键字三] API[内容简介] 空[源代码内容]以下内容放在窗体
Private Sub Form_Activate()
title
End SubPrivate 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 SubPrivate Sub Form_Paint()
title
End SubPrivate Sub Form_Resize()
title
End SubPrivate 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 以上代码保存于: SourceCode Explorer(源代码数据库)
复制时间: 2002-10-24 21:19
软件版本: 1.0.745
软件作者: Shawls
个人主页: Http://Shawls.Yeah.Net
E-Mail: [email protected]
QQ: 9181729
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
以上代码保存于: SourceCode Explorer(源代码数据库)
复制时间: 2002-10-24 21:20
软件版本: 1.0.745
软件作者: Shawls
个人主页: Http://Shawls.Yeah.Net
E-Mail: [email protected]
QQ: 9181729