Friday, December 30, 2011

Get GetKeyboardLayout language from a thread

Option Explicit  
'Get GetKeyboardLayout language from a thread
'Original code by Gringo Man
Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Private Declare Function
GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

Public Sub
KeyBoardLanguage()

Dim
TheardId As Long
Dim
TheardLang As Long
Dim
processid As Long

TheardId = GetWindowThreadProcessId(hwnd, processid)
TheardLang = GetKeyboardLayout(ByVal TheardId)
TheardLang = TheardLang Mod 10000

If
TheardLang = "9721" Then
MsgBox "English"
ElseIf
TheardLang = "5425" Then
MsgBox "Arabic"
End If

End Sub

Private Sub
Command1_Click()
KeyBoardLanguage
End Sub
READ MORE - Get GetKeyboardLayout language from a thread

Saturday, December 24, 2011

Visual Basic 6.0 - Beberapa Masalah File Manifest

Penggunaan file manifest untuk meng- Style XP-kan objek-objek Visual Basic 6.0 ternyata memiliki bebearapa masalah, diantaranya:
  1. Hilangnya shortcut mnemonic (shortcut underlin/underscore) yang biasa diakses melalui Alt + ...
  2. OptionButton dan CheckBox yang disimpan dalam kontainer Frame berubah berwarna hitam mengakibatkan Caption dari dua objek tersebut tidak dapat terbaca.
  3. CommandButton yang property style-nya diset pada mode 1-Graphical tidak mau berubah menjadi Style XP.
  4. MSCOMCTL.OCX TreeView, ToolBar, dsb tidak mau berubah menjadi Style XP.
Penyelesaian:
  • Masalah ke-1: Simpan kode di bawah ini pada module, selanjutnya panggil pada setiap Event Form Load.
    Option Explicit 

    Private Const
    WM_CHANGEUISTATE As Long = &H127
    Private Const UISF_HIDEFOCUS As Integer = &H1
    Private Const UISF_HIDEACCEL As Integer = &H2
    Private Const UIS_CLEAR As Integer = &H2

    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

    Public Sub
    ShowMnemonic(frm As Form)
    Dim uiState As Long
    uiState = MakeLong(UIS_CLEAR, UISF_HIDEFOCUS Or UISF_HIDEACCEL)
    SendMessage frm.hwnd, WM_CHANGEUISTATE, uiState, ByVal 0
    End Sub

    Private Function
    MakeLong(ByVal wLow As Integer, ByVal wHigh As Integer) As Long
    MakeLong = wHigh * &H10000 + wLow
    End Function
  • Masalah ke-2: Jangan tempatkan OptionButton dan CheckBox secara langsung di atas Frame, tetapi simpanlah kedua objek tersebut di atas PictureBox, selanjutnya pindahkan PictureBox ini ke dalam Frame.
  • Masalah ke-3: Mengenai permasalah ini Anda dapat mengunjugi situs Edanmo (Eduardo A. Morcillo).
  • Masalah ke-4: Sudah diselesaikan disini.
READ MORE - Visual Basic 6.0 - Beberapa Masalah File Manifest

VB6 Code - Cara Menggunakan NotifyIcon.OCX

Artikel di bawah ini kami beri judul Cara Menggunakan NotifyIcon.OCX, Apa yang dimaksud dengan NotifyIcon? lihat screenshot di bawah ini
.
Nah, sekarang Anda faham, apa yang dimaksud dengan NotifyIcon itu. NotifyIcon.ocx dibuat oleh Bhagwat Singh. NotifyIcon.OCX merupakan sebuah ocx yang bagus, ia dapat mengurangi kekomplekan pemograman. Setidaknya kita tidak direpotkan dengan membuat sebuah modul untuk keperluan Icon Tray dan modul untuk keperluan Baloon Tips. Apa yang harus Anda lakukan adalah mengisi properties-propertiesnya saja, hanya itu saja. Sekarang, bagaimanakah cara mengisi properties-propertiesnya menggunakan pengkodean. Copy dan pastekan code di bawah ini, sebelumnya Anda tambahkan NotifyIcon.ocx ke dalam project Anda.
Option Explicit

Private Const VERSI_KAMUS As String = "Kamus Bahasa Arab v3.0"

