Tuesday, August 23, 2011

Membuat Frame Dari CommandButton Standar - Visual Basic 6

Penjelasan mengenai pembuatan objek Frame dari CommandButton standar - Guna mendukung pekerjaan pada posting sebelumnya, yakni mengenai pembuatan dialog options yang wajar, standar, profesional seperti kebanyakan software-software lainnya (themed TabStrip, themed PictureBox, transparent CheckBox, transparent Frame, transparent OptionButton), ada baiknya Anda mengetahui beberapa fakta berikut dengan memperhatikan gambar di bawah ini:

Gambar di atas memiliki tiga objek Frame. Nah, disini ada pertanyaan, apakah Frame tersebut benar-benar sebuah Class Frame? Apakah Frame tersebut merupakan sebuah Container? ternyata Frame tersebut bukanlah frame sebenarnya tetapi objek yang berasal dari Class Button dan juga bukan sebuah Container, ini bisa dibuktikan dengan cara melakukan spy terhadap tiga objek frame di atas. [Download EliteSpy+ Andrea Batina].

Nah, untuk membuat frame dari CommandButton Anda membutuhkan module API di bawah ini:
'Simpan pada form 
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long

Private Const
BM_SETSTYLE As Long = &HF4
Private Const BS_GROUPBOX As Long = &H7&

'Contoh penggunaan
Private Sub Form_Load()
Me.ClipControls = False
SendMessage Command1.hWnd, BM_SETSTYLE, BS_GROUPBOX, 0
End Sub

Sampai disini, mungkin Anda memiliki pertanyaan, mengapa tidak menggunakan objek Frame standar dan malah menggunakan Frame yang berasal CommandButton? tentu saja jawabannya sederhana, karena CommandButton terhook dengan 'ComCtl32.dll' sehingga ia bisa mengikuti warna TabStrip atau themed PictureBox yang telah dijelaskan terdahulu. bersambung ...

Catatan: Selain Frame yang berasal dari CommandButton, Anda pun bisa menggunakan Frame yang berasal dari XPControl.OCX yang dibuat oleh Mirko Marchese.


Akhirnya, saya ucapkan terima kasih kepada Giorgio Brausi (Gibra) pemilik situs VBCorner atas pengetahuan di atas.
READ MORE - Membuat Frame Dari CommandButton Standar - Visual Basic 6

PictureBox Yang Diberi Theme/Style - Visual Basic 6

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

'--------------------------------------------------------------------------------------------------- 
'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.
READ MORE - PictureBox Yang Diberi Theme/Style - Visual Basic 6

Just One Click - LaVolpes Manifest Creator - Tools VB6

Tools VB6 ini - [VB6] XP/Vista/Win7 Manifest Creator - diambil dari sebuah Thread milik LaVolpe yang terdapat di situs VBForums - Setelah beberapa kali mencoba Manifest Creator yang dibuat oleh LaVolpe ternyata hasilnya sangat baik dan memuaskan dengan adanya fitur merger terhadap file resource yang telah ada. Walaupun demikian dalam penggunaannya sedikit merepotkan, terutama jika Anda memiliki banyak project yang harus ditambahkan manifest resouce. Akhirnya saya berinisiatif untuk merubahnya menjadi sebuah Add-Ins, sehingga sekarang memiliki fitur tambahan 'Just One Click'.

Download: LaVolpe's Manifest Creator.

Cara menggunakan:
  1. Ekstrak file, double klik install.bat untuk meregistrasikan komponen
  2. Buka project baru, atau project yang telah Anda buat.
  3. Klik menu Add-Ins >> ManifestCreator >> Create Manifest.
Ucapan terima kasih kepada LaVolpe yang telah membuat tools yang sangat bermanfaat ini.
READ MORE - Just One Click - LaVolpes Manifest Creator - Tools VB6