FORM LATERAL FIXO NO DESKTOP
Uso um código, que vou compartilhar em seguida, para deixar um menu fixo no desktop.
Ele reserva a área e empurra todos os ícones e janelas para a sua direita.
No entanto, se eu preciso redimensionar o form, o "rebosteio" é grande. Geralmente trava e fecha tudo.
É uma novela mexer com este form quando ele tem este espaço fixo no windows.
Não sei onde encontrei esse código no passado, também não sei fazer manutenção nele.
Gostaria de saber se alguém tem alguma ideia melhor ou um código parecido.
Ele reserva a área e empurra todos os ícones e janelas para a sua direita.
No entanto, se eu preciso redimensionar o form, o "rebosteio" é grande. Geralmente trava e fecha tudo.
É uma novela mexer com este form quando ele tem este espaço fixo no windows.
Não sei onde encontrei esse código no passado, também não sei fazer manutenção nele.
Gostaria de saber se alguém tem alguma ideia melhor ou um código parecido.
o código
Option Explicit
Public Const TH32CS_SNAPPROCESS As Long = 2&
Public Const MAX_PATH As Long = 260
Public Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Public Const PROCESS_ALL_ACCESS As Long = &H1F0FFF
Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" _
(ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Public Declare Function ProcessFirst Lib "kernel32" _
Alias "Process32First" _
(ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Public Declare Function ProcessNext Lib "kernel32" _
Alias "Process32Next" _
(ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Public Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Public Declare Function TerminateProcess Lib "kernel32" _
(ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Public Declare Sub CloseHandle Lib "kernel32" _
(ByVal hPass As Long)
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'For intellisense
Public Enum AppBarPos
abpLeft = 0&
abpTop = 1&
abpRight = 2&
abpBottom = 3&
End Enum
'A rect(angle)
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'AppBarData struct
Private Type APPBARDATA
cbSize As Long
hwnd As Long
ucallbackMessage As Long
uEdge As Long
rc As RECT
lParam As Long ' message specific
End Type
'This function makes it happen. Nothing can be done without it
Private Declare Function SHAppBarMessage Lib "shell32" ( _
ByVal dwMessage As Long, _
pData As APPBARDATA) As Long
'We dont *have* to subclass, but we do want to do things right, dont we?
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
'Used to forward window messages to the next window proc in the queue
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
'Move the window
Private 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 wFlags As Long) As Long
'Get the window dimensions
Private Declare Function GetWindowRect Lib "user32" ( _
ByVal hwnd As Long, _
lpRect As RECT) As Long
'Get desktop window
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Const ABM_NEW = &H0
Const ABM_REMOVE = &H1
Const ABM_QUERYPOS = &H2
Const ABM_SETPOS = &H3
Const ABM_GETSTATE = &H4
Const ABM_GETTASKBARPOS = &H5
Const ABM_ACTIVATE = &H6 ' lParam == TRUE/FALSE means activate/deactivate
Const ABM_GETAUTOHIDEBAR = &H7
Const ABM_SETAUTOHIDEBAR = &H8 ' this can fail at any time. MUST check the result
Const ABM_WINDOWPOSCHANGED = &H9
Const ABN_STATECHANGE = &H0
Const ABN_POSCHANGED = &H1
Const ABN_FULLSCREENAPP = &H2
Const ABN_WINDOWARRANGE = &H3 ' lParam == TRUE means hide
Const ABS_AUTOHIDE = &H1
Const ABS_ALWAYSONTOP = &H2
Const WM_USER = &H400
Const WM_ACTIVATE = &H6
Const WM_SIZE = &H5
Const WM_MOVE = &H3
Const GWL_WNDPROC = (-4)
Const HWND_TOP = 0&
Const HWND_BOTTOM = 1&
Const SWP_NOSIZE = &H1&
Const SWP_NOMOVE = &H2&
Const SWP_NOZORDER = &H4
'The old windowproc
Dim lOldProc As Long
'The hWnd
Dim lhWnd As Long
'Since we need this so much, just keep a copy permanently
Dim abdAppBar As APPBARDATA
Public Function CloseProcess(EXEName As String, Optional bOnlyFirstInstance As Boolean = False) As Boolean
Dim hSnapShot As Long
Dim uProcess As PROCESSENTRY32
Dim hProcess As Long
CloseProcess = False
hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&)
If hSnapShot = -1 Then Exit Function
uProcess.dwSize = Len(uProcess)
If ProcessFirst(hSnapShot, uProcess) = 1 Then
Do
If LCase$(Left$(uProcess.szExeFile, InStr(1, uProcess.szExeFile, vbNullChar) - 1)) = LCase$(EXEName) Then
hProcess = OpenProcess(PROCESS_ALL_ACCESS, False, uProcess.th32ProcessID)
CloseProcess = TerminateProcess(hProcess, ByVal 0&) > 0
If bOnlyFirstInstance = True Then Exit Do
End If
Loop While ProcessNext(hSnapShot, uProcess)
End If
Call CloseHandle(hSnapShot)
End Function
Public Sub StartAppBar(frm As Form, position As AppBarPos)
'Dont want to subclass twice
On Error GoTo sErr
If lOldProc = 0 Then
Dim rScreen As RECT
Dim rFrm As RECT
GetWindowRect GetDesktopWindow, rScreen
GetWindowRect frm.hwnd, rFrm
rFrm.Bottom = rFrm.Bottom - rFrm.Top
rFrm.Right = rFrm.Right - rFrm.Left
rFrm.Top = 0
rFrm.Left = 0
lhWnd = frm.hwnd
'Subclass !
lOldProc = SetWindowLong(lhWnd, GWL_WNDPROC, AddressOf AppBarProc)
abdAppBar.cbSize = Len(abdAppBar)
abdAppBar.hwnd = lhWnd
abdAppBar.ucallbackMessage = WM_USER
If SHAppBarMessage(ABM_NEW, abdAppBar) = 0 Then
'Uh-oh, something went wrong!
StopAppBar
Exit Sub
End If
'Where is the taskbar?
SHAppBarMessage ABM_GETTASKBARPOS, abdAppBar
'Size our window so its in the right place
With abdAppBar.rc
If .Top > rScreen.Top Then
'Taskbar is at the bottom
rScreen.Bottom = .Top
ElseIf .Bottom < rScreen.Bottom Then
'Taskbar is at the top
rScreen.Top = .Bottom
ElseIf .Right < rScreen.Right Then
'Taskbar is at the left
rScreen.Left = .Right
Else
'Taskbar is at the right
rScreen.Right = .Left
End If
abdAppBar.rc = rScreen
Select Case position
Case AppBarPos.abpLeft
.Right = rFrm.Right
Case AppBarPos.abpTop
.Bottom = rFrm.Bottom
Case AppBarPos.abpRight
.Left = .Right - rFrm.Right
Case AppBarPos.abpBottom
.Top = .Bottom - rFrm.Bottom
End Select
End With
'Which edge are we using?
abdAppBar.uEdge = position
'Ask the OS to find us a space to put the AppBar
SHAppBarMessage ABM_QUERYPOS, abdAppBar
'Tell the OS we're putting our AppBar there (OS reduces desktop space to fit)
SHAppBarMessage ABM_SETPOS, abdAppBar
'Move our window
SetWindowPos lhWnd, 0, abdAppBar.rc.Left, _
abdAppBar.rc.Top, abdAppBar.rc.Right - abdAppBar.rc.Left, _
abdAppBar.rc.Bottom - abdAppBar.rc.Top, SWP_NOZORDER
End If
sErr:
If err.Number <> 0 Then mSYS_Err err, "StartAppBar": Exit Sub
End Sub
Public Sub StopAppBar()
'Dont want to unsubclass a non-subclassed window
On Error GoTo sErr
If lOldProc Then
'Tell the OS we're done with the AppBar
SHAppBarMessage ABM_REMOVE, abdAppBar
'Unsubclass
SetWindowLong lhWnd, GWL_WNDPROC, lOldProc
'Reset so we can do it all again
lOldProc = 0
End If
sErr:
If err.Number <> 0 Then mSYS_Err err, "StopAppBar": Exit Sub
End Sub
Public Function AppBarProc(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
On Error GoTo sErr
Select Case uMsg
Case WM_ACTIVATE
'Window got activated
SHAppBarMessage ABM_ACTIVATE, abdAppBar
Case WM_USER
'Special AppBar message
Select Case wParam
Case ABN_STATECHANGE
'Notifies an appbar that the taskbar's autohide or _
always-on-top state has changed-that is,
'the user has selected or cleared the "Always on top" or _
"Auto hide" check box on the taskbar's property sheet.
Case ABN_POSCHANGED
'Notifies an appbar when an event has occurred that may affect _
the appbar's size and position.
'Events include changes in the taskbar's size, position, and visibility _
state, as well as the
'addition, removal, or resizing of another appbar on the same side of the screen.
GetWindowRect lhWnd, abdAppBar.rc
SHAppBarMessage ABM_QUERYPOS, abdAppBar
SHAppBarMessage ABM_SETPOS, abdAppBar
SetWindowPos lhWnd, 0, abdAppBar.rc.Left, abdAppBar.rc.Top, _
abdAppBar.rc.Right, abdAppBar.rc.Bottom, SWP_NOZORDER
Case ABN_FULLSCREENAPP
'Notifies an appbar when a full-screen application is opening or closing.
'This notification is sent in the form of an application-defined _
message that is set by the ABM_NEW message.
If CBool(lParam) Then
'Fullscreen app is loading!
'Pop
Ricardo, poste o codigo para alguma IA e ele vai fazer algo que voce pedir ....
Faça seu login para responder