Private Sub Form_Load()
With NotifyIcon1
.Tip = VERSI_KAMUS
.BaloonIcon = BaloonIcon.Information
.ShowIcon
.BaloonTitle = VERSI_KAMUS
.BaloonText = VERSI_KAMUS & " - Memudahkan pencarian kosakata bahasa arab dengan fasilitas Windows Pop-Up"
.ShowBaloon
End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
NotifyIcon1.DeleteIcon
End Sub
Catatan:
Kamus Bahasa Arab v1.0 s/d v3.0 (yang paling terakhir di release) seluruhnya menggunakan ocx ini.
READ MORE - VB6 Code - Cara Menggunakan NotifyIcon.OCX

Wednesday, November 23, 2011

KBA Editor 1.0

Ini merupakan kelanjutan dari posting sebelumnya, mengenai cara menambahkan kosakata ke dalam Kamus Bahasa Arab v3.0. Selain aplikasi-aplikasi yang bisa digunakan untuk menambah kosakata (notepad, wordpad, word, dll) kita pun dapat membuat sendiri aplikasi kecil untuk lebih mempermudah mengisi kosakta, dan ini merupakan salah satu contohnya, saya namakan dengan KBA Editor. Apabila ada kekurangan/bug/error Anda dapat memperbaikinya melalui source codenya.

Catatan: Satukan folder KBA Editor 1.0 dengan Kamus Bahasa Arab v3.0 pada saat proses installasi. Apabila Anda telah memiliki banyak kosatakata yang disimpan dalam file tambahan.txt, jangan lupa untuk mem-backup (mengkopi salinan) file tambahan.txt.

READ MORE - KBA Editor 1.0

Memiliki Akun Google Adsense Itu Mudah - Blogging

