Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Minimize to tray title bar button

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Minimize to tray title bar button

    Code:
    ' MinTrayTest.bas
    
    ' Minimize to Tray Title bar button
    ' Tested under Win98/ME,Win2K/XP
    ' Work with Normal and Tool windows
    ' Work with Themed windows under WinXP
    '
    ' This code have been adapted from CDialogMinTrayBtn template class
    ' eMule project (http://www.emule-project.net)
    '
    ' Public Domain
    
    ' Compiled with PBDLL 6.11
    ' The only problem i don't know how to solve is flicker effect when
    ' the window is resized, activated or deactivated
    
    #Compile Exe
    
    #Include "win32api.inc"
    #Include "mintraybtn.inc"
    
    Function PbMain()
      Local szClassName As Asciiz * 32
      Local wc          As WndClassEx
      Local hWnd        As DWord
      Local Msg         As tagMsg
    
      szClassName = "MinTrayBtnTest"
    
      ' Register Window Class
      wc.cbSize        = SizeOf(WndClassEx)
      wc.style         = %CS_HREDRAW Or %CS_VREDRAW
      wc.lpfnWndProc   = CodePtr( WndProc )
      wc.cbClsExtra    = 0
      wc.cbWndExtra    = 0
      wc.hInstance     = GetModuleHandle(ByVal %NULL)
      wc.hIcon         = LoadIcon( %NULL, ByVal %IDI_APPLICATION )
      wc.hCursor       = LoadCursor( %NULL, ByVal %IDC_ARROW )
      wc.hbrBackground = %COLOR_3DFACE + 1
      wc.lpszMenuName  = %NULL
      wc.lpszClassName = VarPtr(szClassName)
      If IsFalse(RegisterClassEx(wc)) Then
        RegisterClass ByVal (VarPtr(wc) + 4)
      End If
    
      hWnd = CreateWindowEx(0, _ '%WS_EX_TOOLWINDOW, _
                            szClassName, _                  ' window class name
                            "Minimize to tray button ---->", _ ' window title
                            %WS_OVERLAPPEDWINDOW, _       ' window style
                            %CW_USEDEFAULT, _             ' initial x position
                            %CW_USEDEFAULT, _             ' initial y position
                            %CW_USEDEFAULT, _             ' initial x size
                            %CW_USEDEFAULT, _             ' initial y size
                            %NULL, _                      ' parent window handle
                            %NULL, _                      ' window menu handle
                            GetModuleHandle(ByVal %NULL), _ ' program instance handle
                            ByVal %NULL)                  ' creation parameters
      Call ShowWindow(hWnd, %SW_SHOWNORMAL)
    
      Do While IsTrue(GetMessage(Msg, ByVal %NULL, 0, 0))
        Call TranslateMessage(Msg)
        Call DispatchMessage(Msg)
      Loop
      Function = msg.wParam
    
    End Function
    
    CallBack Function WndProc()
      Select Case CBMsg
        Case %WM_CREATE
          Call InitTrayBtnTimer(CBHndl) ' Only needed for Themed Windows
    
        Case %WM_NCPAINT
          Function = DefWindowProc(CBHndl, CBMsg, CBwParam, CBlParam)
          Call MinTrayBtnUpdatePosAndSize(CBHndl)
          Call MinTrayBtnDraw(CBHndl)
          Exit Function
    
        Case %WM_NCACTIVATE
          Call MinTrayBtnUpdatePosAndSize(CBHndl)
          Function = DefWindowProc(CBHndl, CBMsg, CBwParam, CBlParam)
          m_bMinTrayBtnActive = CBwParam
          Call MinTrayBtnDraw(CBHndl)
          Exit Function
    
        Case %WM_NCHITTEST
          Local bPreviousHitTest As Long
          Local pt As POINTAPI
    
          bPreviousHitTest = m_bMinTrayBtnHitTest
          pt.x = LoWrd(CBlParam)
          pt.y = HiWrd(CBlParam)
          m_bMinTrayBtnHitTest = MinTrayBtnHitTest(CBHndl, pt)
          If IsTrue(IsThemeActive()) And (m_bMinTrayBtnHitTest <> bPreviousHitTest) Then
            Call MinTrayBtnDraw(CBHndl) ' Windows XP Style (hot button)
          End If
          If IsTrue(m_bMinTrayBtnHitTest) Then
            Function = %HTMINTRAYBUTTON
            Exit Function
          End If
    
        Case %WM_NCLBUTTONDOWN
          pt.x = LoWrd(CBlParam)
          pt.y = HiWrd(CBlParam)
          If IsFalse(m_bMinTrayBtnEnabled) Or IsFalse(m_bMinTrayBtnVisible) Or IsFalse(MinTrayBtnHitTest(CBHndl, pt)) Then
            Function = DefWindowProc(CBHndl, CBMsg, CBwParam, CBlParam)
            Exit Function
          End If
          Call SetCapture(CBHndl)
          m_bMinTrayBtnCapture = %TRUE
          Call MinTrayBtnSetDown(CBHndl)
          Exit Function
    
        Case %WM_NCRBUTTONDOWN
          pt.x = LoWrd(CBlParam)
          pt.y = HiWrd(CBlParam)
          If IsFalse(m_bMinTrayBtnVisible) Or IsFalse(MinTrayBtnHitTest(CBHndl, pt)) Then
            Function = DefWindowProc(CBHndl, CBMsg, CBwParam, CBlParam)
          End If
          Exit Function
    
        Case %WM_MOUSEMOVE
          Local iTmp As Integer Ptr
          Local wTmp As Word
    
          If IsFalse(m_bMinTrayBtnCapture) Then
            Function = DefWindowProc(CBHndl, CBMsg, CBwParam, CBlParam)
            Exit Function
          End If
          wTmp = LoWrd(CBlParam)
          iTmp = VarPtr(wTmp)
          pt.x = @iTmp
          wTmp = HiWrd(CBlParam)
          iTmp = VarPtr(wTmp)
          pt.y = @iTmp
    
          Call ClientToScreen(CBHndl, pt)
    
          m_bMinTrayBtnHitTest = MinTrayBtnHitTest(CBHndl, pt)
          If IsTrue(m_bMinTrayBtnHitTest) Then
            If IsTrue(m_bMinTrayBtnUp) Then Call MinTrayBtnSetDown(CBHndl)
          Else
            If IsFalse(m_bMinTrayBtnUp) Then Call MinTrayBtnSetUp(CBHndl)
          End If
          Exit Function
    
        Case %WM_LBUTTONUP
          If IsFalse(m_bMinTrayBtnCapture) Then
            Function = DefWindowProc(CBHndl, CBMsg, CBwParam, CBlParam)
            Exit Function
          End If
    
          Call ReleaseCapture()
          m_bMinTrayBtnCapture = %FALSE
          Call MinTrayBtnSetUp(CBHndl)
    
          wTmp = LoWrd(CBlParam)
          iTmp = VarPtr(wTmp)
          pt.x = @iTmp
          wTmp = HiWrd(CBlParam)
          iTmp = VarPtr(wTmp)
          pt.y = @iTmp
    
          Call ClientToScreen(CBHndl, pt)
          If IsTrue(MinTrayBtnHitTest(CBHndl, pt)) Then
            Call SendMessage(CBHndl, %WM_SYSCOMMAND, %SC_MINIMIZETRAY, MakLng(pt.x, pt.y))
          End If
          Exit Function
    
        Case %WM_TIMER
          If IsTrue(IsThemeActive()) And CBwParam = m_nMinTrayBtnTimerId Then
            ' Visual XP Style (hot button)
            Call GetCursorPos(pt)
            bPreviousHitTest = MinTrayBtnHitTest(CBHndl, pt)
            If m_bMinTrayBtnHitTest <> bPreviousHitTest Then
              m_bMinTrayBtnHitTest = bPreviousHitTest
              Call MinTrayBtnDraw(CBHndl)
            End If
          End If
    
        Case %WM_SYSCOMMAND
          If CBwParam = %SC_MINIMIZETRAY Then
            MsgBox "Minimize to Tray"
          End If
    
        Case %WM_DESTROY
          PostQuitMessage 0
    
      End Select
    
      Function = DefWindowProc(CBHndl, CBMsg, CBwParam, CBlParam)
    End Function
    
    -----------------------
    
    ' mintraybtn.inc
    '*******************************************
    ' Min Tray Button
    '*******************************************
    
    '***************************************
    ' Theme Declarations
    #Include "theme.inc"
    
    %CAPTION_BUTTONSPACE      = 2
    %CAPTION_MINHEIGHT        = 8
    
    %TIMERMINTRAYBTN_ID       = &H76617A67
    %TIMERMINTRAYBTN_PERIOD   = 200
    
    %HTMINTRAYBUTTON         = 65
    %SC_MINIMIZETRAY         = &HE000
    
    Global m_MinTrayBtnPos      As POINTAPI
    Global m_MinTrayBtnSize     As SIZEL
    Global m_bMinTrayBtnVisible As Long
    Global m_bMinTrayBtnEnabled As Long
    Global m_bMinTrayBtnUp      As Long
    Global m_bMinTrayBtnCapture As Long
    Global m_bMinTrayBtnActive  As Long
    Global m_bMinTrayBtnHitTest As Long
    Global m_nMinTrayBtnTimerId As Long
    
    Declare Function InitTrayBtnTimer(ByVal hWnd As DWord) As Long
    Declare Sub MinTrayBtnUpdatePosAndSize(ByVal hWnd As DWord)
    Declare Sub MinTrayBtnDraw(ByVal hWnd As DWord)
    Declare Sub MinTrayBtnShow(ByVal hWnd As DWord)
    Declare Sub MinTrayBtnHide(ByVal hWnd As DWord)
    Declare Sub MinTrayBtnEnable(ByVal hWnd As DWord)
    Declare Sub MinTrayBtnDisable(ByVal hWnd As DWord)
    Declare Function MinTrayBtnHitTest(ByVal hWnd As DWord, point As POINTAPI) As Long
    Declare Sub MinTrayBtnSetUp(ByVal hWnd As DWord)
    Declare Sub MinTrayBtnSetDown(ByVal hWnd As DWord)
    
    Function InitTrayBtnTimer(ByVal hWnd As DWord) As Long
      m_bMinTrayBtnEnabled = %TRUE
      m_bMinTrayBtnVisible = %TRUE
      m_bMinTrayBtnUp = %TRUE
      m_bMinTrayBtnCapture = %FALSE
      m_bMinTrayBtnActive = %FALSE
      m_bMinTrayBtnHitTest = %FALSE
    
      m_nMinTrayBtnTimerId = SetTimer(hWnd, %TIMERMINTRAYBTN_ID, %TIMERMINTRAYBTN_PERIOD, %NULL)
      Function = %TRUE
    End Function
    
    Sub MinTrayBtnUpdatePosAndSize(ByVal hWnd As DWord)
      Local dwStyle     As DWord
      Local dwExStyle   As DWord
      Local caption     As Long
      Local borderfixed As SIZEL
      Local bordersize  As SIZEL
      Local window      As RECT
      Local buttonsize  As SIZEL
    
      dwStyle = GetWindowLong(hWnd, %GWL_STYLE)
      dwExStyle = GetWindowLong(hWnd, %GWL_EXSTYLE)
    
      If (dwExStyle And %WS_EX_TOOLWINDOW) = 0 Then
        caption = GetSystemMetrics(%SM_CYCAPTION) - 1
      Else
        caption = GetSystemMetrics(%SM_CYSMCAPTION) - 1
      End If
    
      If caption < %CAPTION_MINHEIGHT Then caption = %CAPTION_MINHEIGHT
    
      borderfixed.cx = - GetSystemMetrics(%SM_CXFIXEDFRAME)
      borderfixed.cy = GetSystemMetrics(%SM_CYFIXEDFRAME)
    
      bordersize.cx = - GetSystemMetrics(%SM_CXSIZEFRAME)
      bordersize.cy = GetSystemMetrics(%SM_CYSIZEFRAME)
    
      Call GetWindowRect(hWnd, window)
    
      buttonsize.cy = caption - (%CAPTION_BUTTONSPACE * 2)
      buttonsize.cx = buttonsize.cy
    
      If IsFalse(IsThemeActive()) Then
        buttonsize.cx = buttonsize.cx + 2
      End If
    
      m_MinTrayBtnSize = buttonsize
    
      m_MinTrayBtnPos.x = (window.nRight - window.nLeft) - ((%CAPTION_BUTTONSPACE + buttonsize.cx) * 2)
      m_MinTrayBtnPos.y = %CAPTION_BUTTONSPACE
    
      If ((dwStyle And %WS_THICKFRAME) <> 0) Then
        ' resizable window
        m_MinTrayBtnPos.x = m_MinTrayBtnPos.x + bordersize.cx
        m_MinTrayBtnPos.y = m_MinTrayBtnPos.y + bordersize.cy
      Else
        ' fixed window
        m_MinTrayBtnPos.x = m_MinTrayBtnPos.x + borderfixed.cx
        m_MinTrayBtnPos.y = m_MinTrayBtnPos.y + borderfixed.cy
      End If
    
      If ((dwExStyle And %WS_EX_TOOLWINDOW) = 0) And (((dwStyle And %WS_MINIMIZEBOX) <> 0) Or ((dwStyle And %WS_MAXIMIZEBOX) <> 0)) Then
        If IsFalse(IsThemeActive()) Then
          m_MinTrayBtnPos.x = m_MinTrayBtnPos.x - ((buttonsize.cx * 2) + %CAPTION_BUTTONSPACE)
        Else
          m_MinTrayBtnPos.x = m_MinTrayBtnPos.x - ((buttonsize.cx + %CAPTION_BUTTONSPACE) * 2)
        End If
      End If
    End Sub
    
    Sub MinTrayBtnDraw(ByVal hWnd As DWord)
      Local hDC As DWord
      Local rc As RECT
      Local caption As Long
      Local pixratio As Long
      Local pixratio2 As Long
      Local dotwidth As Long
      Local dotheight As Long
      Local dot As RECT
      Local spcsize As SIZEL
      Local X As Long
      Local Y As Long
    
      If IsFalse m_bMinTrayBtnVisible Then Exit Sub
    
      hDC = GetWindowDC(hWnd)
      If hDC = 0 Then Exit Sub 'panic!
    
      If IsFalse(IsThemeActive()) Then
        ' button
        rc.nLeft   = m_MinTrayBtnPos.x
        rc.nTop    = m_MinTrayBtnPos.y
        rc.nRight  = m_MinTrayBtnPos.x + m_MinTrayBtnSize.cx
        rc.nBottom = m_MinTrayBtnPos.y + m_MinTrayBtnSize.cy
        If IsTrue(m_bMinTrayBtnUp) Then
          Call DrawFrameControl(hDC, rc, %DFC_BUTTON, %DFCS_BUTTONPUSH)
        Else
          Call DrawFrameControl(hDC, rc, %DFC_BUTTON, %DFCS_BUTTONPUSH Or %DFCS_PUSHED)
        End If
    
        ' dot
        rc.nLeft = rc.nLeft + 1
        rc.nTop = rc.nTop + 1
        rc.nRight  = rc.nRight - 1
        rc.nBottom = rc.nBottom - 1
    
        caption = m_MinTrayBtnSize.cy + (%CAPTION_BUTTONSPACE * 2)
        If caption >= 14 Then
          If caption >= 20 Then
            pixratio = 2 + ((caption - 20) / 8)
          Else
            pixratio = 2
          End If
        Else
          pixratio = 1
        End If
    
        If caption >= 12 Then
          pixratio2 = 1 + (caption - 12) / 8
        Else
          pixratio2 = 0
        End If
    
        dotwidth = (1 + pixratio * 3)
        Shift Right dotwidth, 1
    
        dotheight = pixratio
        dot.nRight = dotwidth
        dot.nBottom = dotheight
    
        spcsize.cx = (1 + pixratio2 * 3)
        Shift Right spcsize.cx, 1
        spcsize.cy = pixratio2
    
        X = dot.nRight - dot.nLeft
        Y = dot.nBottom - dot.nTop
        dot.nLeft = dot.nLeft - X
        dot.nTop  = dot.nTop - Y
        dot.nRight = dot.nRight - X
        dot.nBottom = dot.nBottom - Y
    
        dot.nLeft = dot.nLeft + rc.nRight
        dot.nTop = dot.nTop + rc.nBottom
        dot.nRight = dot.nRight + rc.nRight
        dot.nBottom = dot.nBottom + rc.nBottom
    
        dot.nLeft = dot.nLeft - spcsize.cx
        dot.nTop = dot.nTop - spcsize.cy
        dot.nRight = dot.nRight - spcsize.cx
        dot.nBottom = dot.nBottom - spcsize.cy
    
        If IsFalse(m_bMinTrayBtnUp) Then
          dot.nLeft = dot.nLeft + 1
          dot.nTop = dot.nTop + 1
          dot.nRight = dot.nRight + 1
          dot.nBottom = dot.nBottom + 1
        End If
    
        If IsTrue(m_bMinTrayBtnEnabled) Then
          Call FillRect(hDC, dot, %COLOR_BTNTEXT + 1)
        Else
          rc.nLeft = dot.nLeft + 1
          rc.nTop = dot.nTop + 1
          rc.nRight = dot.nRight + 1
          rc.nBottom = dot.nBottom + 1
          Call FillRect(hDC, rc, %COLOR_BTNHILIGHT + 1)
          Call FillRect(hDC, dot, %COLOR_GRAYTEXT + 1)
        End If
      Else
        Local hTheme As DWord
        Local iState As Long
    
        hTheme= OpenThemeData(hWnd, "Window")
        If hTheme <> 0 Then
          rc.nLeft   = m_MinTrayBtnPos.x
          rc.nTop    = m_MinTrayBtnPos.y
          rc.nRight  = m_MinTrayBtnPos.x + m_MinTrayBtnSize.cx
          rc.nBottom = m_MinTrayBtnPos.y + m_MinTrayBtnSize.cy
          ' btn.TopLeft()+= CSize(btn.Width() / 8, btn.Height() / 8);
          rc.nTop = rc.nTop + (rc.nBottom - rc.nTop) / 8
          If IsTrue(m_bMinTrayBtnHitTest) Then
            If IsTrue(m_bMinTrayBtnCapture) Then
              iState = 3 ' %MINBS_PUSHED
            Else
              iState = 2 ' %MINBS_HOT
            End If
          ElseIf IsFalse(m_bMinTrayBtnActive) Then
            iState = 5 '%MINBS_INACTIVE
          ElseIf IsTrue(m_bMinTrayBtnEnabled) Then
            iState = 1 '%MINBS_NORMAL
          Else
            iState = 4 '%MINBS_DISABLED
          End If
    
          Call DrawThemeBackground(hTheme, hDC, 15, iState, rc, ByVal %NULL) '%WP_MINBUTTON = 15
          Call CloseThemeData(hTheme)
        End If
      End If
      Call ReleaseDC(hWnd, hDC)
    
    End Sub
    
    Sub MinTrayBtnShow(ByVal hWnd As DWord)
      If IsTrue(m_bMinTrayBtnVisible) Then Exit Sub
    
      m_bMinTrayBtnVisible = %TRUE
      If IsTrue(IsWindowVisible(hWnd)) Then
        Call RedrawWindow(hWnd, ByVal %NULL, %NULL, %RDW_FRAME Or %RDW_INVALIDATE Or %RDW_UPDATENOW)
      End If
    End Sub
    
    Sub MinTrayBtnHide(ByVal hWnd As DWord)
      If IsFalse(m_bMinTrayBtnVisible) Then Exit Sub
    
      m_bMinTrayBtnVisible = %FALSE
      If IsTrue(IsWindowVisible(hWnd)) Then
        Call RedrawWindow(hWnd, ByVal %NULL, %NULL, %RDW_FRAME Or %RDW_INVALIDATE Or %RDW_UPDATENOW)
      End If
    End Sub
    
    Sub MinTrayBtnEnable(ByVal hWnd As DWord)
      If IsTrue(m_bMinTrayBtnEnabled) Then Exit Sub
    
      m_bMinTrayBtnEnabled = %TRUE
      Call MinTrayBtnSetUp(hWnd)
    End Sub
    
    Sub MinTrayBtnDisable(ByVal hWnd As DWord)
      If IsFalse(m_bMinTrayBtnEnabled) Then Exit Sub
    
      m_bMinTrayBtnEnabled = %FALSE
    
      If IsTrue(m_bMinTrayBtnCapture) Then
        Call ReleaseCapture()
        m_bMinTrayBtnCapture = %FALSE
      End If
    
      Call MinTrayBtnSetUp(hWnd)
    End Sub
    
    Function MinTrayBtnHitTest(ByVal hWnd As DWord, point As POINTAPI) As Long
      Local rWnd As RECT
      Local rBtn As RECT
    
      Call GetWindowRect(hWnd, rWnd)
    
      point.x = point.x - rWnd.nLeft
      point.y = point.y - rWnd.nTop
    
      rBtn.nLeft   = m_MinTrayBtnPos.x
      rBtn.nTop    = m_MinTrayBtnPos.y
      rBtn.nRight  = m_MinTrayBtnPos.x + m_MinTrayBtnSize.cx
      rBtn.nBottom = m_MinTrayBtnPos.y + m_MinTrayBtnSize.cy
    
      rBtn.nTop = rBtn.nTop - (%CAPTION_BUTTONSPACE / 2)
      rBtn.nBottom = rBtn.nBottom + (%CAPTION_BUTTONSPACE / 2)
    
      If (rBtn.nLeft <= point.x And rBtn.nRight >= point.x) And (rBtn.nTop <= point.y And rBtn.nBottom >= point.y) Then Function = %TRUE
    End Function
    
    Sub MinTrayBtnSetUp(ByVal hWnd As DWord)
      m_bMinTrayBtnUp = %TRUE
      Call MinTrayBtnDraw(hWnd)
    End Sub
    
    Sub MinTrayBtnSetDown(ByVal hWnd As DWord)
      m_bMinTrayBtnUp = %FALSE
      Call MinTrayBtnDraw(hWnd)
    End Sub
    
    ----------------------
    
    ' theme.inc
    '********************************
    ' Theme API
    '********************************
    
    Sub MakeWideChar(pszInput As Asciiz, ByVal dwOutput As DWord)
      Local lTmp As Long
      Local bInp As Byte Ptr
      Local bOut As Byte Ptr
      bInp = VarPtr(pszInput)
      bOut = dwOutput
      For lTmp = 0 To Len(pszInput)
        @bOut[lTmp * 2] = @bInp[lTmp]
        @bOut[lTmp * 2 + 1] = 0
      Next lTmp
    End Sub
    
    Function GetThemeProcAddress(szProcName As Asciiz) As DWord
      Static hThemeModule As DWord
    
      If hThemeModule = 0 Then
        hThemeModule = LoadLibrary("uxTheme.dll")
        If hThemeModule = 0 Then Exit Function
      End If
      Function = GetProcAddress(hThemeModule, szProcName)
    End Function
    
    Function OpenThemeData(ByVal hWnd As DWord, pszClassList As Asciiz) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      Local wszClassList() As Byte
      ReDim wszClassList((Len(pszClassList) + 1) * 2)
      Call MakeWideChar(pszClassList, VarPtr(wszClassList(0)))
      dwProcAddress = GetThemeProcAddress("OpenThemeData")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using OpenThemeData(hWnd, ByVal VarPtr(wszClassList(0))) To lRet
      Function = lRet
    End Function
    
    Function CloseThemeData(ByVal hTheme As DWord) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("CloseThemeData")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using CloseThemeData(hTheme) To lRet
      Function = lRet
    End Function
    
    Function DrawThemeBackground(ByVal hTheme As DWord, ByVal hDC As DWord, ByVal iPartId As Long, ByVal iStateId As Long, pRect As RECT, pClipRect As RECT) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("DrawThemeBackground")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using DrawThemeBackground(hTheme, hDC, iPartId, iStateId, pRect, pClipRect) To lRet
      Function = lRet
    End Function
    
    Function DrawThemeText(ByVal hTheme As DWord, ByVal hDC As DWord, ByVal iPartId As Long, ByVal iStateId As Long, pszText As Asciiz, ByVal iCharCount As Long, ByVal dwTextFlags As DWord, ByVal dwTextFlags2 As DWord, pRect As RECT) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("DrawThemeText")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using DrawThemeText(hTheme, hDC, iPartId, iStateId, pszText, iCharCount, dwTextFlags, dwTextFlags2, pRect) To lRet
      Function = lRet
    End Function
    
    Function GetThemeBackgroundContentRect(ByVal hTheme As DWord, ByVal hDC As DWord, ByVal iPartId As Long, ByVal iStateId As Long, pBoundingRect As RECT, pContentRect As RECT) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeBackgroundContentRect")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeBackgroundContentRect(hTheme, hDC, iPartId, iStateId, pBoundingRect, pContentRect) To lRet
      Function = lRet
    End Function
    
    Function GetThemeBackgroundExtent(ByVal hTheme As DWord, ByVal hDC As DWord, ByVal iPartId As Long, ByVal iStateId As Long, pContentRect As RECT, pExtentRect As RECT) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeBackgroundExtent")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeBackgroundExtent(hTheme, hDC, iPartId, iStateId, pContentRect, pExtentRect) To lRet
      Function = lRet
    End Function
    
    Function GetThemePartSize(ByVal hTheme As DWord, ByVal hDC As DWord, ByVal iPartId As Long, ByVal iStateId As Long, pRect As RECT, ByVal eSize As Long, psz As SIZEL) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemePartSize")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemePartSize(hTheme, hDC, iPartId, iStateId, pRect, eSize, psz) To lRet
      Function = lRet
    End Function
    
    Function GetThemeTextExtent(ByVal hTheme As DWord, ByVal hDC As DWord, ByVal iPartId As Long, ByVal iStateId As Long, pszText As Asciiz, ByVal iCharCount As Long, ByVal dwTextFlags As DWord, pBoundingRect As RECT, pExtentRect As RECT) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeTextExtent")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeTextExtent(hTheme, hDC, iPartId, iStateId, pszText, iCharCount, dwTextFlags, pBoundingRect, pExtentRect) To lRet
      Function = lRet
    End Function
    
    Function GetThemeTextMetrics(ByVal hTheme As DWord, ByVal hDC As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ptm As TEXTMETRIC) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeTextMetrics")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeTextMetrics(hTheme, hDC, iPartId, iStateId, ptm) To lRet
      Function = lRet
    End Function
    
    Function GetThemeBackgroundRegion(ByVal hTheme As DWord, ByVal hDC As DWord, ByVal iPartId As Long, ByVal iStateId As Long, pRect As RECT, pRegion As DWord) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeBackgroundRegion")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeBackgroundRegion(hTheme, hDC, iPartId, iStateId, pRect, pRegion) To lRet
      Function = lRet
    End Function
    
    Function HitTestThemeBackground(ByVal hTheme As DWord, ByVal hDC As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal dwOptions As DWord, pRect As RECT, ByVal hrgn As DWord, ptTest As POINTAPI, pwHitTestCode As Word) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("HitTestThemeBackground")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using HitTestThemeBackground(hTheme, hDC, iPartId, iStateId, dwOptions, pRect, hrgn, ptTest, pwHitTestCode) To lRet
      Function = lRet
    End Function
    
    Function DrawThemeEdge(ByVal hTheme As DWord, ByVal hDC As DWord, ByVal iPartId As Long, ByVal iStateId As Long, pDestRect As RECT, ByVal uEdge As DWord, ByVal uFlags As DWord, pContentRect As RECT) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("DrawThemeEdge")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using DrawThemeEdge(hTheme, hDC, iPartId, iStateId, pDestRect, uEdge, uFlags, pContentRect) To lRet
      Function = lRet
    End Function
    
    Function DrawThemeIcon(ByVal hTheme As DWord, ByVal hDC As DWord, ByVal iPartId As Long, ByVal iStateId As Long, pRect As RECT, ByVal himl As DWord, ByVal iImageIndex As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("DrawThemeIcon")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using DrawThemeIcon(hTheme, hDC, iPartId, iStateId, pRect, himl, iImageIndex) To lRet
      Function = lRet
    End Function
    
    Function IsThemePartDefined(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("IsThemePartDefined")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using IsThemePartDefined(hTheme, iPartId, iStateId) To lRet
      Function = lRet
    End Function
    
    Function IsThemeBackgroundPartiallyTransparent(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("IsThemeBackgroundPartiallyTransparent")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using IsThemeBackgroundPartiallyTransparent(hTheme, iPartId, iStateId) To lRet
      Function = lRet
    End Function
    
    Function GetThemeColor(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, pColor As DWord) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("IsThemeBackgroundPartiallyTransparent")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeColor(hTheme, iPartId, iStateId, iPropId, pColor) To lRet
      Function = lRet
    End Function
    
    Function GetThemeMetric(ByVal hTheme As DWord, ByVal hDc As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, piVal As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeMetric")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeMetric(hTheme, hDc, iPartId, iStateId, iPropId, piVal) To lRet
      Function = lRet
    End Function
    
    Function GetThemeString(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, pszBuff As Asciiz, ByVal cchMaxBuffChars As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeString")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeString(hTheme, iPartId, iStateId, iPropId, pszBuff, cchMaxBuffChars) To lRet
      Function = lRet
    End Function
    
    Function GetThemeBool(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, pfVal As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeBool")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeBool(hTheme, iPartId, iStateId, iPropId, pfVal) To lRet
      Function = lRet
    End Function
    
    Function GetThemeInt(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, piVal As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeInt")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeInt(hTheme, iPartId, iStateId, iPropId, piVal) To lRet
      Function = lRet
    End Function
    
    Function GetThemeEnumValue(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, piVal As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeEnumValue")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeEnumValue(hTheme, iPartId, iStateId, iPropId, piVal) To lRet
      Function = lRet
    End Function
    
    Function GetThemePosition(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, pPoint As POINTAPI) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemePosition")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemePosition(hTheme, iPartId, iStateId, iPropId, pPoint) To lRet
      Function = lRet
    End Function
    
    Function GetThemeFont(ByVal hTheme As DWord, ByVal hDC As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, pFont As LOGFONT) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeFont")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeFont(hTheme, hDC, iPartId, iStateId, iPropId, pFont) To lRet
      Function = lRet
    End Function
    
    Function GetThemeRect(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, pRect As RECT) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeRect")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeRect(hTheme, iPartId, iStateId, iPropId, pRect) To lRet
      Function = lRet
    End Function
    
    Function GetThemeMargins(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, prc As RECT, pMargins As DWord) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeMargins")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeMargins(hTheme, iPartId, iStateId, iPropId, prc, pMargins) To lRet
      Function = lRet
    End Function
    
    Function GetThemeIntList(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, pIntList As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeIntList")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeIntList(hTheme, iPartId, iStateId, iPropId, pIntList) To lRet
      Function = lRet
    End Function
    
    Function GetThemePropertyOrigin(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, pOrigin As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemePropertyOrigin")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemePropertyOrigin(hTheme, iPartId, iStateId, iPropId, pOrigin) To lRet
      Function = lRet
    End Function
    
    Function SetWindowTheme(ByVal hWnd As DWord, pszSubAppName As Asciiz, pszSubIdList As Asciiz) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("SetWindowTheme")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using SetWindowTheme(hWnd, pszSubAppName, pszSubIdList) To lRet
      Function = lRet
    End Function
    
    Function GetThemeFilename(ByVal hTheme As DWord, ByVal iPartId As Long, ByVal iStateId As Long, ByVal iPropId As Long, pszThemeFileName As Asciiz, ByVal cchMaxBuffChars As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeFilename")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeFilename(hTheme, iPartId, iStateId, iPropId, pszThemeFileName, cchMaxBuffChars) To lRet
      Function = lRet
    End Function
    
    Function GetThemeSysColor(ByVal hTheme As DWord, ByVal iColorId As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeSysColor")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeSysColor(hTheme, iColorId) To lRet
      Function = lRet
    End Function
    
    Function GetThemeSysColorBrush(ByVal hTheme As DWord, ByVal iColorId As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeSysColorBrush")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeSysColorBrush(hTheme, iColorId) To lRet
      Function = lRet
    End Function
    
    Function GetThemeSysBool(ByVal hTheme As DWord, ByVal iBoolId As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeSysBool")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeSysBool(hTheme, iBoolId) To lRet
      Function = lRet
    End Function
    
    Function GetThemeSysSize(ByVal hTheme As DWord, ByVal iSizeId As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeSysSize")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeSysSize(hTheme, iSizeId) To lRet
      Function = lRet
    End Function
    
    Function GetThemeSysFont(ByVal hTheme As DWord, ByVal iFontId As Long, plf As LOGFONT) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeSysFont")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeSysFont(hTheme, iFontId, plf) To lRet
      Function = lRet
    End Function
    
    Function GetThemeSysString(ByVal hTheme As DWord, ByVal iStringId As Long, pszStringBuff As Asciiz, ByVal cchMaxStringChars As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeSysString")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeSysString(hTheme, iStringId, pszStringBuff, cchMaxStringChars) To lRet
      Function = lRet
    End Function
    
    Function GetThemeSysInt(ByVal hTheme As DWord, ByVal iIntId As Long, piValue As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeSysInt")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeSysInt(hTheme, iIntId, piValue) To lRet
      Function = lRet
    End Function
    
    Function IsThemeActive() As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("IsThemeActive")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using IsThemeActive() To lRet
      Function = lRet
    End Function
    
    Function IsAppThemed() As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("IsAppThemed")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using IsAppThemed() To lRet
      Function = lRet
    End Function
    
    Function GetWindowTheme(ByVal hWnd As DWord) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetWindowTheme")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetWindowTheme(hWnd) To lRet
      Function = lRet
    End Function
    
    Function EnableThemeDialogTexture(ByVal hWnd As DWord, ByVal dwFlags As DWord) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetWindowTheme")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetWindowTheme(hWnd) To lRet
      Function = lRet
    End Function
    
    Function IsThemeDialogTextureEnabled(ByVal hWnd As DWord) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("IsThemeDialogTextureEnabled")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using IsThemeDialogTextureEnabled(hWnd) To lRet
      Function = lRet
    End Function
    
    Function GetThemeAppProperties() As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeAppProperties")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeAppProperties() To lRet
      Function = lRet
    End Function
    
    Sub SetThemeAppProperties(ByVal dwFlags As DWord)
      Local dwProcAddress As DWord
      dwProcAddress = GetThemeProcAddress("SetThemeAppProperties")
      If dwProcAddress = 0 Then Exit Sub
      Call DWord dwProcAddress Using SetThemeAppProperties(dwFlags)
    End Sub
    
    Function GetCurrentThemeName(pszThemeFileName As Asciiz, ByVal cchMaxNameChars As Long, pszColorBuff As Asciiz, ByVal cchMaxColorChars As Long, pszSizeBuff As Asciiz, ByVal cchMaxSizeChars As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetCurrentThemeName")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetCurrentThemeName(pszThemeFileName, cchMaxNameChars, pszColorBuff, cchMaxColorChars, pszSizeBuff, cchMaxSizeChars) To lRet
      Function = lRet
    End Function
    
    Function GetThemeDocumentationProperty(pszThemeName As Asciiz, pszPropertyName As Asciiz, pszValueBuff As Asciiz, ByVal cchMaxValChars As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("GetThemeDocumentationProperty")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using GetThemeDocumentationProperty(pszThemeName, pszPropertyName, pszValueBuff, cchMaxValChars) To lRet
      Function = lRet
    End Function
    
    Function DrawThemeParentBackground(ByVal hWnd As DWord, ByVal hDC As DWord, prc As RECT) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("DrawThemeParentBackground")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using DrawThemeParentBackground(hWnd, hDC, prc) To lRet
      Function = lRet
    End Function
    
    Function EnableTheming(ByVal fEnable As Long) As Long
      Local dwProcAddress As DWord
      Local lRet          As Long
      dwProcAddress = GetThemeProcAddress("EnableTheming")
      If dwProcAddress = 0 Then Exit Function
      Call DWord dwProcAddress Using EnableTheming(fEnable) To lRet
      Function = lRet
    End Function

    ------------------
Working...
X