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

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

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.

• Download: KBA Editor 1.0 (Setup)
• Download: KBA Editor 1.0 (Source Code)

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

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:



Option Explicit 
 
Private Sub Form_Resize() 
    With Text1 
        .Top = Me.ScaleTop 
        .Left = Me.ScaleLeft 
        .Width = Me.ScaleWidth 
        .Height = Me.ScaleHeight 
    End With 
End Sub 

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

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

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