Artikel ini, untuk yang memahami permainan google adsense tetapi tidak/belum/gagal memiliki akun google adsense, dan sedikitnya telah memahami mengenai dunia blogging. Mengirim artikel dan diterima menjadi publisher google adsense itu tidaklah sulit, yang sangat sulit adalah memperoleh penghasilan darinya.Sebelum Anda mengirimkan blog/artikel, ada beberapa hal yang harus diperhatikan yakni pada saat kita mengirimkan sebuah blog/artikel sebenarnya blog yang kita kirimkan tersebut pada dasarnya tidak langsung direview oleh manusia, tetapi harus melewati mesin pemindai yang dilengkapi auto respond dan sistem pakar terlebih dahulu. Jika blog yang Anda kirim tidak sesuai kreteria google (sesuai dengan sistem pakar yang diprogramkan), maka si mesin tersebut akan mengirimkan email penolakan sesuai dengan kreteria kesalahan yang terdapat pada blog tersebut (sistem pakar). Hal ini dilakukan untuk menekan biaya, tenaga, waktu, terlebih kecepatan. Kesimpulannya Google akan mengandalkan mesin bagi tugas-tugas yang seratus persen dapat diselesaikan oleh sebuah mesin. Contoh sederhananya adalah masalah yang berkenaan dengan broken link, dll. Nah, setelah kita mengetahui bahwa Google mengandalkan mesin untuk tugas yang seratus persen bisa dilakukan mesin tersebut, lalu bagaimana dengan peran manusianya?. Pada jaman modern dan canggih menurut versi kita sekarang (bukan versi 200 tahun mendatang), ketahuilah masih banyak sekali hal-hal yang menurut manusia sangat sederhana akan tetapi menjadi sangat-sangat rumit bahkan mustahil dilakukan oleh sebuah mesin. Contoh sederhananya mengidentifikasi gambar. Terlebih mengenai detail dari gambar tersebut, apakah wajahnya terlihat bahagia atau sedih? laki-laki atau perempuan (keduanya memiliki rambut yang sama panjang)?. Adapun kaitan dengan tulisan di atas, bagaimana jika blog yang kita submit memuat konten-konten yang tidak diperbolehkan? apakah mesin dapat menyelesaikannya? tentu saja tidak, tetapi manusia yang melakukannya. Ini sekedar contoh sederhana saja mengenai peran manusia di dalamnya. Setelah kita memahami dua hal di atas, maka untuk mudah diterima menjadi publisher adsense ikuti langkah berikut: buatlah email baru di gmail.com buatlah blog baru di blogger menggunakan akun gmail tadi (bukankah harus berumur 6 bulan dengan domain sendiri?) gantilah template dengan minima, ini untuk menangkal penolakan karena navigasi yang sulit pastikan untuk mengisi data secara lengkap buatlah beberapa belas atau beberapa puluh artikel. gunakan Bahasa Inggris. Mengenai artikel, perhatikan: tidak ada broken link (penolakan kebanyakan bukan berada di sini) bukan duplikat konten (100% copy paste tanpa edit) Konten yang berhubungan antara judul, sub judul, isi/artikel menurut versi mesin bukan menurut versi manusia (penolakan kebanyakan berada di sini). Dari sekian baris tulisan di atas, konten yang tidak berhubungan inilah yang paling banyak dan menjadi penyebab utama penolakan, bukan masalah domain, bukan masalah umur yang 6 bulan itu, bukan masalah Bahasa Inggris, bukan masalah duplikat konten, juga bukan masala broken link karena kita telah yakin dan memastikan serta mematuhi semuanya. Konten yang berhubungan menurut versi manusia, belum tentu berhubungan menurut versi mesin, disinilah letak permasalahan utamanya, mengapa terjadi demikian? Ini disebabkan karena mesin tersebut bekerja dengan cara menumpuk keyword-keyword dari artikel yang kita kirimkan dan membandingkannya dengan judul-judul blog tersebut, kemudian mesin tersebut membuat keputusan sebagai blog yang memiliki konten berhubungan atau sebaliknya, dan hasilnya kebanyakan adalah blog dengan konten yang tidak memiliki hubungan menurut versi mesin, dan hasil akhirnya adalah ditolak. Nah, jika sudah demikian, bagaimana cara mengatasinya? seret dan giring saja si mesin pemindai tersebut ke daerah (blog/artikel) yang sangat sempit. Sebuah daerah (blog/artikel) yang kemungkinan peluang salah terjemahnya sangat kecil. Jika Anda memahami salah satu bahasa pemrogrman tentu hal ini lebih mudah, yakni dengan membuat artikel dari awal sampai akhir hanya berisi kode-kode saja (saya menyarankan yang ini). Link/tautan di bawah merupakan salah satu contoh blog dari seluruh penjelasan di atas, tidak pernah di rubah baik template maupun judul-judulnya semenjak diterima menjadi publisher adsense tahun 2009. Karena tidak pernah dikelola dan sepi pengunjung, di dalamnya hanya ada satu dollar saja, padahal sudah dua tahun ya? tidak apa-apa, setidaknya rasa penasaran itu sudah terobati. http://4basic-vb.blogspot.com Anda diperbolehkan mengcopy paste seluruh artikel yang terdapat pada http://4basic-vb.blogspot.com tanpa menyebutkan sumbernya, yang perlu Anda lakukan adalah mengganti judul-judul artikelnya dan mengganti header-headernya saja, agar tidak terjadi duplikat konten. Untuk memastikan tidak terdapat duplikat konten, ujilah judul-judul dan header-header yang telah Anda ganti melalui search engine google dengan memberi tanda petik di kiri dan kanan. Blog yang baru Anda buat dan submit pertama kali tersebut harus langsung diterima menjadi publisher google adsense, jika masih ragu, pastikan sekali lagi bahwa seluruhnya telah terselesaikan dengan baik. Waktu tersedia banyak dan google sabar menunggu. Catatan Penting: Hindari membuat beberapa akun (misalnya Anda dan teman-teman Anda) dalam ip adress yang sama, jika satu akun dibanned, kemungkinan akan dibanned seluruhnya. Karena yang diperhitungkan mesin di sini lebih kepada IP Adress, tetapi ini hanya sekedar kemungkinan saja
READ MORE - Memiliki Akun Google Adsense Itu Mudah - Blogging

Drag And Drop Pada Dua ListBox - VB6 Souce Code

Terkadang dalam memprogram kita membutuhkan operasi drag and drop antara dua object ListBox, contohnya untuk pembuatan wizard dan lain sebagainya. Di bawah ini merupakan contoh source codenya. Dibuat oleh Luciano Esteban Lodola pemilik situs: http://www.recursosvisualbasic.com.ar
Option Explicit 
' ---------------------------------------------------------------------------------------
' \ -- Autor : Luciano Lodola -- http://www.recursosvisualbasic.com.ar
' ---------------------------------------------------------------------------------------

' \ -- funciNn de windows para poder obtener un elemento (Indice) de un control de lista a partir de la psiciNn del mouse
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long

