Results 1 to 2 of 2

Thread: Desktop Fixed Menu ? bug

  1. #1

    Thread Starter
    Junior Member ricardoweb084's Avatar
    Join Date
    Mar 2024
    Posts
    18

    Lightbulb Desktop Fixed Menu ? bug

    I use this code to make a menu fixed to the desktop.

    It reserves the area and pushes all the icons and windows to the right.

    However, if I need to resize the form, it usually crashes and closes everything. I don't know where I found it, and I also don't know how to maintain it.

    I would like to know if anyone has a better idea or similar code.

    Name:  Sem título.jpg
Views: 221
Size:  14.0 KB


    Code:
    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
    
    
    'Function Fg_EncerraProcesso(Arquivo As String)
        'CloseProcess Arquivo, False
        'Sleep (1000)
    'End Function
    
    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
       'Exit Sub
       If mSYS.mSYS_bMenuLateral = False Then Exit Sub
        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
       'Exit Sub
       If mSYS.mSYS_bMenuLateral = False Then Exit Sub
       
        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
       If mSYS.mSYS_bMenuLateral = False Then Exit Function
        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 AppBar to the back
                    SetWindowPos lhWnd, HWND_BOTTOM, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
                Else
                    'Fullscreen app finished
                    'Pop AppBar to the front
                    SetWindowPos lhWnd, HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
                End If
                  
            Case ABN_WINDOWARRANGE
                'Notifies an appbar that the user has selected the Cascade,
                'Tile Horizontally, or Tile Vertically command from the taskbar's context menu.
                  
            End Select
        End Select
        'Forward message to next windowproc
        AppBarProc = CallWindowProc(lOldProc, hwnd, uMsg, wParam, lParam)
    
    sErr:
       If err.Number <> 0 Then mSYS_Err err, "AppBarProc": Exit Function
    End Function

  2. #2

    Thread Starter
    Junior Member ricardoweb084's Avatar
    Join Date
    Mar 2024
    Posts
    18

    Re: Desktop Fixed Menu ? bug

    For now I have abandoned this solution. It brings more problems than results.
    When resizing a form with this code, the system and the workspace get very buggy.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width