以文本方式查看主题

-  Foxtable(狐表)  (http://foxtable.net/bbs/index.asp)
--  专家坐堂  (http://foxtable.net/bbs/list.asp?boardid=2)
----  [求助]无边窗体任务栏右键菜单关闭能改变么  (http://foxtable.net/bbs/dispbbs.asp?boardid=2&id=40322)
--  作者：aalons
--  发布时间：2013/9/15 11:09:00
--  [求助]无边窗体任务栏右键菜单关闭能改变么
如题\'如何做纯粹的无边框窗体\'点任务栏右键的关闭菜单\'只关闭了当前窗体\'然后显示了Foxtable的原窗体\'露出了马甲\'有没能全部关闭的\'且左键点击任务栏上的图标无法最大化、最小化和还原



 下载信息  [文件大小：   下载次数： ]
图片点击可在新窗口打开查看点击浏览该文件:任务栏.table

 



下面的两段代码谁能将它改成Foxtable的呀？？？？

[此贴子已经被作者于2013-9-15 19:26:59编辑过]
--  作者：aalons
--  发布时间：2013/9/15 11:36:00
--  
 \'*************************************************************************
\'**模 块 名：cSubClass
\'**说    明：通用子类化模块,拦截本进程指定句柄的消息
\'**版    本：V1.0
\'**备    注： 内嵌汇编技术实现单个类模块子类化 
\'            
\'*************************************************************************

\'========================================================================================
\' Subclasser declarations
\'========================================================================================

Private Enum eMsgWhen
    [MSG_AFTER] = 1                                  \'Message calls back after the original (previous) WndProc
    [MSG_BEFORE] = 2                                \'Message calls back before the original (previous) WndProc
    [MSG_BEFORE_AND_AFTER] = MSG_AFTER Or MSG_BEFORE \'Message calls back before and after the original (previous) WndProc
End Enum

Private Const ALL_MESSAGES    As Long = -1          \'All messages added or deleted
Private Const CODE_LEN        As Long = 197        \'Length of the machine code in bytes
Private Const GWL_WNDPROC      As Long = -4          \'Get/SetWindow offset to the WndProc procedure address
Private Const PATCH_04        As Long = 88          \'Table B (before) address patch offset
Private Const PATCH_05        As Long = 93          \'Table B (before) entry count patch offset
Private Const PATCH_08        As Long = 132        \'Table A (after) address patch offset
Private Const PATCH_09        As Long = 137        \'Table A (after) entry count patch offset

Private Type tSubData                                \'Subclass data type
    hWnd                      As Long              \'Handle of the window being subclassed
    nAddrSub                  As Long              \'The address of our new WndProc (allocated memory).
    nAddrOrig                  As Long              \'The address of the pre-existing WndProc
    nMsgCntA                  As Long              \'Msg after table entry count
    nMsgCntB                  As Long              \'Msg before table entry count
    aMsgTblA()                As Long              \'Msg after table array
    aMsgTblB()                As Long              \'Msg Before table array
End Type

Private sc_aSubData()          As tSubData          \'Subclass data array
Private sc_aBuf(1 To CODE_LEN) As Byte              \'Code buffer byte array
Private sc_pCWP                As Long              \'Address of the CallWindowsProc
Private sc_pEbMode            As Long              \'Address of the EbMode IDE break/stop/running function
Private sc_pSWL                As Long              \'Address of the SetWindowsLong function
  
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long

Private Const WM_LBUTTONDOWN = &H201
Private Const WM_SETFOCUS = &O7

Public Event MsgCome(ByVal bBefore As Boolean, ByRef bHandled As Boolean, ByRef lReturn As Long, ByRef lng_hWnd As Long, ByRef uMsg As Long, ByRef wParam As Long, ByRef lParam As Long)

Private Sub Class_Terminate()
        Call Subclass_StopAll
End Sub

\'========================================================================================
\' Subclass handler: MUST be the first Public routine in this file.
\'                  That includes public properties also.
\'========================================================================================
Public Sub zSubclass_Proc(ByVal bBefore As Boolean, ByRef bHandled As Boolean, ByRef lReturn As Long, ByRef lng_hWnd As Long, ByRef uMsg As Long, ByRef wParam As Long, ByRef lParam As Long)
    \'
    \'Parameters:
    \'  bBefore  - Indicates whether the the message is being processed before or after the default handler - only really needed if a message is set to callback both before & after.
    \'  bHandled - Set this variable to True in a \'before\' callback to prevent the message being subsequently processed by the default handler... and if set, an \'after\' callback
    \'  lReturn  - Set this variable as per your intentions and requirements, see the MSDN documentation for each individual message value.
    \'  lng_hWnd - The window handle
    \'  uMsg    - The message number
    \'  wParam  - Message related data
    \'  lParam  - Message related data
    \'
    \'Notes:
    \'  If you really know what you\'re doing, it\'s possible to change the values of the
    \'  hWnd, uMsg, wParam and lParam parameters in a \'before\' callback so that different
    \'  values get passed to the default handler.. and optionaly, the \'after\' callback
    RaiseEvent MsgCome(bBefore, bHandled, lReturn, lng_hWnd, uMsg, wParam, lParam)
    Debug.Print bBefore; bHandled; lReturn; lng_hWnd; uMsg; wParam; lParam
    \'消息截获
End Sub

\'========================================================================================
\' Methods
\'========================================================================================

Public Function AddWindowMsgs(ByVal hWnd As Long) As Boolean
        \'-- Start subclassing
        Call Subclass_Start(hWnd)
        Call Subclass_AddMsg(hWnd, ALL_MESSAGES, MSG_BEFORE)
        \'-- Success
        AddWindowMsgs = True
End Function

Public Function DeleteWindowMsg(ByVal hWnd As Long) As Boolean
    Debug.Print "de"
End Function

\'========================================================================================
\' Subclass code - The programmer may call any of the following Subclass_??? routines
\'========================================================================================

Private Sub Subclass_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
    \'Add a message to the table of those that will invoke a callback. You should Subclass_Start first and then add the messages
    \'Parameters:
    \'  lng_hWnd - The handle of the window for which the uMsg is to be added to the callback table
    \'  uMsg    - The message number that will invoke a callback. NB Can also be ALL_MESSAGES, ie all messages will callback
    \'  When    - Whether the msg is to callback before, after or both with respect to the the default (previous) handler
    With sc_aSubData(zIdx(lng_hWnd))
        If (When And eMsgWhen.MSG_BEFORE) Then
            Call zAddMsg(uMsg, .aMsgTblB, .nMsgCntB, eMsgWhen.MSG_BEFORE, .nAddrSub)
        End If
        If (When And eMsgWhen.MSG_AFTER) Then
            Call zAddMsg(uMsg, .aMsgTblA, .nMsgCntA, eMsgWhen.MSG_AFTER, .nAddrSub)
        End If
    End With
End Sub

Private Sub Subclass_DelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
    \'Delete a message from the table of those that will invoke a callback.
    \'Parameters:
    \'  lng_hWnd - The handle of the window for which the uMsg is to be removed from the callback table
    \'  uMsg    - The message number that will be removed from the callback table. NB Can also be ALL_MESSAGES, ie all messages will callback
    \'  When    - Whether the msg is to be removed from the before, after or both callback tables
    With sc_aSubData(zIdx(lng_hWnd))
        If (When And eMsgWhen.MSG_BEFORE) Then
            Call zDelMsg(uMsg, .aMsgTblB, .nMsgCntB, eMsgWhen.MSG_BEFORE, .nAddrSub)
        End If
        If (When And eMsgWhen.MSG_AFTER) Then
            Call zDelMsg(uMsg, .aMsgTblA, .nMsgCntA, eMsgWhen.MSG_AFTER, .nAddrSub)
        End If
    End With
End Sub

Private Function Subclass_InIDE() As Boolean
    \'Return whether we\'re running in the IDE.
    Debug.Assert zSetTrue(Subclass_InIDE)
End Function

Private Function Subclass_Start(ByVal lng_hWnd As Long) As Long
    \'Start subclassing the passed window handle
    \'Parameters:
    \'  lng_hWnd - The handle of the window to be subclassed
    \'Returns;
    \'  The sc_aSubData() index
    Dim I                        As Long                      \'Loop index
    Dim J                        As Long                      \'Loop index
    Dim nSubIdx                  As Long                      \'Subclass data index
    Dim sSubCode                As String                    \'Subclass code string
    
    Const GMEM_FIXED            As Long = 0                  \'Fixed memory GlobalAlloc flag
    Const PAGE_EXECUTE_READWRITE As Long = &H40&              \'Allow memory to execute without violating XP SP2 Data Execution Prevention
    Const PATCH_01              As Long = 18                  \'Code buffer offset to the location of the relative address to EbMode
    Const PATCH_02              As Long = 68                  \'Address of the previous WndProc
    Const PATCH_03              As Long = 78                  \'Relative address of SetWindowsLong
    Const PATCH_06              As Long = 116                \'Address of the previous WndProc
    Const PATCH_07              As Long = 121                \'Relative address of CallWindowProc
    Const PATCH_0A              As Long = 186                \'Address of the owner object
    Const FUNC_CWP              As String = "CallWindowProcA" \'We use CallWindowProc to call the original WndProc
    Const FUNC_EBM              As String = "EbMode"          \'VBA\'s EbMode function allows the machine code thunk to know if the IDE has stopped or is on a breakpoint
    Const FUNC_SWL              As String = "SetWindowLongA"  \'SetWindowLongA allows the cSubclasser machine code thunk to unsubclass the subclasser itself if it detects via the EbMode function that the IDE has stopped
    Const MOD_USER              As String = "user32"          \'Location of the SetWindowLongA & CallWindowProc functions
    Const MOD_VBA5              As String = "vba5"            \'Location of the EbMode function if running VB5
    Const MOD_VBA6              As String = "vba6"            \'Location of the EbMode function if running VB6

    \'If it\'s the first time through here..
    If (sc_aBuf(1) = 0) Then
        \'Build the hex pair subclass string
        sSubCode = "5589E583C4F85731C08945FC8945F8EB0EE80000000083F802742185C07424E830000000837DF800750AE838000000E84D0000005F8B45FCC9C21000E826000000EBF168000000006AFCFF7508E800000000EBE031D24ABF00000000B900000000E82D000000C3FF7514FF7510FF750CFF75086800000000E8000000008945FCC331D2BF00000000B900000000E801000000C3E32F09C978078B450CF2AF75248D4514508D4510508D450C508D4508508D45FC508D45F85052B800000000508B00FF501CC3"
        \'Convert the string from hex pairs to bytes and store in the machine code buffer
        I = 1
        Do While J < CODE_LEN
            J = J + 1
            sc_aBuf(J) = CByte("&H" & Mid$(sSubCode, I, 2))                      \'Convert a pair of hex characters to an eight-bit value and store in the static code buffer array
            I = I + 2
        Loop                                                                      \'Next pair of hex characters
        \'Get API function addresses
        If (Subclass_InIDE) Then                                                  \'If we\'re running in the VB IDE
            sc_aBuf(16) = &H90                                                    \'Patch the code buffer to enable the IDE state code
            sc_aBuf(17) = &H90                                                    \'Patch the code buffer to enable the IDE state code
            sc_pEbMode = zAddrFunc(MOD_VBA6, FUNC_EBM)                            \'Get the address of EbMode in vba6.dll
            If (sc_pEbMode = 0) Then                                              \'Found?
                sc_pEbMode = zAddrFunc(MOD_VBA5, FUNC_EBM)                        \'VB5 perhaps
            End If
        End If
        Call zPatchVal(VarPtr(sc_aBuf(1)), PATCH_0A, ObjPtr(Me))                  \'Patch the address of this object instance into the static machine code buffer
        sc_pCWP = zAddrFunc(MOD_USER, FUNC_CWP)                                  \'Get the address of the CallWindowsProc function
        sc_pSWL = zAddrFunc(MOD_USER, FUNC_SWL)                                  \'Get the address of the SetWindowLongA function
        ReDim sc_aSubData(0 To 0) As tSubData                                    \'Create the first sc_aSubData element
    Else
        nSubIdx = zIdx(lng_hWnd, True)
        If (nSubIdx = -1) Then                                                    \'If an sc_aSubData element isn\'t being re-cycled
            nSubIdx = UBound(sc_aSubData()) + 1                                  \'Calculate the next element
            ReDim Preserve sc_aSubData(0 To nSubIdx) As tSubData                  \'Create a new sc_aSubData element
        End If
        Subclass_Start = nSubIdx
    End If
    With sc_aSubData(nSubIdx)
        .nAddrSub = GlobalAlloc(GMEM_FIXED, CODE_LEN)                            \'Allocate memory for the machine code WndProc
        Call VirtualProtect(ByVal .nAddrSub, CODE_LEN, PAGE_EXECUTE_READWRITE, I) \'Mark memory as executable
        Call RtlMoveMemory(ByVal .nAddrSub, sc_aBuf(1), CODE_LEN)                \'Copy the machine code from the static byte array to the code array in sc_aSubData
    
        .hWnd = lng_hWnd                                                          \'Store the hWnd
        .nAddrOrig = SetWindowLongA(.hWnd, GWL_WNDPROC, .nAddrSub)                \'Set our WndProc in place
    
        Call zPatchRel(.nAddrSub, PATCH_01, sc_pEbMode)                          \'Patch the relative address to the VBA EbMode api function, whether we need to not.. hardly worth testing
        Call zPatchVal(.nAddrSub, PATCH_02, .nAddrOrig)                          \'Original WndProc address for CallWindowProc, call the original WndProc
        Call zPatchRel(.nAddrSub, PATCH_03, sc_pSWL)                              \'Patch the relative address of the SetWindowLongA api function
        Call zPatchVal(.nAddrSub, PATCH_06, .nAddrOrig)                          \'Original WndProc address for SetWindowLongA, unsubclass on IDE stop
        Call zPatchRel(.nAddrSub, PATCH_07, sc_pCWP)                              \'Patch the relative address of the CallWindowProc api function
    End With
End Function

Private Sub Subclass_StopAll()
    \'Stop all subclassing
    Dim I As Long
  
    I = UBound(sc_aSubData())                                                    \'Get the upper bound of the subclass data array
    Do While I >= 0                                                              \'Iterate through each element
        With sc_aSubData(I)
            If (.hWnd <> 0) Then                                                  \'If not previously Subclass_Stop\'d
                Call Subclass_Stop(.hWnd)                                        \'Subclass_Stop
            End If
        End With
    
        I = I - 1                                                                \'Next element
    Loop
End Sub

Private Sub Subclass_Stop(ByVal lng_hWnd As Long)
    \'Stop subclassing the passed window handle
    \'Parameters:
    \'  lng_hWnd - The handle of the window to stop being subclassed

    With sc_aSubData(zIdx(lng_hWnd))
        Call SetWindowLongA(.hWnd, GWL_WNDPROC, .nAddrOrig)                      \'Restore the original WndProc
        Call zPatchVal(.nAddrSub, PATCH_05, 0)                                    \'Patch the Table B entry count to ensure no further \'before\' callbacks
        Call zPatchVal(.nAddrSub, PATCH_09, 0)                                    \'Patch the Table A entry count to ensure no further \'after\' callbacks
        Call GlobalFree(.nAddrSub)                                                \'Release the machine code memory
        .hWnd = 0                                                                \'Mark the sc_aSubData element as available for re-use
        .nMsgCntB = 0                                                            \'Clear the before table
        .nMsgCntA = 0                                                            \'Clear the after table
        Erase .aMsgTblB                                                          \'Erase the before table
        Erase .aMsgTblA                                                          \'Erase the after table
    End With
End Sub

\'----------------------------------------------------------------------------------------
\'These z??? routines are exclusively called by the Subclass_??? routines.
\'----------------------------------------------------------------------------------------

Private Sub zAddMsg(ByVal uMsg As Long, ByRef aMsgTbl() As Long, ByRef nMsgCnt As Long, ByVal When As eMsgWhen, ByVal nAddr As Long)
    \'Worker sub for Subclass_AddMsg

    Dim nEntry  As Long                                                            \'Message table entry index
    Dim nOff1  As Long                                                            \'Machine code buffer offset 1
    Dim nOff2  As Long                                                            \'Machine code buffer offset 2
  
    If (uMsg = ALL_MESSAGES) Then                                                \'If all messages
        nMsgCnt = ALL_MESSAGES                                                    \'Indicates that all messages will callback
      Else                                                                        \'Else a specific message number
        Do While nEntry < nMsgCnt                                                \'For each existing entry. NB will skip if nMsgCnt = 0
            nEntry = nEntry + 1
        
            If (aMsgTbl(nEntry) = 0) Then                                        \'This msg table slot is a deleted entry
                aMsgTbl(nEntry) = uMsg                                            \'Re-use this entry
                Exit Sub                                                          \'Bail
            ElseIf (aMsgTbl(nEntry) = uMsg) Then                                  \'The msg is already in the table!
                Exit Sub                                                          \'Bail
            End If
        Loop                                                                      \'Next entry

        nMsgCnt = nMsgCnt + 1                                                    \'New slot required, bump the table entry count
        ReDim Preserve aMsgTbl(1 To nMsgCnt) As Long                              \'Bump the size of the table.
        aMsgTbl(nMsgCnt) = uMsg                                                  \'Store the message number in the table
    End If

    If (When = eMsgWhen.MSG_BEFORE) Then                                          \'If before
        nOff1 = PATCH_04                                                          \'Offset to the Before table
        nOff2 = PATCH_05                                                          \'Offset to the Before table entry count
      Else                                                                        \'Else after
        nOff1 = PATCH_08                                                          \'Offset to the After table
        nOff2 = PATCH_09                                                          \'Offset to the After table entry count
    End If

    If (uMsg <> ALL_MESSAGES) Then
        Call zPatchVal(nAddr, nOff1, VarPtr(aMsgTbl(1)))                          \'Address of the msg table, has to be re-patched because Redim Preserve will move it in memory.
    End If
    Call zPatchVal(nAddr, nOff2, nMsgCnt)                                        \'Patch the appropriate table entry count
End Sub

Private Function zAddrFunc(ByVal sDLL As String, ByVal sProc As String) As Long
    \'Return the memory address of the passed function in the passed dll

    zAddrFunc = GetProcAddress(GetModuleHandleA(sDLL), sProc)
    Debug.Assert zAddrFunc                                                        \'You may wish to comment out this line if you\'re using vb5 else the EbMode GetProcAddress will stop here everytime because we look for vba6.dll first
End Function

Private Sub zDelMsg(ByVal uMsg As Long, ByRef aMsgTbl() As Long, ByRef nMsgCnt As Long, ByVal When As eMsgWhen, ByVal nAddr As Long)
    \'Worker sub for Subclass_DelMsg
    Dim nEntry As Long
  
    If (uMsg = ALL_MESSAGES) Then                                                \'If deleting all messages
        nMsgCnt = 0                                                              \'Message count is now zero
        If When = eMsgWhen.MSG_BEFORE Then                                        \'If before
            nEntry = PATCH_05                                                    \'Patch the before table message count location
          Else                                                                    \'Else after
            nEntry = PATCH_09                                                    \'Patch the after table message count location
        End If
        Call zPatchVal(nAddr, nEntry, 0)                                          \'Patch the table message count to zero
    Else                                                                        \'Else deleteting a specific message
        Do While nEntry < nMsgCnt                                                \'For each table entry
            nEntry = nEntry + 1
            If (aMsgTbl(nEntry) = uMsg) Then                                      \'If this entry is the message we wish to delete
                aMsgTbl(nEntry) = 0                                              \'Mark the table slot as available
                Exit Do                                                          \'Bail
            End If
        Loop                                                                      \'Next entry
    End If
End Sub

Private Function zIdx(ByVal lng_hWnd As Long, Optional ByVal bAdd As Boolean = False) As Long
    \'Get the sc_aSubData() array index of the passed hWnd
    \'Get the upper bound of sc_aSubData() - If you get an error here, you\'re probably Subclass_AddMsg-ing before Subclass_Start

    zIdx = UBound(sc_aSubData)
    Do While zIdx >= 0                                                            \'Iterate through the existing sc_aSubData() elements
        With sc_aSubData(zIdx)
            If (.hWnd = lng_hWnd) Then                                            \'If the hWnd of this element is the one we\'re looking for
                If (Not bAdd) Then                                                \'If we\'re searching not adding
                    Exit Function                                                \'Found
                End If
            ElseIf (.hWnd = 0) Then                                              \'If this an element marked for reuse.
                If (bAdd) Then                                                    \'If we\'re adding
                    Exit Function                                                \'Re-use it
                End If
            End If
        End With
        zIdx = zIdx - 1                                                          \'Decrement the index
    Loop
  
    If (Not bAdd) Then
        Debug.Assert False                                                        \'hWnd not found, programmer error
    End If

    \'If we exit here, we\'re returning -1, no freed elements were found
End Function

Private Sub zPatchRel(ByVal nAddr As Long, ByVal nOffset As Long, ByVal nTargetAddr As Long)
    \'Patch the machine code buffer at the indicated offset with the relative address to the target address.
    Call RtlMoveMemory(ByVal nAddr + nOffset, nTargetAddr - nAddr - nOffset - 4, 4)
End Sub

Private Sub zPatchVal(ByVal nAddr As Long, ByVal nOffset As Long, ByVal nValue As Long)
    \'Patch the machine code buffer at the indicated offset with the passed value
    Call RtlMoveMemory(ByVal nAddr + nOffset, nValue, 4)
End Sub

Private Function zSetTrue(ByRef bValue As Boolean) As Boolean
    \'Worker function for Subclass_InIDE
    zSetTrue = True
    bValue = True
End Function

[此贴子已经被作者于2013-9-15 19:24:22编辑过]
--  作者：aalons
--  发布时间：2013/9/15 12:13:00
--  
\'*************************************************************************
\'**模 块 名：cSetStyle
\'**说    明：为无标题栏窗口模拟默认窗体行为的类
\'**备    注: 需要单类模块子类化类cSubclass.cls支持
\'*************************************************************************

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private 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
Private Declare Function DrawFocusRect Lib "user32.dll" ( _
     ByVal hdc As Long, _
     ByRef lpRect As RECT) As Long
Private Declare Function GetWindowRect Lib "user32.dll" ( _
     ByVal hWnd As Long, _
     ByRef lpRect As RECT) As Long
Private Declare Function GetDC Lib "user32.dll" ( _
     ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" ( _
     ByVal hWnd As Long, _
     ByVal hdc As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" ( _
     ByRef lpPoint As POINTAPI) As Long
Private Declare Function MoveWindow Lib "user32.dll" ( _
     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

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Const GWL_STYLE = (-16)
Private Const WS_SYSMENU = &H80000
Private Const WS_MINIMIZEBOX = &H20000
Private Const SC_CLOSE = &HF060&
Private Const SC_MOVE = &HF010&
Private Const WM_SYSCOMMAND = &H112
Private Const WM_SETTINGCHANGE As Long = &H1A
Private Const WM_MOUSEMOVE As Long = &H200
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_LBUTTONUP As Long = &H202
Private Const MK_LBUTTON As Long = &H1

Dim WithEvents objSubclass As cSubclass
Dim WithEvents m_objForm As Form              \'窗体对象,方便事件封装

Dim m_theHWND As Long, theMonDC As Long, DrawRECT As Boolean, tST As Boolean
Dim MouseStyle As Long          \'鼠标方位,顺时钟0到7,-1表示不在窗体边缘
Dim mX As Long, mY As Long      \'鼠标按下时的座标


Public Event CloseClick()       \'菜单关闭项被点击
Public Event SettingChange()    \'WM_SETTINGCHANGE消息出现,可重绘窗体
Public Event MouseSize(ByVal theMouseStyle As Long)     \'鼠标位置

Public Function SetWindowStyle(ByVal hWnd As Long)
    \'添加任务栏右键菜单,以及启动子类化.
    \'目标窗体的ShowInTaskbar属性需要设置为True.
    m_theHWND = hWnd
    
    Call SetWindowLong(m_theHWND, GWL_STYLE, WS_SYSMENU Or WS_MINIMIZEBOX)    \'添加任务栏菜单样式
    Call objSubclass.AddWindowMsgs(m_theHWND)
End Function

Public Function CallWindowStateChange() As Boolean
    \'最大化与还原效果处理,每次调用切换至另一状态
    \'返回值为窗体状态.
    \'   TRUE为最大化状态,FALSE为非最大化状态
    Static tW As Long, tH As Long, tX As Long, tY As Long
    
    With m_objForm
        If tST Then     \'TRUE,最大化状态
            .Move tX, tY, tW, tH
            tST = False
        Else
            tX = .Left: tY = .Top: tW = .Width: tH = .Height    \'记忆原位置,用于还原
            .Move 0, 0, Screen.Width, Screen.Height - GetTaskbarHeight
            tST = True
        End If
    End With
    CallWindowStateChange = tST
End Function

Private Sub objSubclass_MsgCome(ByVal bBefore As Boolean, bHandled As Boolean, lReturn As Long, lng_hWnd As Long, uMsg As Long, wParam As Long, lParam As Long)
    Static MS As Long, PT As POINTAPI, RT As RECT, LastRT As RECT, NewRT As RECT
    
    If bBefore = False Then Exit Sub
    Select Case uMsg
        Case WM_SYSCOMMAND
            If wParam = SC_CLOSE Then       \'点击了关闭按钮
                RaiseEvent CloseClick
            End If
        Case WM_SETTINGCHANGE           \'WM_SETTINGCHANGE消息出现,比如任务栏被改变等
            RaiseEvent SettingChange
            Call CallSettingChange
        Case WM_LBUTTONDOWN         \'鼠标按下.
            Call GetCursorPos(PT)
            MS = GetMouseStyle(lng_hWnd, PT.X, PT.Y)
            
            If MS <> -1 And DrawRECT = False And tST = False Then           \'如果在调整区内按下鼠标左键
                DrawRECT = True                         \'开始画框
                Call GetWindowRect(lng_hWnd, RT)
                
                mX = PT.X: mY = PT.Y                    \'记录鼠标按下时的座标
                LastRT = RT: NewRT = RT
                
                Call DrawMutiRect(theMonDC, LastRT)
            End If
        Case WM_MOUSEMOVE                   \'鼠标移动
            Call GetCursorPos(PT)
            
            If DrawRECT = False And tST = False Then
                MS = GetMouseStyle(lng_hWnd, PT.X, PT.Y)
                RaiseEvent MouseSize(MS)                    \'窗体中用于改变鼠标样式
                Call CallMouseSize(MS)
            End If
            
            Debug.Print "                                           MouseStyle = " & MS
            
            If (wParam And MK_LBUTTON) And DrawRECT = True Then    \'如果按下鼠标在移动
                If theMonDC = 0 Then theMonDC = GetDC(0)       \'取桌面DC
                With PT
                    Select Case MS
                        Case 0
                            NewRT.Top = .Y
                        Case 1
                            NewRT.Top = .Y: NewRT.Right = .X
                        Case 2
                            NewRT.Right = .X
                        Case 3
                            NewRT.Bottom = .Y: NewRT.Right = .X
                        Case 4
                            NewRT.Bottom = .Y
                        Case 5
                            NewRT.Bottom = .Y: NewRT.Left = PT.X
                        Case 6
                            NewRT.Left = PT.X
                        Case 7
                            NewRT.Top = .Y: NewRT.Left = .X
                    End Select
                End With
                Call DrawMutiRect(theMonDC, LastRT)     \'先擦除原来的框
                Call DrawMutiRect(theMonDC, NewRT)      \'画新的框
                LastRT = NewRT
                
                Debug.Print "                                       " & NewRT.Top, NewRT.Bottom, NewRT.Left, NewRT.Right
            End If
        Case WM_LBUTTONUP
            If DrawRECT = True Then
                DrawRECT = False
                Call DrawMutiRect(theMonDC, LastRT)         \'先擦除原来的框
                With LastRT                                 \'改变窗体大小与位置
                    Call MoveWindow(lng_hWnd, .Left, .Top, .Right - .Left, .Bottom - .Top, True)
                End With
                Call ReleaseDC(0, theMonDC): theMonDC = 0   \'再释放DC
            End If
    End Select
End Sub

Private Sub DrawMutiRect(ByVal DestDC As Long, ByRef RT As RECT)
    \'画框.
    \'画三次是为了粗一点(如果觉得细了的话就去掉注释)
    Dim I As RECT
    
    I = RT
    DrawFocusRect DestDC, I
\'    With I
\'        .Left = .Left + 1
\'        .Top = .Top + 1
\'        .Right = .Right - 1
\'        .Bottom = .Bottom - 1
\'    End With
\'    DrawFocusRect DestDC, I
\'    With I
\'        .Left = .Left - 2
\'        .Top = .Top - 2
\'        .Right = .Right + 2
\'        .Bottom = .Bottom + 2
\'    End With
\'    DrawFocusRect DestDC, I
End Sub

Private Function GetMouseStyle(ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long) As Long
    \'取鼠标方位,0到7,分成8个方位.
    \'7 0 1
    \'6   2
    \'5 4 3
    Const WC As Long = 5        \'5个象素以内有效
    Dim RT As RECT, XOK As Long, YOK As Long
    
    GetMouseStyle = -1
    
    Call GetWindowRect(hWnd, RT)
    With RT
        Do
            If Abs(.Left - X) <= WC And Abs(.Bottom - Y) <= WC Then
                \'左下角判定
                GetMouseStyle = 5
                Exit Do
            End If
            If Abs(.Left - X) <= WC And Abs(.Top - Y) <= WC Then
                \'左上角判定
                GetMouseStyle = 7
                Exit Do
            End If
            If Abs(.Right - X) <= WC And Abs(.Bottom - Y) <= WC Then
                \'右下角判定
                GetMouseStyle = 3
                Exit Do
            End If
            If Abs(.Right - X) <= WC And Abs(.Top - Y) <= WC Then
                \'右上角判定
                GetMouseStyle = 1
                Exit Do
            End If
            If X > .Left + WC And X < .Right - WC And Abs(.Top - Y) <= WC Then
                \'上边判定
                GetMouseStyle = 0
                Exit Do
            End If
            If Abs(.Right - X) <= WC And Y < .Bottom - WC And Y > .Top + WC Then
                \'右边判定
                GetMouseStyle = 2
                Exit Do
            End If
            If X > .Left + WC And X < .Right - WC And Abs(.Bottom - Y) <= WC Then
                \'下边判定
                GetMouseStyle = 4
                Exit Do
            End If
            If Abs(.Left - X) <= WC And Y < .Bottom - WC And Y > .Top + WC Then
                \'左边判定
                GetMouseStyle = 6
                Exit Do
            End If
            Exit Do
        Loop
    End With
End Function

Private Sub CallSettingChange()
    \'任务栏改变等事件
    If tST And m_objForm.WindowState <> vbMinimized Then m_objForm.Move 0, 0, Screen.Width, Screen.Height - GetTaskbarHeight
End Sub

Private Sub CallMouseSize(ByVal theMouseStyle As Long)
    \'边缘位置时的鼠标样式改变
    With m_objForm
        Select Case theMouseStyle
            Case 0, 4     \'上下边
                .MousePointer = vbSizeNS
            Case 1, 5     \'左下右上角
                .MousePointer = vbSizeNESW
            Case 2, 6     \'左右边
                .MousePointer = vbSizeWE
            Case 3, 7     \'左上右下角
                .MousePointer = vbSizeNWSE
            Case Else
                .MousePointer = vbArrow
        End Select
    End With
End Sub

Private Function LoWord(ByVal DWord As Long) As Integer
    \'低字
    If DWord And &H8000& Then
        LoWord = DWord Or &HFFFF0000
    Else
        LoWord = DWord And &HFFFF&
    End If
End Function

Private Function HiWord(ByVal DWord As Long) As Integer
    \'高字
    HiWord = (DWord And &HFFFF0000) \\ 65536
End Function

Private Sub Class_Initialize()
    Set objSubclass = New cSubclass
End Sub

Private Sub Class_Terminate()
    objSubclass.DeleteWindowMsg m_theHWND
    Set objSubclass = Nothing
End Sub

Public Property Get objForm() As Form
    Set objForm = m_objForm
End Property

Public Property Let objForm(ByVal vNewValue As Form)
    Set m_objForm = vNewValue
End Property

[此贴子已经被作者于2013-9-15 19:25:52编辑过]
--  作者：aalons
--  发布时间：2013/9/15 15:14:00
--  
顶3
--  作者：aalons
--  发布时间：2013/9/15 19:17:00
--  
顶4  高手今天都不在
--  作者：有点甜
--  发布时间：2013/9/15 20:13:00
--  
 如果要关闭主窗口，用代码 basemainform.close

 没有闲心做任务栏的右键菜单。楼主自己想办法吧。
--  作者：有点甜
--  发布时间：2013/9/15 20:49:00
--  
 感觉有趣，还是做了一下，楼主参考下。

 
 下载信息  [文件大小：   下载次数： ]
图片点击可在新窗口打开查看点击浏览该文件:任务栏.table
--  作者：aalons
--  发布时间：2013/9/16 1:09:00
--  
以下是引用有点甜在2013-9-15 20:49:00的发言：
 感觉有趣，还是做了一下，楼主参考下。

 
 下载信息  [文件大小：332.0 KB  下载次数：1]
图片点击可在新窗口打开查看点击浏览该文件:任务栏.table
谢谢，谢谢，敬仰之情有如滔滔江水。
--  作者：lsy
--  发布时间：2013/9/16 7:35:00
--  
楼主的坚持，有点甜的敬业，都让人敬佩。
--  作者：aalons
--  发布时间：2013/9/16 8:28:00
--  
只是好像右键关闭还是只关闭当前窗口，露出后面的Foxtable窗口？？有点甜？？你那边是吗？