' -- Constante / mensaje para recupera el Item a partir de la posiciNn del mouse ( con SendMessage )
Private Const LB_ITEMFROMPOINT = &H1A9
Public iX As Integer
' --------------------------------------------------------------------------------------
'\ -- Inicio
' --------------------------------------------------------------------------------------
Private Sub Form_Load()

Dim i As Byte
' -- Agregar elementos de muestra para el ejemplo
With List1
.AddItem "Impresora Epson"
.AddItem "Impresora Lexmark"
.AddItem "Monitor LG"
.AddItem "Monitor Samsung"
.AddItem "PC Pentium Dual Core"
.AddItem "PC Pentium Core Duo"
.AddItem "Impresora lDser HP - MonocromDtica"
.AddItem "Impresora lDser Epson - MonocromDtica"
.AddItem "Impresora lDser color"
End With
' -- Importante !!!! Habilitar el Drag con el mï؟½todo OLEDragMode, y el Drop para el List2
List1.OLEDragMode = 1
List2.OLEDropMode = 1
End Sub

' --------------------------------------------------------------------------------------
'\ -- FunciNn que retorna el Jndice del Item del List2 ( Donde se encuentra el mouse )
' --------------------------------------------------------------------------------------
Private Function pvGetItemFromPoint(X As Single, Y As Single, lBox As ListBox) As Long

Dim
indice As Long
Dim
XPoint As Long
Dim
YPoint As Long
Dim
ZPoint As Long

' -- Valor por defecto de retorno de la funciNn ( NingRn item estD seleccionado)
indice = -1

XPoint = CLng(X / Screen.TwipsPerPixelX)
YPoint = CLng(Y / Screen.TwipsPerPixelY)
ZPoint = CLng(YPoint * &H10000 + XPoint)
With lBox
' -- Recupera el item seleccionado (el Jndice )
indice = SendMessage(.hwnd, LB_ITEMFROMPOINT, 0, ByVal ZPoint)
If indice >= 0 And indice <= .ListCount Then
pvGetItemFromPoint = indice
End If
End With
End Function
' --------------------------------------------------------------------------------------
'\ -- Iniciar Drag del item
' --------------------------------------------------------------------------------------
Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
iX = X
List1.OLEDrag
End Sub

' --------------------------------------------------------------------------------------
'\ -- evento que se produce al soltar el item
' --------------------------------------------------------------------------------------
Private Sub List2_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim
lIndex As Long
' -- Obtener el Jndice pasando a la funciNn
lIndex = pvGetItemFromPoint(X, Y, List2)
' -- Agregar con el mï؟½todo Additem en la posiciNn indicada por el Jndice
If lIndex >= 0 Then
List2.AddItem Data.GetData(1), lIndex
Else
List2.AddItem Data.GetData(1)
End If
' -- seleccionar el dato
If lIndex <> -1 Then List2.Selected(lIndex) = True
' -- Opcional - eliminar el elemento del List
List1.RemoveItem (List1.ListIndex)

End Sub
READ MORE - Drag And Drop Pada Dua ListBox - VB6 Souce Code

Mengcopy Seluruh Folder Beserta Isinya - VB6 Source

Berikut merupakan contoh source code untuk mengcopy folder beserta seluruh isi yang terdapat di dalamnya. Menggunakan Microsoft Scripting Runtime. Untuk lebih memudahkan penggunaan Anda dapat merubahnya menjadi Function.

Sumber: http://www.i-bego.com/visual-basic/copy-folder-pada-vb-t3616.html

Private Sub CopyFolder() 
Dim fso
Dim sfol As String, dfol As String
sfol = "c:\MyFolder" ' change to match the source folder path
dfol = "e:\MyFolder" ' change to match the destination folder path
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(dfol) Then
fso.CopyFolder sfol, dfol
Else
MsgBox dfol & " already exists!", vbExclamation, "Folder Exists"
End If
End Sub
READ MORE - Mengcopy Seluruh Folder Beserta Isinya - VB6 Source

Memahami Bookmark Pada Microsoft ADO

Masing-masing record akan memiliki bookmark. Bookmark itu sifatnya unik (berbeda satu sama lainnya). Bookmark tidak dapat dilihat. Bookmark hanya bisa ditampung dalam datatype variant. Bookmark itu ... dan lain sebagainya.

