Tuy nhiên việc này đôi khi lại không cần thiết và làm choáng chỗ làm việc trong vùng soạn thảo và bạn có thể đóng cửa sổ này Task Pane đi nếu không muốn nó tiếp tục hiển thị nữa.
Forms
Option Explicit
' | |
' | |
' | | | | / /
' | || |__ ____ (_) ____ / /
' | | | _ \ / _ | | | | _ \ \ / /
' | |_| | | | |_| |_| |_| |_| \ \/ /
' \____| | |\__________ __/ \__/
' | |
' | |
' | |
Public Enum DockPositions
None = -1
'Floating = 0
EdgeLeft = 1
'EdgeTop = 2
EdgeRight = 3
'EdgeBottom = 4
End Enum
#If VBA7 Then
Private hDeskWnd As LongPtr 'XLDESK
Private hBookWnd As LongPtr 'EXCEL7
Private hFormWnd As LongPtr 'Handle of this form
#Else
Private hDeskWnd As Long 'XLDESK
Private hBookWnd As Long 'EXCEL7
Private hFormWnd As Long 'Handle of this form
#End If
Public Location As DockPositions
Private PixelL As Long
Private PixelT As Long
Private isHooked As Boolean
Private WithEvents wbkThis As Workbook
'// Initialize of this form
Private Sub UserForm_Initialize()
Dim PointL As Single, PointT As Single, PointW As Single, PointH As Single
Dim clsConvert As cUnitCvt, clsWindow As cWindow
'// Get handles of XLDESK window and EXCEL7 window
hFormWnd = FindWindow("ThunderDFrame", Me.Caption)
hDeskWnd = FindWindowEx(Application.hWnd, 0&, "XLDESK", vbNullString)
hBookWnd = FindWindowEx(hDeskWnd, 0&, "EXCEL7", vbNullString)
'// Design this form
With Me
PointL = (.Width - .InsideWidth) / 2
PointT = (.Height - .InsideHeight) - PointL
PointW = .InsideWidth
PointH = .InsideHeight
End With
Set clsConvert = New cUnitCvt
PixelL = clsConvert.PointsToPixelsX(PointL)
PixelT = clsConvert.PointsToPixelsY(PointT)
Set clsWindow = New cWindow
With clsWindow
.Handle = hFormWnd
.CropRectangle PixelL, PixelT, _
PixelL + clsConvert.PointsToPixelsX(PointW), _
PixelT + clsConvert.PointsToPixelsY(PointH)
.SetParent hDeskWnd
End With
'// Set object wbkThis and release memory
Set wbkThis = ThisWorkbook
Set clsConvert = Nothing: Set clsWindow = Nothing
End Sub
Private Sub UserForm_Activate()
Call SetPosition: Call StartHook
End Sub
'================ CUSTORM TASK PANE : START ================
Friend Sub SetPosition(Optional ByRef Position As DockPositions = EdgeLeft)
If Location <> Position Then
Location = Position: Call SetLayout
End If
End Sub
Friend Sub SetLayout()
Dim rectDesk As RECT, w0 As Long, h0 As Long
Dim rectForm As RECT, w1 As Long, h1 As Long
'// Get properties of hDeskWnd
Call GetWindowRect(hDeskWnd, rectDesk)
w0 = rectDesk.Right - rectDesk.Left
h0 = rectDesk.Bottom - rectDesk.Top
'// Get properties of hDockForm
Call GetWindowRect(hFormWnd, rectForm)
w1 = rectForm.Right - rectForm.Left
h1 = rectForm.Bottom - rectForm.Top
'// Set positon of DockForm and window of this workbook (hBookWnd)
Application.ScreenUpdating = False
Select Case Location
Case EdgeLeft
Call MoveWindow(hBookWnd, w1 - 2 * PixelL - 1, 0, w0 - w1 + 2 * PixelL, h0, True)
Call MoveWindow(hFormWnd, -PixelL - 1, -PixelT - 1, w1, h1, True)
Case EdgeRight
Call MoveWindow(hBookWnd, 0, 0, w0 - w1 + 2 * PixelL + 1, h0, True)
Call MoveWindow(hFormWnd, w0 - w1 + PixelL + 2, -PixelT - 1, w1, h1, True)
Case None
Call MoveWindow(hBookWnd, 0, 0, w0, h0, True)
End Select
Application.ScreenUpdating = True
End Sub
Private Sub StartHook()
#If VBA7 Then
lpPrevProc = SetWindowLongPtr(hDeskWnd, GWL_WNDPROC, AddressOf xlDeskProc)
#Else
lpPrevProc = SetWindowLong(hDeskWnd, GWL_WNDPROC, AddressOf xlDeskProc)
#End If
Call SavePointer(lpPrevProc, "lpPrevProc")
isHooked = True
End Sub
Private Sub StopHook()
If 0 = lpPrevProc Then Call RecoverPointer(lpPrevProc, "lpPrevProc")
If 0 <> lpPrevProc Then
#If VBA7 Then
Call SetWindowLongPtr(hDeskWnd, GWL_WNDPROC, lpPrevProc)
#Else
Call SetWindowLong(hDeskWnd, GWL_WNDPROC, lpPrevProc)
#End If
lpPrevProc = 0
End If
End Sub
'================ CUSTORM TASK PANE : END ================
'// Catch some events of wbkThis (ThisWorkbook)
Private Sub wbkThis_Activate()
If isHooked Then StartHook
End Sub
Private Sub wbkThis_Deactivate()
If isHooked Then StopHook
End Sub
Private Sub wbkThis_BeforeClose(Cancel As Boolean)
Unload Me
End Sub
'// Catch events of some controls
Private Sub lblExit_Click()
Unload Me
End Sub
Private Sub UserForm_Terminate()
Call SetPosition(None): Call StopHook
Set wbkThis = Nothing
End Sub
Model 1
Option Explicit
' | |
' | |
' | | | | / /
' | || |__ ____ (_) ____ / /
' | | | _ \ / _ | | | | _ \ \ / /
' | |_| | | | |_| |_| |_| |_| \ \/ /
' \____| | |\__________ __/ \__/
' | |
' | |
' | |
#If VBA7 Then
Public Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As LongPtr, _
ByVal hWnd As LongPtr, _
ByVal Msg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Public Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hWnd1 As LongPtr, _
ByVal hWnd2 As LongPtr, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As LongPtr
Public Declare PtrSafe Function MoveWindow Lib "user32" ( _
ByVal hWnd As LongPtr, _
ByVal x As Long, _
ByVal Y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Public Declare PtrSafe Function SetParent Lib "user32" ( _
ByVal hWndChild As LongPtr, _
ByVal hWndNewParent As LongPtr) As LongPtr
#If Win64 Then
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" ( _
ByVal hWnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
#Else
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
#End If
Public Declare PtrSafe Function CreatePolygonRgn Lib "gdi32" ( _
lpPoint As POINTAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long) As LongPtr
Public Declare PtrSafe Function CreateRectRgn Lib "gdi32" ( _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As LongPtr
Public Declare PtrSafe Function DeleteObject Lib "gdi32" ( _
ByVal hObject As LongPtr) As Long
Public Declare PtrSafe Function GetDC Lib "user32" ( _
ByVal hWnd As LongPtr) As LongPtr
Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" ( _
ByVal hDC As LongPtr, _
ByVal nIndex As Long) As Long
#If Win64 Then
Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" ( _
ByRef hWnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
#Else
Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" ( _
ByRef hWnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
#End If
Public Declare PtrSafe Function GetWindowRect Lib "user32" ( _
ByVal hWnd As LongPtr, _
lpRect As RECT) As Long
Public Declare PtrSafe Function LockWindowUpdate Lib "user32" ( _
ByVal hwndLock As LongPtr) As Long
Public Declare PtrSafe Function ReleaseCapture Lib "user32" () As Long
Public Declare PtrSafe Function ReleaseDC Lib "user32" ( _
ByVal hWnd As LongPtr, _
ByVal hDC As LongPtr) As Long
Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hWnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As Any) As LongPtr
Public Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" ( _
ByVal hWnd As LongPtr, _
ByVal crey As Byte, _
ByVal bAlpha As Byte, _
ByVal dwFlags As Long) As LongPtr
Public Declare PtrSafe Function SetWindowPos Lib "user32" ( _
ByVal hWnd As LongPtr, _
ByVal hWndInsertAfter As LongPtr, _
ByVal x As Long, _
ByVal Y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal uFlags As Long) As Long
Public Declare PtrSafe Function SetWindowRgn Lib "user32" ( _
ByVal hWnd As LongPtr, _
ByVal hRgn As LongPtr, _
ByVal bRedraw As Long) As Long
#Else
Public 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
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
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 SetParent Lib "user32" ( _
ByVal hWndChild As Long, ByVal _
hWndNewParent As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Declare Function CreatePolygonRgn Lib "gdi32" ( _
lpPoint As POINTAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long) As Long
Public Declare Function CreateRectRgn Lib "gdi32" ( _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long
Public Declare Function GetDC Lib "user32.dll" ( _
ByVal hWnd As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Public Declare Function GetParent Lib "user32" ( _
ByVal hWnd As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
ByRef hWnd As Long, _
ByVal nIndex As Long) As Long
Public Declare Function GetWindowRect Lib "user32" ( _
ByVal hWnd As Long, _
lpRect As RECT) As Long
Public Declare Function LockWindowUpdate Lib "user32" ( _
ByVal hwndLock As Long) As Long
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function ReleaseDC Lib "user32" ( _
ByVal hWnd As Long, _
ByVal hDC As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Any) As Long
Public Declare Function SetLayeredWindowAttributes Lib "user32" ( _
ByVal hWnd As Long, _
ByVal crey As Byte, _
ByVal bAlpha As Byte, _
ByVal dwFlags As Long) As Long
Public Declare Function SetWindowPos Lib "user32" ( _
ByVal hWnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal x As Long, _
ByVal Y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal uFlags As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" ( _
ByVal hWnd As Long, _
ByVal hRgn As Long, _
ByVal bRedraw As Long) As Long
#End If
Public Type POINTAPI
x As Long
Y As Long
End Type
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Const GWL_WNDPROC As Long = (-4)
Public Const WM_SIZE As Long = &H5
Public Const WM_SIZING As Long = &H214
Module 2
'Option Private Module
Option Explicit
' | |
' | |
' | | | | / /
' | || |__ ____ (_) ____ / /
' | | | _ \ / _ | | | | _ \ \ / /
' | |_| | | | |_| |_| |_| |_| \ \/ /
' \____| | |\__________ __/ \__/
' | |
' | |
' | |
#If VBA7 Then
Public lpPrevProc As LongPtr
Public Sub SavePointer(ByRef lpValue As LongPtr, ByRef strNote As String)
Call SaveSetting("HookLabs", "TaskPane", strNote, lpValue)
End Sub
Public Sub RecoverPointer(ByRef lpValue As LongPtr, ByRef strNote As String)
lpValue = CLngPtr(GetSetting("HookLabs", "TaskPane", strNote))
End Sub
Public Function xlDeskProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
If WM_SIZE = uMsg Then
Call frmTaskPane.SetLayout
Else
If 0 = lpPrevProc Then Call RecoverPointer(lpPrevProc, "lpPrevProc")
If 0 <> lpPrevProc Then
xlDeskProc = CallWindowProc(lpPrevProc, hWnd, uMsg, wParam, lParam)
End If
End If
End Function
#Else
Public lpPrevProc As Long
Public Sub SavePointer(ByRef lpValue As Long, ByRef strNote As String)
Call SaveSetting("HookLabs", "TaskPane", strNote, lpValue)
End Sub
Public Sub RecoverPointer(ByRef lpValue As Long, ByRef strNote As String)
lpValue = CLng(GetSetting("HookLabs", "TaskPane", strNote))
End Sub
Public Function xlDeskProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If WM_SIZE = uMsg Then
Call frmTaskPane.SetLayout
Else
If 0 = lpPrevProc Then Call RecoverPointer(lpPrevProc, "lpPrevProc")
If 0 <> lpPrevProc Then
xlDeskProc = CallWindowProc(lpPrevProc, hWnd, uMsg, wParam, lParam)
End If
End If
End Function
#End If
Public Sub ShowTaskPane()
If Not frmTaskPane.Visible Then
frmTaskPane.Show
Else
Unload frmTaskPane
End If
End Sub
Public Sub ChangeDockPosition()
If Not frmTaskPane.Visible Then
frmTaskPane.Show
Else
If EdgeLeft = frmTaskPane.Location Then
frmTaskPane.Location = EdgeRight
Else
frmTaskPane.Location = EdgeLeft
End If
frmTaskPane.SetLayout
End If
End Sub
Class Module 1 :
Option Explicit
' | |
' | |
' | | | | / /
' | || |__ ____ (_) ____ / /
' | | | _ \ / _ | | | | _ \ \ / /
' | |_| | | | |_| |_| |_| |_| \ \/ /
' \____| | |\__________ __/ \__/
' | |
' | |
' | |
'Author: thaipv@live.com
'Date: 31/08/2019
#If VBA7 Then
Private hDC As LongPtr
#Else
Private hDC As Long
#End If
Private Const POINTSPERINCH = 72
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
'// Initialize
Private Sub Class_Initialize()
hDC = GetDC(0)
End Sub
'// Conver points to pixels
Friend Function PointsToPixelsX(ByRef sngPoints As Single) As Long
PointsToPixelsX = sngPoints * GetDeviceCaps(hDC, LOGPIXELSX) / POINTSPERINCH
End Function
Friend Function PointsToPixelsY(ByRef sngPoints As Single) As Long
PointsToPixelsY = sngPoints * GetDeviceCaps(hDC, LOGPIXELSY) / POINTSPERINCH
End Function
'// Convert pixels to points
Friend Function PixelsToPointsX(ByRef lngPixels As Long) As Single
PixelsToPointsX = lngPixels / GetDeviceCaps(hDC, LOGPIXELSX) * POINTSPERINCH
End Function
Friend Function PixelsToPointsY(ByRef lngPixels As Long) As Single
PixelsToPointsY = lngPixels / GetDeviceCaps(hDC, LOGPIXELSY) * POINTSPERINCH
End Function
'// Convert centimeters to points '// Convert points to centimeters
'// Convert centimeters to pixels '// Convert pixels to centimeters
'// Terminate
Private Sub Class_Terminate()
ReleaseDC 0, hDC
End Sub
Class Module 2 :
Option Explicit
Option Base 0
' | |
' | |
' | | | | / /
' | || |__ ____ (_) ____ / /
' | | | _ \ / _ | | | | _ \ \ / /
' | |_| | | | |_| |_| |_| |_| \ \/ /
' \____| | |\__________ __/ \__/
' | |
' | |
' | |
'Author: thaipv@live.com
'Date: #08/08/2019#
#If VBA7 Then
Private hWindow As LongPtr, hParent_ As LongPtr
Public Property Let Handle(hValue As LongPtr): hWindow = hValue: End Property
#Else
Private hWindow As Long, hParent_ As Long
Public Property Let Handle(hValue As Long): hWindow = hValue: End Property
#End If
'// Crop window
Friend Sub CropPolygon(ByRef PointsPX() As POINTAPI) ' O---------------------------->
Const ALTERNATE = 1 ', WINDING = 2 ' | A-----------------B
#If VBA7 Then ' | |//////////////////\
Dim hDrawRegion As LongPtr ' | |///////////////////\
#Else ' | |////////////////////\
Dim hDrawRegion As Long ' | |/////////////////////\
#End If ' | D----------------------C
' v
Call LockWindowUpdate(hWindow)
hDrawRegion = CreatePolygonRgn(PointsPX(0), UBound(PointsPX), ALTERNATE)
Call SetWindowRgn(hWindow, hDrawRegion, True)
Call DeleteObject(hDrawRegion)
Call LockWindowUpdate(0&)
End Sub
Friend Sub CropRectangle(ByRef X1 As Long, ByRef Y1 As Long, _
ByRef X2 As Long, ByRef Y2 As Long)
#If VBA7 Then
Dim hDrawRegion As LongPtr ' O --------------------------->
#Else ' | (x1,y1)----------------
Dim hDrawRegion As Long ' | |//////////////////////|
#End If ' | |//////////////////////|
' | |//////////////////////|
Call LockWindowUpdate(hWindow) ' | |//////////////////////|
hDrawRegion = CreateRectRgn(X1, Y1, X2, Y2) ' | ----------------(x2,y2)
Call SetWindowRgn(hWindow, hDrawRegion, True) ' v
Call DeleteObject(hDrawRegion)
Call LockWindowUpdate(0&)
End Sub
'Make window is transparent
'NOT WORK with SetParen method
Friend Sub Transparent(Optional ByRef Opacity As Byte = 255)
Const GWL_EXSTYLE = (-20), WS_EX_LAYERED = &H80000, LWA_ALPHA = &H2&
#If VBA7 Then
Dim hResult As LongPtr
hResult = GetWindowLongPtr(hWindow, GWL_EXSTYLE) Or WS_EX_LAYERED
Call SetWindowLongPtr(hWindow, GWL_EXSTYLE, hResult)
#Else
Dim hResult As Long
hResult = GetWindowLong(hWindow, GWL_EXSTYLE) Or WS_EX_LAYERED
Call SetWindowLong(hWindow, GWL_EXSTYLE, hResult)
#End If
Call SetLayeredWindowAttributes(hWindow, 0&, Opacity, LWA_ALPHA)
End Sub
'Make window is alway on top
'NOT WORK with SetParen method
Friend Sub AlwaysOnTop(Optional Status As Boolean = True)
Const SWP_NOMOVE = &H2, HWND_TOPMOST = -1
Const SWP_NOSIZE = &H1, HWND_NOTOPMOST = -2
If Status Then
Call SetWindowPos(hWindow, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
Else
Call SetWindowPos(hWindow, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End If
End Sub
'Make window is a child of a window (parent window)
#If VBA7 Then
Friend Sub SetParent(ByVal hParent As LongPtr)
hParent_ = hParent
Call mDeclare.SetParent(hWindow, hParent)
End Sub
#Else
Friend Sub SetParent(ByVal hParent As Long)
hParent_ = hParent
Call mDeclare.SetParent(hWindow, hParent)
End Sub
#End If
'Move form when drag mouse anywhere of the background object
Friend Sub FlexMove()
Const WM_NCLBUTTONDOWN = &HA1, HTCAPTION = 2
Call Transparent(180)
Call LockWindowUpdate(hWindow)
Call ReleaseCapture
Call SendMessage(hWindow, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
Call Transparent
Call LockWindowUpdate(0&)
End Sub
Chúc bạn thành công
Đăng nhận xét