Showing posts with label PictureBox. Show all posts
Showing posts with label PictureBox. Show all posts

Thursday, July 11, 2013

VB6 PictureBox - Print Left Center Right Align - PictureBox

Di bawah ini merupakan contoh print left - center - right pada PictureBox, seperti pada gambar di bawah ini:

VB6 Print Left Center Right Align PictureBox
Gambar - VB6 Print Left Center Right Align PictureBox

Option Explicit

'-------------------------------------------------------------------------
'http://khoiriyyah.blogspot.com
'-------------------------------------------------------------------------
'Print right align pada objek PictureBox
Private Sub PrintRightAlign(ByVal Teks As String, pic As PictureBox)
With pic
.CurrentX = pic.ScaleWidth - pic.TextWidth(Teks)
pic.Print Teks
End With
End Sub

'Print center pada objek PictureBox
Private Sub PrintCenter(ByVal Teks As String, pic As PictureBox)
With pic
.CurrentX = (pic.ScaleWidth - pic.TextWidth(Teks)) / 2
pic.Print Teks
End With
End Sub

'Print left pada objek PictureBox
Private Sub PrintLeft(ByVal Teks As String, pic As PictureBox)
With pic
pic.Print Teks
End With
End Sub

Private Sub Form_Load()
Picture1.AutoRedraw = True
End Sub

'Contoh print left align
Private Sub cmdLeft_Click()
Static i As Long
i = i + 1
Call PrintLeft(i, Picture1)
End Sub

'Contoh print center
Private Sub cmdCenter_Click()
Static i As Long
i = i + 1
Call PrintCenter(i, Picture1)
End Sub

'Contoh print right
Private Sub cmdRight_Click()
Static i As Long
i = i + 1
Call PrintRightAlign(i, Picture1)
End Sub

Download: vb6_print_center_right_left.zip

READ MORE - VB6 PictureBox - Print Left Center Right Align - PictureBox

Sunday, June 17, 2012

Mengkopi Gambar Ke Clipboard Melalui VB6

Private Sub CopyFromPictureBox(pic As PictureBox)
With Clipboard
.Clear
.SetData pic.Picture
End With
End Sub

Private Sub CopyFromFile(Path As String)
With Clipboard
.Clear
.SetData LoadPicture(Path)
End With
End Sub
READ MORE - Mengkopi Gambar Ke Clipboard Melalui VB6

Progress Bar dari PictureBox Seperti Pada VB Classic

Option Explicit

Dim tenth As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Sub UpdateStatus(FileBytes As Long)
Static progress As Long
Dim r As Long
Const SRCCOPY = &HCC0020
Dim Txt$
progress = progress + FileBytes
If progress > Picture1.ScaleWidth Then
progress = Picture1.ScaleWidth
End If
Txt$ = Format$(CLng((progress / Picture1.ScaleWidth) * 100)) + "%"
Picture1.Cls
Picture1.CurrentX = (Picture1.ScaleWidth - Picture1.TextWidth(Txt$)) \ 2
Picture1.CurrentY = (Picture1.ScaleHeight - Picture1.TextHeight(Txt$)) \ 2
Picture1.Print Txt$
Picture1.Line (0, 0)-(progress, Picture1.ScaleHeight), Picture1.ForeColor, BF
r = BitBlt(Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, Picture1.hdc, 0, 0, SRCCOPY)
End Sub

Private Sub Command1_Click()
Dim i As Integer, x As Long
Picture1.ScaleWidth = 109
tenth = 10
For i = 1 To 11
Call UpdateStatus(tenth)
x = Timer
While Timer < x + 0.75
DoEvents
Wend
Next
End Sub

Private Sub Form_Load()
Picture1.FontBold = True
Picture1.AutoRedraw = True
Picture1.BackColor = vbWhite
Picture1.DrawMode = 10
Picture1.FillStyle = 0
Picture1.ForeColor = vbBlue
End Sub
READ MORE - Progress Bar dari PictureBox Seperti Pada VB Classic

Contoh Membuat Picture Yang Dapat DiScroll

Option Explicit

Private Sub Form_Load()

Picture1.Move 0, 0, ScaleWidth - VScroll1.Width, ScaleHeight - HScroll1.Height

With Picture2
.AutoSize = True

.Picture = LoadPicture("splash.bmp")

.Move 0, 0
End With

With HScroll1
.Top = Picture1.Height
.Left = 0
.Width = Picture1.Width
End With

With VScroll1
.Top = 0
.Left = Picture1.Width
.Height = Picture1.Height
End With

HScroll1.Max = Picture2.Width - Picture1.Width
VScroll1.Max = Picture2.Height - Picture1.Height
HScroll1.LargeChange = HScroll1.Max / 10
VScroll1.LargeChange = VScroll1.Max / 10
HScroll1.SmallChange = HScroll1.Max / 25
VScroll1.SmallChange = VScroll1.Max / 25