Di bawah ini merupakan contoh sederhana penggunaan bookmark pada Microsoft ADO:
Download: Contoh Penggunaan Bookmark
READ MORE - Memahami Bookmark Pada Microsoft ADO

ADO Database dan Progress Bar - VB6 Source Code

Umumnya pada saat kita me-load database, seluruh form akan menjadi freeze (beku). Hal ini disebabkan kompiler hanya melakukan satu eksekusi kode dalam satu waktu. Hal ini tentu saja mempengaruhi terhadap splash form (form loading) yang dilengkapi unlimited progress bar. Pada dasarnya progress bar tersebut tidak akan pernah ditampilkan dengan baik. Nah, agar kompiler dapat mengeksekusi 2 kode dalam waktu bersamaan (load database/recordset dan tampilan progress bar) maka load-lah database tersebut menggunakan mode Asyncron. Nah, Asyncron itu adalah kata kuncinya.
READ MORE - ADO Database dan Progress Bar - VB6 Source Code

Menambahkan Kosakata Pada Kamus Bahasa Arab v3.0

Berbeda dengan versi-versi sebelumnya, maka pada versi yang ketiga, Anda dapat menambahkan sendiri kosakata yang belum ada. Kosakata tersebut bisa Anda tambahkan dengan menggunakan Word, Excel, Access, Wordpad, ataupun Notepad.

File yang digunakan untuk keperluan ini terletak pada folder bersamaan dengan file aplikasinya (.exe). File tersebut saya namakan dengan tambahan.txt. Di dalamnya terdapat satu contoh kosakata. Terdiri dari 4 kolom, kolom tersebut secara berturut-turut kosakata, indeks, arti, fiil-bukan fiil.

  1. Kosakata berisi kosakata arab yang hendak dicari.
  2. Indeks berisi keyword dari kosakata di atas, bisa berisi satu atau lebih dengan menggunakan delimiter (pemisah) spasi.
  3. Arti berisi arti dari kosakata di atas.
  4. Fiil dan bukan fiil berisi data type boolean, angka satu mewakili fiil dan angka 0 mewakili bukan fiil (ism atau harf).
READ MORE - Menambahkan Kosakata Pada Kamus Bahasa Arab v3.0

Sunday, October 23, 2011

Perbedaan .ScaleWidth dan .Width pada Form - Tips dan Trik V

Apakah perbedaan property .ScaleWidth dan .Width pada Form? .Width adalah lebar dari ujung kiri sampai ujung kanan. Sedangkan .ScaleWidth adalah lebar ujung kiri sampai ujung kanan - border sisi kiri dan sisi kanan. Dengan kata lain .ScaleWidth adalah seluruh daerah Form yang bisa digunakan untuk menyimpan control, demikian pula .ScaleTop, .ScaleHeight, dan .ScaleLeft. Untuk memahaminya lebih baik maka:
  1. Buatlah project baru
  2. Tempatkan satu TextBox pada Form
  3. Copy dan pastekan kode di bawah ini:

  4. Option Explicit 

    Private Sub
    Form_Resize()
    With Text1
    .Top = Me.ScaleTop
    .Left = Me.ScaleLeft
    .Width = Me.ScaleWidth
    .Height = Me.ScaleHeight
    End With
    End Sub
  5. Jalankan.
dan tentu saja akan berbeda dengan kode di bawah ini:
Private Sub Form_Resize() 
With Text1
.Top = 0
.Left = 0
.Width = Me.Width
.Height = Me.Height
End With
End Sub
Catatan: Settinglah property Text1 .MultiLine = True dan .ScrollBar = 3 -Both

READ MORE - Perbedaan .ScaleWidth dan .Width pada Form - Tips dan Trik V

Agar Form Tidak Terpengaruh Resolusi Screen - Tips VB6

Setelah memahami perbedaan .Top, .Left, .Width, .Height dengan .ScaleTop, .ScaleLeft, .ScaleWidth, .ScaleHeight maka kita sekarang melangkah pada bagian selanjutnya mengenai tampilan yang tidak terpengaruh oleh resolusi layar. Sederhanya agar sebuah form memiliki ukuran relatif sama adalah membagi ukurannya lebar dan tinggi berdasarkan prosentase. Perhatikan 2 baris kode di bawah:
Option Explicit 

