Tweet
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
------------------