VScroll1.Visible = (Picture1.Height < Picture2.Height)
HScroll1.Visible = (Picture1.Width < Picture2.Width)
End Sub

Private Sub HScroll1_Change()

Picture2.Left = -HScroll1.Value

End Sub

Private Sub VScroll1_Change()

Picture2.Top = -VScroll1.Value

End Sub

Private Sub Form_Resize()
With Picture1
.Height = Form1.Height
.Width = Form1.Width
End With

Picture1.Move 0, 0, ScaleWidth - VScroll1.Width, ScaleHeight - HScroll1.Height
Picture2.Move 0, 0

With HScroll1
.Top = Picture1.Height
.Left = 0
.Width = Picture1.Width
.Max = Picture2.Width - Picture1.Width
End With

With VScroll1
.Top = 0
.Left = Picture1.Width
.Height = Picture1.Height
.Max = Picture2.Height - Picture1.Height
End With

VScroll1.Visible = (Picture1.Height < Picture2.Height)
HScroll1.Visible = (Picture1.Width < Picture2.Width)
End Sub
READ MORE - Contoh Membuat Picture Yang Dapat DiScroll

Friday, June 8, 2012

Memahami Drag and Drop Dalam Visual Basic 6

Posting mengenai contoh operasi Drag and Drop menggunakan OLE pada VB6, Sebelum Anda mencoba kode drag and drop di bawah ini, settinglah property objek Picture1 OLEDropMode = 1 - Manual dan Property AutoSize = True.
Private Sub Picture1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)  
On Error GoTo
ErrHandler
Picture1.Picture = LoadPicture(Data.Files(1))
Exit Sub

ErrHandler:
MsgBox "Error gambar tidak bisa diload"
End Sub
Untuk melihat cara kerjanya, bukalah Windows Explorer draglah satu file gambar yang terdapat pada Windows Explorer tersebut, selanjutnya drop tepat di atas object PictureBox.
READ MORE - Memahami Drag and Drop Dalam Visual Basic 6

Sunday, May 27, 2012

Mendisablekan Seluruh Objek Yang Terdapat Pada PictureBox

Setelah sebelumnya kita mengetahui cara merubah .Caption dan ukuran Form, maka sekarang kita beralih topik mengenai cara mendisablekan seluruh objek yang terdapat pada PictureBox atau Frame. Jadi judul yang lebih tepat adalah mendisablekan seluruh objek yang terdapat pada PictureBox atau Frame menggunakan kode.

Sebelumnya ada beberapa hal yang harus diketahui, bahwa Form itu merupakan sebuah Container atau bisa disebut juga koleksi (Collection) demikian pula PictureBox dan Frame. Karena mereka (Form, PictureBox, Frame) adalah sebuah kontainer maka mereka dapat menampung objek-objek lain, sebagai contoh: apabila kita membuat sebuah Form dan pada Form tersebut kita tempatkan PictureBox maka bisa dikatakan: Kontainer Form menampung objek PictureBox. Dan apabila kita tempatkan sebuah CommandButton pada PictureBox tersebut, maka bisa dikatakan bahwa kontainer PictureBox menampung sebuah objek CommandButton.

Pada umumnya sebuah kontainer atau koleksi diperlengkapi dengan kode (dulu pada saat pembuatan) agar bisa memanggil objek secara sekaligus menggunakan perulangan For ... Each. Sebagai contoh:
    Dim c As Control 'Deklarasikan bahwa variabel c adalah Control bukan embe atau kucing. 
For Each c In Me.Controls
If TypeOf c Is CommandButton Then
c.Enabled = False 'disablekan
End If
Next
Apabila diterjemahkan maka kira-kira sebagai berikut: Jadikan variabel c sebagai Control bukang string, integer, embe, atau kucing. Untuk setiap c (Control) yang berada pada Container (Me.Controls) [lakukan:] disablekan c (c.Enabled = False).

Dengan memahami yang telah dijelaskan di atas, sekarang bagaimana jika kita ingin mendisablekan seluruh objek yang terdapat pada PictureBox (saja) tanpa mendisablekan objek-objek yang berada di luar PictureBox. Berikur merupakan salah satu contohnya:
Private Sub Command1_Click() 
Dim c As Control 'deklarasikan bahwa variabel c adalah Contol ehm..ehm.. Control
For Each c In Me.Controls
If c.Container.Name = "Picture1" Then
c.Enabled = False
End If
Next
End Sub
Untuk setiap c (control) yang berada pada container [lakukan] jika nama kontainernya adalah Picture1 [pengecualian] maka disablekan c (c.Enabled = False).
READ MORE - Mendisablekan Seluruh Objek Yang Terdapat Pada PictureBox

Tuesday, August 23, 2011

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