Private Sub Form_Resize()
With Form1
.Left = 0
.Top = 0
.Height = Screen.Height
.Width = Screen.Width
End With
End Sub
Kode di atas akan membuat sebuah form memiliki ukuran sama dengan tinggi dan lebar layar, berapapun resolusinya. Maka kode di bawah akan membuat form memiliki ukuran 1/2 dari ukuran layar baik tinggi maupun lebarnya, berapapun resolusi layar yang Anda setting.
Option Explicit 

Private Sub Form_Resize()
With Form1
.Left = 0
.Top = 0
.Height = (Screen.Height * 0.5) 'Ini akan membuat tinggi Form setengahnya dari layar
.Width = (Screen.Width * 0.5) 'Ini akan membuat lebar Form setengahnya dari layar.
End With
End Sub
Sekarang coba Anda rubah resolusi layar ke posisi paling ektrim terbesar atau ke posisi ektrim terendah, Apakah tinggi dan lebar Form tersebut berubah? tidak, dia tetap setengahnya dari layar. Lalu apa yang harus Anda lakukan selanjutnya, melakukan resize terhadap seluruh control (CommandButton, TextBox, Label, dan lain-lain. Nah, bagaimana caranya?
READ MORE - Agar Form Tidak Terpengaruh Resolusi Screen - Tips VB6

Control Yang Tidak Terpengaruh Oleh Resolusi Screen - Trik V

Apabila Form diiperbandingkan kepada Screen, maka control harus diperbandingkan kepada Form. Maksudnya kepada .ScaleTop, .ScaleLeft, .ScaleWidth, .ScaleHeight seperti yang telah kita pelajari sebelumnya.

Baiklah, sekarang saya akan membuat sebuah contoh control yang tidak terpengaruh oleh perubahan resolusi screen. Dalam hal ini control diwakili oleh satu CommandButton.
Option Explicit 

Private Sub
Form_Resize()
On Error Resume Next
With
Form1
.Left = 0
.Top = 0
.Height = (Screen.Height * 0.5)
.Width = (Screen.Width * 0.5)
End With
With
Command1
.Left = (Me.ScaleWidth * 0.68)
.Top = (Me.ScaleHeight * 0.78)
.Width = (Me.ScaleWidth * 0.2)
.Height = (Me.ScaleHeight * 0.1)
End With
End Sub

Nah, sekarang bagaimana jika di dalam Form tersebut terdapat 31 control, Apakah kita harus mengkodenya satu persatu? tentu saja tidak, di atas hanyalah dasar-dasar atau kode dasar untuk memudahkan pemahaman bagaimana agar form dan control tidak terpengaruh oleh resolusi screen. Adapun dalam kenyataanya, Anda harus memodifikasi dan membuatnya menjadi .Class, .Module, .OCX, .DLL agar mudah digunakan.

READ MORE - Control Yang Tidak Terpengaruh Oleh Resolusi Screen - Trik V

Cara Sederhana Mendeteksi Perubahan Resolusi Screen - Trik V

Bagaimana kita mengetahui perubahan resolusi screen dengan hanya menggunakan beberapa baris kode saja? Mendeteksi Current OS (operating system yang sedang digunakan), mendeteksi Plug n Play Device (external hardisk, flashdisc, webcam, dll), screen client area, perubahan konfigurasi system, mendeteksi perubahan waktu, dan sebagainya?.

Untuk keperluan yang telah dijelaskan di atas, kita bisa menggunakan SysInfo.OCX (Microsoft SysInfo Control 6.0). Sysinfo seakan-akan sesuatu yang mutlak diperlukan dalam membuat sebuah aplikasi yang baik. Mengapa demikian?

Di bawah ini merupakan contoh sederhananya:
Option Explicit 

Dim
strOldResolution As String

Private Sub
Form_Load()
With Timer1
.Enabled = False
.Interval = 100
End With
strOldResolution = "Resolution: " & Screen.Width / Screen.TwipsPerPixelX & _
" x " & Screen.Height / Screen.TwipsPerPixelY
Me.Caption = strOldResolution
Text1.Text = strOldResolution & vbCrLf
End Sub

Private Sub
SysInfo1_DisplayChanged()
Timer1.Enabled = True 'delay time
End Sub

Private Sub
Timer1_Timer()
Dim strText As String 'buffer variable
strText = Text1.Text
strText = strText & "Resolusi berubah menjadi: " & Screen.Width / Screen.TwipsPerPixelX & _
" x " & Screen.Height / Screen.TwipsPerPixelY & vbCrLf
Text1.Text = strText
Timer1.Enabled = False
End Sub

Dan tentu saja Anda bisa membuat modifikasi untuk disesuaikan dengan kebutuhan, misalnya seperti kode di bawah ini (kode yang berasal dari posting sebelumnya):
Option Explicit 

Private Sub
Form_Resize()
On Error Resume Next
With
Form1
.Left = 0
.Top = 0
.Height = (Screen.Height * 0.5)
.Width = (Screen.Width * 0.5)
End With
With
Command1
.Left = (Me.ScaleWidth * 0.68)
.Top = (Me.ScaleHeight * 0.78)
.Width = (Me.ScaleWidth * 0.2)
.Height = (Me.ScaleHeight * 0.1)
End With
End Sub

Private Sub
SysInfo1_DisplayChanged()
If chkNonAktif.Value = vbChecked Then Exit Sub
Timer1.Enabled = True
End Sub

Private Sub
Timer1_Timer()
Form_Resize
Timer1.Enabled = False
End Sub

Selain Sysinfo.OCX yang dibuat oleh Microsoft, Anda bisa juga menggunakan SysInfo yang dibuat oleh Karl E. Peterson, dan menurut saya ini lebih baik. Terakhir, mengapa SysInfo yang dibuat Karl E. Peterson saya anggap lebih baik?
READ MORE - Cara Sederhana Mendeteksi Perubahan Resolusi Screen - Trik V

Menambahkan Item Ke dalam ListBox tanpa Duplikat - VB6

Menggunakan fungsi API, sehingga kecepatannya bisa dikatakan sangat baik. Adapun kodenya adalah seperti di bawah ini:
Option Explicit 

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
LB_FINDSTRINGEXACT As Long = &H1A2

Private Function
AddItemListUnix(lst As ListBox, ByVal sItem As String) As Boolean
If
(SendMessage(lst.hwnd, LB_FINDSTRINGEXACT, -1&, ByVal sItem) > -1) Then Exit Function
lst.AddItem sItem
End Function
Mengenai contoh penggunaannya:
Private Sub Command1_Click() 
AddItemListUnix List1, "Test"
AddItemListUnix List1, "Test"
AddItemListUnix List1, "Form"
AddItemListUnix List1, "Test"
AddItemListUnix List1, "CommandButton"
AddItemListUnix List1, "CommandButton"
End Sub
READ MORE - Menambahkan Item Ke dalam ListBox tanpa Duplikat - VB6

ListBox Load Table - 10 s/d 20 X Lebih Cepat - Tips dan Tric

Option Explicit

Tentu Anda sudah tidak asing lagi dengan potongan kode di bawah:
Do While Recordset.EOF = False 
ListBox.AddItem Recordset!Field
Recordset.MoveNext
Loop

Atau kode di bawah ini:
For i = 1 To Recordset.RecordCount 
ListBox.AddItem Recordset!Field
Recordset.MoveNext
Next

Kedua kode di atas digunakan untuk mem-populate (mengisi) ListBox atau ComboBox dengan Field dari sebuah database. Kode di atas bisa menjadi 10 s/d 20 kali lebih cepat dengan sedikit memodifikasi kodenya yakni dengan membuat satu variable yang diperlakukan sebagai buffer. Coba Anda bandingkan dua kode di bawah ini:
Private Sub Command2_Click() 

Dim L As Long
Dim v As Variant
Dim t As Double

t =
GetTickCount
Set adoPrimaryRS = New Recordset
adoPrimaryRS.Open "SELECT isbn FROM [Title Author] ORDER BY isbn", db, adOpenStatic, adLockOptimistic

List1.Clear
List1.Visible = False

For L =
0 To adoPrimaryRS.RecordCount - 1
List1.AddItem adoPrimaryRS!isbn
adoPrimaryRS.MoveNext
Next

List1.Visible = True
Me.Caption = GetTickCount - t & " milliseconds"

End Sub

Dengan kode di bawah ini:
Private Sub Command1_Click() 

Dim L As Long
Dim v As Variant
Dim t As Double

t =
GetTickCount
Set adoPrimaryRS = New Recordset
adoPrimaryRS.Open "SELECT isbn FROM [Title Author] ORDER BY isbn", db, adOpenStatic, adLockOptimistic

List1.Clear
List1.Visible = False
v =
adoPrimaryRS.GetRows

For L =
0 To adoPrimaryRS.RecordCount - 1
List1.AddItem v(0, L)
Next

v = Empty

List1.Visible = True
Me.Caption = GetTickCount - t & " milliseconds"

End Sub

Catatan: Dua kode di atas digunakan untuk mengakses database BIBLIO.MDB.
READ MORE - ListBox Load Table - 10 s/d 20 X Lebih Cepat - Tips dan Tric

Friday, September 23, 2011

Update: My Source Online 2.0 - Online MySQL Database

Rupanya pada versi yang sebelumnya terjadi beberapa kegagalan, diantaranya:
  1. Gagal dalam mengecek koneksi internet, modul yang digunakan adalah -[memeriksa keberadaan koneksi internet]- sehingga selalu menampilkan pesan error "Mohon maaf, tidak ada koneksi internet".
  2. Gagal dalam meregistrasikan COMDLG32.OCX (CommonDialog ActiveX), kemungkinan masalah versi.

Kedua masalah tersebut telah saya perbaiki, pertama dengan mengganti modul check koneksi internet masalah kedua diatasi dengan cara mengganti COMDLG32.OCX dengan class yang diembed langsung pada aplikasi.

Catatan: karena aplikasi ini tidak dilengkapi dengan file-file runtime (hanya dua ActiveX yang disertakan vbSendMail dan CMAX20.OCX [Syntax Hightlighter]), maka sebaiknya Anda lengkapi dulu runtimenya dan beberapa file untuk mengakses database MySQL, atau Anda rujuk pada link di bawah ini:

  1. Aplikasi Minimarket (menggunakan database MySQL, lengkap beserta file-file runtime yang dibutuhkan)
  2. MySQL ODBC 3.51 Driver

Nah, setelah menjalankan dua file di atas, seharusnya Anda sudah dapat mengakses database MySQL secara online menggunakan VB6.

Download: My Source Online 2.0

READ MORE - Update: My Source Online 2.0 - Online MySQL Database

My Source Online 2.0 - Online MySQL Database

Rupanya pada versi yang sebelumnya terjadi beberapa kegagalan, diantaranya:
  1. Gagal dalam mengecek koneksi internet, modul yang digunakan adalah -[memeriksa keberadaan koneksi internet]- sehingga selalu menampilkan pesan error "Mohon maaf, tidak ada koneksi internet".
  2. Gagal dalam meregistrasikan COMDLG32.OCX (CommonDialog ActiveX), kemungkinan masalah versi.

Kedua masalah tersebut telah saya perbaiki, pertama dengan mengganti modul check koneksi internet masalah kedua diatasi dengan cara mengganti COMDLG32.OCX dengan class yang diembed langsung pada aplikasi.

Catatan: karena aplikasi ini tidak dilengkapi dengan file-file runtime (hanya dua ActiveX yang disertakan vbSendMail dan CMAX20.OCX [Syntax Hightlighter]), maka sebaiknya Anda lengkapi dulu runtimenya dan beberapa file untuk mengakses database MySQL, atau Anda rujuk pada link di bawah ini:

  1. Aplikasi Minimarket (menggunakan database MySQL, lengkap beserta file-file runtime yang dibutuhkan)
  2. MySQL ODBC 3.51 Driver

Nah, setelah menjalankan dua file di atas, seharusnya Anda sudah dapat mengakses database MySQL secara online menggunakan VB6.

Download: My Source Online 2.0

READ MORE - My Source Online 2.0 - Online MySQL Database

Software My Source Online 1.0 - Menggunakan Database MySQL

My Source Online 1.0 merupakan sebuah aplikasi untuk menyimpan kode VB6 ke dalam database MySQL secara online.

Download: http://khoiriyyah.vacau.com/source_online.zip

Agar tidak terjadi error pastikan Anda telah menginstall MySQL Connector 3.51.

READ MORE - Software My Source Online 1.0 - Menggunakan Database MySQL

Software My Source Online 1.0 - Menggunakan Database MySQL

My Source Online 1.0 merupakan sebuah aplikasi untuk menyimpan kode VB6 ke dalam database MySQL secara online.

Download: http://khoiriyyah.vacau.com/source_online.zip

Agar tidak terjadi error pastikan Anda telah menginstall MySQL Connector 3.51.

READ MORE - Software My Source Online 1.0 - Menggunakan Database MySQL

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