Menjelaskan mengenai cara memberi theme pada object PictureBox - Apabila kita memperhatikan pada posting sebelumnya mengenai ToolBar, TabStrip, TreeView, dan ListView XP Style Tanpa Kode, maka kita akan melihat jelas object TabStrip yang memiliki theme. Nah, object TabStrip tersebut umumnya (tidak selalu) membutuhkan beberapa PictureBox dalam melakukan tugasnya, yang menjadi persoalan sekarang PictureBox tersebut apabila digunakan bersamaan dengan TabStrip akan memiliki perbedaan warna yang mencolok dan ini menyebabkan rancangan GUI yang kurang baik, bagaimana kita mengatasi permasalahan ini? Perhatikan gambar Setting Winrar di bawah ini:
Setidaknya ada dua cara untuk memberi mengatasi masalah PictureBox di atas, pertama memberi theme pada PictureBox, alternatif yang kedua adalah Fake Gradient dengan menyelaraskan warna PictureBox dengan warna TabStrip yang gradient.
Expand Code...
Contoh penggunaan:
Apakah pekerjaan kita selesai sampai disini? Tidak! setidaknya ada pekerjaan lagi yang harus dilakukan, pertama: melakukan transparansi terhadap object Frame, kedua: melakukan transparansi terhadap object OptionButton dan CheckBox. Mungkin pada posting selanjutnya.
READ MORE - PictureBox Yang Diberi Theme/Style - Visual Basic 6
Setidaknya ada dua cara untuk memberi mengatasi masalah PictureBox di atas, pertama memberi theme pada PictureBox, alternatif yang kedua adalah Fake Gradient dengan menyelaraskan warna PictureBox dengan warna TabStrip yang gradient.
Expand Code...
'---------------------------------------------------------------------------------------------------
'Author: Jottum -- Simpan kode di bawah ini pada module --
'---------------------------------------------------------------------------------------------------
Option Explicit
'API Declarations.
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const LF_FACESIZE = 32
Private Type FONTSLOG
flfHeight As Long
flfWidth As Long
flfEscapement As Long
flfOrientation As Long
flfWeight As Long
flfItalic As Byte
flfUnderline As Byte
flfStrikeOut As Byte
flfCharSet As Byte
flfOutPrecision As Byte
flfClipPrecision As Byte
flfQuality As Byte
flfPitchAndFamily As Byte
flfFaceName As String * LF_FACESIZE
End Type
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function InflateRect Lib "user32" _
(lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Declare Function GetDesktopWindow Lib "user32" _
() As Long
Private Declare Function DrawEdge Lib "user32" _
(ByVal hDC As Long, qrc As RECT, ByVal edge As Long, _
ByVal grfFlags As Long) As Long
Private Declare Function DrawText Lib "user32" _
Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, _
ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function BitBlt Lib "gdi32" _
(ByVal hdcDest As Long, ByVal xDest As Long, ByVal yDest As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" _
(ByVal hDC As Long, lpRect As RECT) As Long
'Theme API Declarations.
Private Declare Function GetThemeFont Lib "uxtheme.dll" ( _
ByVal hTheme As Long, _
ByVal hDC As Long, _
ByVal iPartId As Long, _
ByVal iStateId As Long, _
ByVal iPropId As Long, _
tLogFont As FONTSLOG) As Long
Private Declare Function OpenThemeData Lib "uxtheme.dll" _
(ByVal hwnd As Long, ByVal pszClassList As Long) As Long
Private Declare Function IsThemeActive Lib "uxtheme.dll" _
() As Boolean
Private Declare Function CloseThemeData Lib "uxtheme.dll" _
(ByVal hTheme As Long) As Long
Private Declare Function DrawThemeBackground Lib "uxtheme.dll" _
(ByVal hTheme As Long, ByVal lHdc As Long, _
ByVal iPartId As Long, ByVal iStateId As Long, _
pRect As RECT, pClipRect As RECT) As Long
Private Declare Function DrawThemeText Lib "uxtheme.dll" _
(ByVal hTheme As Long, ByVal hDC As Long, ByVal iPartId As Long, _
ByVal iStateId As Long, ByVal pszText As Long, _
ByVal iCharCount As Long, ByVal dwTextFlag As Long, _
ByVal dwTextFlags2 As Long, pRect As RECT) As Long
Private Declare Function GetThemeRect Lib "uxtheme.dll" ( _
ByVal hTheme As Long, _
ByVal iPartId As Long, _
ByVal iStateId As Long, _
ByVal iPropId As Long, _
ByRef pRect As RECT) As Long
'Types, Enums and Constants...
'Tab constants.
Private Enum ThemeTabParts
TAB_TABITEM = 1
TAB_TABITEMLEFTEDGE = 2
TAB_TABITEMRIGHTEDGE = 3
TAB_TABITEMBOTHEDGE = 4
TAB_TOPTABITEM = 5
TAB_TOPTABITEMLEFTEDGE = 6
TAB_TOPTABITEMRIGHTEDGE = 7
TAB_TOPTABITEMBOTEDGE = 8
TAB_PANE = 9
TAB_BODY = 10
End Enum
Private Enum ThemeTabItemStates
TIS_NORMAL = 1
TIS_HOT = 2
TIS_SELECTED = 3
TIS_DISABLED = 4
TIS_FOCUSED = 5
End Enum
Private Enum ThemeTabItemLeftEdgeStates
TILES_NORMAL = 1
TILES_HOT = 2
TILES_SELECTED = 3
TILES_DISABLED = 4
TILES_FOCUSED = 5
End Enum
Private Enum ThemeTabItemRightEdgeStates
TIRES_NORMAL = 1
TIRES_HOT = 2
TIRES_SELECTED = 3
TIRES_DISABLED = 4
TIRES_FOCUSED = 5
End Enum
Private Enum ThemeTabItemBotEdgeStates
TIBES_NORMAL = 1
TIBES_HOT = 2
TIBES_SELECTED = 3
TIBES_DISABLED = 4
TIBES_FOCUSED = 5
End Enum
Private Enum ThemeTopTabItemStates
TTIS_NORMAL = 1
TTIS_HOT = 2
TTIS_SELECTED = 3
TTIS_DISABLED = 4
TTIS_FOCUSED = 5
End Enum
Private Enum ThemeTopTabItemLeftEdgeStates
TTILES_NORMAL = 1
TTILES_HOT = 2
TTILES_SELECTED = 3
TTILES_DISABLED = 4
TTILES_FOCUSED = 5
End Enum
Private Enum ThemeTopTabItemRightEdgeStates
TTIRES_NORMAL = 1
TTIRES_HOT = 2
TTIRES_SELECTED = 3
TTIRES_DISABLED = 4
TTIRES_FOCUSED = 5
End Enum
Private Enum ThemeTopTabItemBotEdgeStates
TTIBES_NORMAL = 1
TTIBES_HOT = 2
TTIBES_SELECTED = 3
TTIBES_DISABLED = 4
TTIBES_FOCUSED = 5
End Enum
'DrawTabThemeBackground() constants.
Public Const DTTB_HIDEPANE = True
Public Const DTTB_SHOWPANE = False 'Default if omitted
Public Const DTTB_SHOWERRMSG = True
Public Const DTTB_HIDERRMSG = False 'Default if omitted
Public Const DTTB_HIDEBODY = True 'Default is False, show the body
'IsThemed() constant.
Public Const IT_SHOWERRMSG = True
'Miscellaneous
Private Const DT_LEFT = &H0
Private Const DT_TOP = &H0
Private Const DT_CENTER = &H1
Private Const DT_RIGHT = &H2
Private Const DT_VCENTER = &H4
Private Const DT_BOTTOM = &H8&
Private Const DT_SINGLELINE = &H20
Private Const TMT_FONT = 210
'\DrawEdge
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENINNER = &H8
Private Const BDR_OUTER = &H3
Private Const BDR_INNER = &HC
Private Const BDR_RAISED = &H5
Private Const BDR_SUNKEN = &HA
Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)
Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8
Private Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
' --/
'
'Public
'*******************************************************************************************************
'********************************************
'********************* Function DrawTabThemeBackground
'**
'*
'* Author: Jottum
'* Date : 07/15/2007 (mm/dd/yyyy)
'* Site : http://www.uitdeschriften.com/files/VB6
'*
'* The function DrawTabThemeBackground draws a Tab pane, body, pane and body, or a fake tab on any
'* object with a DC.
'*
'* Usage example:
'* ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½
'* DrawTabThemeBackground Me 'Draws on object Me, Pane + Body, no Error Messages.
'*
'* DrawTabThemeBackground Picturebox1, DTTB_HIDEPANE 'Draws on Picturebox1, just the gradient, not the pane
'*
'* DrawTabThemeBackground Form2, , DTTB_SHOWERRMSG 'Draws Pane + Body on Form2 and displays errors (If any).
'* __________________
'* End Usage example:
'*
'* Note:
'* ï؟½ï؟½ï؟½ï؟½ï؟½
'* This is just an example function to show how UxTheme.Dll can be used from VB6.
'* _________
'* End Note:
'*
'* Syntax:
'* ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½
'* DrawTabThemeBackground Object, Flag, Flag, Header 'Any object with a hDc property.
'* '1st True is gradient only (Body).
'* Or '2nd True is show errors. (If any)
'* '3rd fakes a tab control.
'* DrawTabThemeBackground Object
'*
'* Returns: True or False, this enables you to check by code if executed successful.
'*
'* If DrawTabThemeBackground(Me, DTTB_SHOWPANE, DTTB_SHOWERRMSG, "Fake Tab", DTTB_HIDEBODY) then
'*
'* 'Magic coding here.
'*
'* Else
'*
'* 'Perform a miracle. ;)
'*
'* End If
'* ___________
'* End Syntax:
'*
'**
'*********************
'********************************************
'*******************************************************************************************************
Public Function DrawTabThemeBackground(Obj As Object, _
Optional lBodyOnly As Boolean = False, _
Optional ShowErrMsg As Boolean = False, _
Optional TabTitle As String = vbNullString, _
Optional lNoBody As Boolean = False) As Boolean
On Error GoTo ThemeError 'Catch errors.
Dim hTheme As Long 'Declare local variables
Dim lR As Long
Dim tR As RECT
Dim tR2 As RECT
Dim tTextR As RECT
Dim cControl As Control
Dim lTmp As Long
Dim strLength As Long
If lBodyOnly And lNoBody Then
Err.Raise 520, _
"DrawTabThemeBackground", _
"Error in function call, check parameters: " & _
vbCrLf & vbCrLf & " lBodyOnly and lNoBody are both true. " & _
vbCrLf
End If
'The only reason you can cause this problem is the design of this function,
'which in this case is a feature and not a bug. ;) It gives me the chance
'to demonstrate Error Raising in user functions.
'
'I could have taken a little different aproach in function design or just
'validate the other variables passed, and act accordingly.
'
'For example if TabTitle <> vbNullString, the developer wants to fake a
'Tab Control and that *has* to have a Tab pane. In any other situation
'I could have used the first True and set the conflicting variable to False.
'
'When the developer looks at the form at runtime, he'll notice the Tab isn't
'what he expected it to be. He can now do two things, say the function sucks
'and move on, or look at the way he's calling it... <g>
'
'Error raising can be usefull if your function isn't generating any errors
'as far as the compiler's concern, but to you as developer and therefore the
'enduser. But let's get on with it.
If ThemeSysFont <> vbNullString Then
On Error Resume Next
Obj.Font.Name = ThemeSysFont 'Or it looks real bad!... well,
On Error GoTo 0 'to me that is of course... ;)
End If
GetClientRect Obj.hwnd, tR 'Get the drawing area rectangle
If Not TabTitle = vbNullString Then 'Some calculating...
tR.Top = 165 / Screen.TwipsPerPixelY 'Top margin
tR.Left = 135 / Screen.TwipsPerPixelX 'Left margin
tR.Right = tR.Right - (120 / Screen.TwipsPerPixelX) 'Right margin
tR.Bottom = tR.Bottom - (650 / Screen.TwipsPerPixelY) 'Button margin below the Tab.
tR2.Top = 150 / Screen.TwipsPerPixelY 'Tab text.
tR2.Left = 135 / Screen.TwipsPerPixelX
tR2.Bottom = 435 / Screen.TwipsPerPixelY
tR2.Right = (Obj.TextWidth(TabTitle) / Screen.TwipsPerPixelX) + 24
tR.Top = tR.Top + (tR2.Bottom - tR2.Top) - 2 ' Make some space for header.
strLength = (Obj.TextWidth(TabTitle) / Screen.TwipsPerPixelX)
'Get length of TabTitle.
End If
If IsThemed_(Obj.hwnd) Then 'Check for theme presence
Obj.Cls 'Clear Objects surface.
Obj.AutoRedraw = True 'Make sure AutoRedraw = True
Obj.BackColor = vbButtonFace 'Should be default with a Tab
'Control.
hTheme = OpenThemeData(Obj.hwnd, StrPtr("Tab")) 'Open with correct theme item
If Not lBodyOnly Then 'They want the gradient...
If TabTitle = vbNullString Then '...but not to fake a tab.
tR.Top = tR.Top + 1 'Zero doesn't paint the top and
tR.Left = tR.Left + 1 'left borders on a visible part
'of Obj.
End If
lR = DrawThemeBackground(hTheme, Obj.hDC, _
TAB_PANE, _
TIS_NORMAL, _
tR, tR) 'Draw the Tab Pane (No gradient
'background)
If Not lNoBody Then
InflateRect tR, -3, -3 'Adjust the rectangle size, to
'Draw the Tab body (Gradient)
'inside the Tab Pane.
lR = DrawThemeBackground(hTheme, Obj.hDC, _
TAB_BODY, _
TIS_NORMAL, _
tR, tR) 'Draw Tab body (Gradient
End If 'background)
Else
If Not lNoBody Then
lR = DrawThemeBackground(hTheme, Obj.hDC, _
TAB_BODY, _
TIS_NORMAL, _
tR, tR) 'Draw Tab body (Gradient
'background)
End If
End If
InflateRect tR2, 0, 1 'A little adjustment ...
If Not TabTitle = vbNullString Then
lR = DrawThemeBackground(hTheme, Obj.hDC, _
TAB_TOPTABITEM, _
TIBES_SELECTED, _
tR2, tR2) 'Draw Tab Header
lR = DrawThemeBackground(hTheme, Obj.hDC, _
TAB_TOPTABITEMRIGHTEDGE, _
TTIRES_SELECTED, _
tR2, tR2) 'Draw Tab Header Right Edge
lR = DrawThemeBackground(hTheme, Obj.hDC, _
TAB_TOPTABITEMLEFTEDGE, _
TILES_SELECTED, _
tR2, tR2) 'Draw Tab Header Left Edge
tR2.Top = tR2.Top + 4 'A little smuggling ...
lR = DrawThemeText(hTheme, _
Obj.hDC, _
TAB_TOPTABITEM, _
TTIBES_SELECTED, _
StrPtr(TabTitle), _
-1, _
DT_CENTER Or DT_VCENTER, _
0, _
tR2) 'Draw the text.
End If
CloseThemeData hTheme 'Release Handle
DrawTabThemeBackground = True 'Success, return True.
Exit Function
Else 'Draw legacy fake tab.
GetClientRect Obj.hwnd, tR 'Get the drawing area rectangle
tR.Top = 120 / Screen.TwipsPerPixelY 'Top margin
tR.Left = 120 / Screen.TwipsPerPixelX 'Left margin
tR.Right = (Obj.Width / Screen.TwipsPerPixelX) - (215 / Screen.TwipsPerPixelX) 'Right margin
tR.Bottom = tR.Bottom - (630 / Screen.TwipsPerPixelY) 'Button margin below the Tab.
tR2.Top = 135 / Screen.TwipsPerPixelY 'Tab text.
tR2.Left = 120 / Screen.TwipsPerPixelX
tR2.Bottom = 465 / Screen.TwipsPerPixelY
tR2.Right = (Obj.TextWidth(TabTitle) / Screen.TwipsPerPixelX) + 25
tR.Top = tR.Top + (tR2.Bottom - tR2.Top) '- 2 ' Make some space for header.
DrawEdge Obj.hDC, tR, EDGE_RAISED, BF_RECT
If Not TabTitle = vbNullString Then
DrawEdge Obj.hDC, tR2, EDGE_RAISED, BF_RIGHT
DrawEdge Obj.hDC, tR2, EDGE_RAISED, BF_LEFT
DrawEdge Obj.hDC, tR2, EDGE_RAISED, BF_TOP
'Since whe're only drawing the borders, the legacy fake Tab is fully
'Transparent. With the below function, I'm smuggling a little again
'by copying a small part just below the frame top edge and draw it
'over the frame top edge where the caption will be drawn.
lR = BitBlt(Obj.hDC, tR2.Left + 2, tR2.Bottom - 1, strLength + 15, tR2.Left + 3, _
Obj.hDC, tR2.Left + 2, tR2.Bottom + 1, vbSrcCopy)
tR2.Right = tR2.Right - 8
tR2.Top = tR2.Top + 6
DrawText Obj.hDC, TabTitle, Len(TabTitle), tR2, vbButtonText
End If
DrawTabThemeBackground = True
Exit Function
End If
ThemeError:
DrawTabThemeBackground = False 'Function failed...
If ShowErrMsg Then
If MsgBox("An Error occurred in Function DrawTabThemeBackground: " & vbCrLf & vbCrLf & _
"Return value" & vbTab & ": " & Str$(lR) & vbCrLf & _
"Error number" & vbTab & ": " & Err.Number & vbCrLf & _
"Error description" & vbTab & ": " & Err.Description & " " & vbCrLf & _
"Error Object" & vbTab & ": " & Obj.Name & vbCrLf & _
"Error source" & vbTab & ": " & Err.Source & vbCrLf & vbCrLf & _
"Would you like to try to continue executing this function? ", _
vbExclamation + vbYesNo) = vbYes Then
Resume Next
Else
Resume AllNotSoWell
End If
Else
Resume AllNotSoWell
End If
AllNotSoWell:
Exit Function
End Function
'*******************************************************************************************************
'********************************************
'********************* FUNCTION ISTHEMED_
'**
'*
'* Author: Jottum
'* Date : 07/15/2007 (mm/dd/yyyy)
'* Site : http://www.uitdeschriften.com/files/VB6
'*
'* The function IsThemed_ checks if there's any theming going on, if so it tries to get a
'* handle from the function OpenThemeData. If this succeeds the hTheme variable contains
'* that handle, otherwise it's 0. (If it's 0 you can't use the theming functions.)
'*
'* Usage example:
'* ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½
'* If IsThemed_([hWnd], [bShowErrorMessage]) then
'*
'* 'Draw/Do theme stuff
'*
'* Else
'*
'* 'Draw/Do legacy stuff
'*
'* End If
'* ______________
'* Usage example:
'*
'* Note:
'* ï؟½ï؟½ï؟½ï؟½ï؟½
'* - I renamed the function from IsThemed to IsThemed_ and declared it private to avoid any
'* possible conflicts with an existing, equally named public declared function. If you would
'* like to have this function globally available, Copy and Paste the entire function to one
'* of your .BAS modules, change Private to Public and remove all Underscores (6 of them... I think;).
'*
'* - You can now call IsThemed() from anywhere in your application.
'*
'* - The hWnd parameter is optional, the default is the Desktop's. Me.hWnd is just an example,
'* any valid hWnd - or none at all, it'll fetch the desktop's - will do.
'* _________
'* End Note:
'*
'* The IT_SHOWERRMSG (bShowErrorMessage) parameter is optional, the default is False which means
'* it doesn't show the errors (if any) it traps. It could be useful - for example when debuging
'* unexpected behavior in your application, or while still developing - to set it to true.
'*
'* Syntax:
'* ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½ï؟½
'* Dim bShowErrorMessage As Boolean 'If declared Public in a module, you can
'* 'set this flag application wide
'* Dim bReturnValue As Boolean
'*
'* bShowErrorMessage = True
'*
'* bReturnValue = IsThemed([ANY_VALID_HWND], [bShowErrorMessage])
'*
'* Or 'No hWnd, static show Error Messages.
'*
'* bReturnValue = IsThemed( , [IT_SHOWERRMSG])
'*
'* Or 'hWnd and show Error Messages
'*
'* bReturnValue = IsThemed([ANY_VALID_HWND], [IT_SHOWERRMSG])
'*
'* Or 'hWnd, no Error Messages
'*
'* If IsThemed_([ANY_VALID_HWND]) Then ....
'*
'* Or 'Use all defaults (Desktop hWnd),
'* ,no Error Messages
'* If IsThemed_() Then ....
'* ___________
'* End Syntax:
'*
'**
'*********************
'********************************************
'*******************************************************************************************************
Public Function IsThemed_(Optional hwnd As Long = 0, Optional ShowErrMsg As Boolean = False) As Boolean
On Error GoTo ThemeError 'Catch errors, like calling a DLL 'Catch errors...
'function and no DLL in sight. (W2K ?)
Dim hTheme As Long 'Declare variable for Theme Handle
If IsThemeActive() Then 'Aha, theming! Now try to get a handle.
If hwnd = 0 Then 'But first make sure we've got a valid
'hWnd passed, and if not get the
hwnd = GetDesktopWindow 'Desktop's
End If
hTheme = OpenThemeData(hwnd, StrPtr("Status")) 'Any pszClasslist item will do, I
'just picked "Status" at random.
If (hTheme <> 0) Then 'We've got a handle
CloseThemeData hTheme 'Release handle.
IsThemed_ = True 'Return Success.
Exit Function 'We don't want to bump into
'ThemeError. ;)
Else
IsThemed_ = False 'Can't get a handle, so nothing is open.
Exit Function 'Let's split!
End If
Else
IsThemed_ = False 'No theming!
Exit Function 'Let's split here too!
End If
ThemeError:
IsThemed_ = False 'Don't forget to set flag to false.
If ShowErrMsg Then '... display MessageBox with Error
MsgBox "An Error occurred in Function IsThemed_: " & vbCrLf & vbCrLf & _
"Error number" & vbTab & ": " & Err.Number & vbCrLf & _
"Error description" & vbTab & ": " & Err.Description & " " & vbCrLf & _
"Error source" & vbTab & ": " & Err.Source & vbCrLf & vbCrLf & _
"Code execution has stopped for this call. ", vbExclamation
End If
Resume AllNotSoWell
AllNotSoWell:
Exit Function
End Function
'See WhatIsThemeFont just below.
Public Function ThemeSysFont() As String
Dim lHwnd As Long
Dim lHdc As Long
Dim lKind As Long
Dim lState As Long
lHwnd = GetDesktopWindow
lHdc = GetDC(lHwnd)
lKind = 4 '4 = PB_GROUPBOX
lState = 1 '1 = PBS_NORMAL
ThemeSysFont = WhatIsThemeFont("Button", lHwnd, lHdc, lKind, lState)
ReleaseDC lHwnd, lHdc
End Function
'This function needs more attention. Will do that later.
'
'WhatIsThemeFont will return just a string containing the
'font name, not the font object.
Public Function WhatIsThemeFont(pszClassListItem As String, lHwnd As Long, lHdc As Long, iPartId As Long, iState As Long) As String
On Error Resume Next
Dim tLogFont As FONTSLOG
Dim hTheme As Long
If IsThemed_(lHwnd) Then
hTheme = OpenThemeData(lHwnd, StrPtr(pszClassListItem))
If hTheme <> 0 Then
GetThemeFont hTheme, lHdc, iPartId, iState, TMT_FONT, tLogFont
If tLogFont.flfFaceName <> "" Then
WhatIsThemeFont = tLogFont.flfFaceName
Else
WhatIsThemeFont = "MS Sans Serif" 'Just to be safe.
End If
CloseThemeData hTheme
Else
WhatIsThemeFont = "MS Sans Serif"
'Not good if you get here, so show a message.
MsgBox "An Error occured retrieving a theme handle from OpenThemeData(): " & vbCrLf & vbCrLf & _
" - Function" & vbTab & ": WhatIsThemeFont " & vbCrLf & _
" - Module " & vbTab & ": DrawTabBckgrnd.bas ", vbCritical
End If
Else
WhatIsThemeFont = "MS Sans Serif" 'Default on any none themed OS, this is
'the dirty way, I know. :)
End If
On Error GoTo 0 'Reset normal error trapping
End Function
Contoh penggunaan:
Private Sub Form_Load()
DrawTabThemeBackground Picture1 'memberi theme pada PictureBox
End Sub
Apakah pekerjaan kita selesai sampai disini? Tidak! setidaknya ada pekerjaan lagi yang harus dilakukan, pertama: melakukan transparansi terhadap object Frame, kedua: melakukan transparansi terhadap object OptionButton dan CheckBox. Mungkin pada posting selanjutnya.
