Mengektrak Seluruh Link Atau Elemen Menggunakan MSHTML - VB6

Mengenai cara mengekstrak seluruh link atau elemen yang ditentukan dalam sebuah halamn HTML menggunakan VB6 dengan bantuan ActiveX MSHTML - Adapun contoh kode untuk mengektrak seluruh link menggunakan VB6 dengan bantuan MSHTML adalah sebagai berikut:

Private Sub Command1_Click()

    Dim d As New MSHTML.HTMLDocument
    Dim l As HTMLImg
    Dim x As HTMLHtmlElement
    
    List1.Clear
    d.body.innerHTML = Text1.Text
    
    Set x = d.getElementById("IMG")
   
    For Each l In d.images
        If l.src <> "" Then
            List1.AddItem l.src
        End If
    Next
    Text1.Text = d.body.innerHTML
    
End Sub

Demikian contoh untuk mengekstrak link atau elemen yang ditentukan menggunkan VB6 dengan bantuan ActiveX MSHTML, semoga bermanfaat.

READ MORE - Mengektrak Seluruh Link Atau Elemen Menggunakan MSHTML - VB6

TwitterCOM.dll - Mengirim Tweet Ke Twitter Dari VB6

Mengenai cara mengirim tweet ke twitter.com menggunakan aplikasi yang dibuat dengan VB6 menggunakan bantuan COM ActiveX yang miskin fitur yang diberi nama TwitterCOM.dll. Sekarang saya mau share mengenai TwitterCOM.dll sebuah COM ActiveX yang miskin fiture, walaupun miskin fitur, akan tetapi dengan menggunakan TwitterCOM.dll maka mengirim tweet ke twitter menjadi sangat mudah, siapapun dapat melakukannya termasuk saya, Anda, ibu-ibu, kakek-kakek, nenek-nenek, anak di bawah umur, balita, bayi, baik pria maupun wanita. Dengan syarat terkoneksi dengan internet dan memiliki akun twitter. That's All.
Adapun kode untuk mengirim tweet ke twitter adalah sebagai berikut:

Option Explicit

'http://khoiriyyah.blogspot.com

Private Sub cmdSendTweet_Click()
    Dim t As New Twitter
    With t
        .AccessToken = txtToken.Text
        .AccessTokenSecret = txtAccessTokenSecret.Text
        .ConsumerKey = txtConsumerKey.Text
        .ConsumerSecret = txtConsumerSecret.Text
        .Tweet = txtTweet.Text
        .SendTweet
    End With
    Set t = Nothing
End Sub

Wah, ternyata mengirim tweet ke twitter.com menggunakan VB6, kodenya sederhana beungeut.
Catatan sangat penting:
Sebelum menggunakan TwitterCOM.dll Anda harus memperoleh 4 key, yaitu:

1. Consumer Key
2. Access Token
3. Consumer Secret
4. Access Token Secret

Sekarang kita sudah tidak membutuhkan UserName dan Password untuk melakukan proses ototirasi dan otentifikasi, karena sejak Desember 2009 Twitter sudah tidak menggunakan lagi Basic Auth dan berpindah ke OAuth 1.0a.
Anda dapat memperoleh 4 kunci di atas dari https://dev.twitter.com/apps kemudian aktifkan mode access read-writenya.
Download: TwitterCOM.dll

READ MORE - TwitterCOM.dll - Mengirim Tweet Ke Twitter Dari VB6

Contoh Mengambil Image Dari Resource - VB6 Code

Mengenai cara mengambil gambar dari file resource menggunakan pemrograman Visual Basic 6 - Bagaimana kita dapat menggunakan gambar yang terdapat pada resource file, berikut adalah jawabannya:

Private Sub Form_Paint()
    Me.PaintPicture VB.LoadResPicture(101, vbResBitmap), 0, 0
End Sub

Walaupun hanya satu baris, semoga bermanfaat.

READ MORE - Contoh Mengambil Image Dari Resource - VB6 Code

Dua Cara Memperoleh Nama Hari Dari Tanggal Tertentu

Cara Pertama

Private Function GetDayName(d As Date) As String
    GetDayName = WeekdayName(Weekday(d, vbMonday))
End Function

Cara Kedua

Private Function GetDayName(d As Date) As String
    GetDayName = Format$(d, "dddd")
End Function

Contoh penggunaan

Private Sub Command1_Click()
    MsgBox GetDayName(#6/14/2012#)
End Sub

READ MORE - Dua Cara Memperoleh Nama Hari Dari Tanggal Tertentu

Dua Cara Memperoleh Tanggal Terakhir Dari Bulan Tertentu

Cara Pertama:

Private Function GetLastDayOfMonth(d As Date) As Integer
    GetLastDayOfMonth = DateDiff("d", Format$(d, "mm/yyyy"), Format$(DateAdd("m", 1, d), "mm/yyyy"))
End Function

Cara Kedua:

Private Function GetLastDayOfMonth(d As Date) As String
    GetLastDayOfMonth = DateAdd("m", 1, DateSerial(Year(d), Month(d), 1)) - 1
End Function

Contoh Penggunaan:

Private Sub Command2_Click()
    Dim d As Date
    d = #7/13/2012#
    MsgBox GetLastDayOfMonth(d)
End Sub

READ MORE - Dua Cara Memperoleh Tanggal Terakhir Dari Bulan Tertentu

Tidy XML Menggunakan XSL Transform - VB6 Source Code

Private Function TidyXML(sXML As String) As String
    Dim oXSLT As DOMDocument
    Dim XSL_FILE As String
    Dim sResult As String
    Const DoubleQuotes = """"
    Dim strText As String
    Dim objDom As DOMDocument
 
    Set objDom = New DOMDocument
    objDom.loadXML sXML
 
    Set oXSLT = New DOMDocument
    XSL_FILE = "<?xml version=" & DoubleQuotes & "1.0" & DoubleQuotes & " encoding=" & DoubleQuotes & "UTF-8" & DoubleQuotes & "?>" & vbCrLf & "<xsl:stylesheet version=" & DoubleQuotes & "1.0" & DoubleQuotes & " xmlns:xsl=" & DoubleQuotes & "http://www.w3.org/1999/XSL/Transform" & DoubleQuotes & ">" & vbCrLf & "     <xsl:output method=" & DoubleQuotes & "xml" & DoubleQuotes & " version=" & DoubleQuotes & "1.0" & DoubleQuotes & " encoding=" & DoubleQuotes & "UTF-8" & DoubleQuotes & " indent=" & DoubleQuotes & "yes" & DoubleQuotes & "/>" & vbCrLf & "     <xsl:template match=" & DoubleQuotes & "@* | node()" & DoubleQuotes & ">" & vbCrLf & "          <xsl:copy>" & vbCrLf & "               <xsl:apply-templates select=" & DoubleQuotes & "@* | node()" & DoubleQuotes & " />" & vbCrLf & "          </xsl:copy>" & vbCrLf & "     </xsl:template>" & vbCrLf & "</xsl:stylesheet>"
    objDom.async = False
    oXSLT.async = False
    oXSLT.loadXML XSL_FILE
    If oXSLT.parseError.errorCode = 0 Then
        If oXSLT.readyState = 4 Then
            sResult = objDom.transformNode(oXSLT.documentElement)
            sResult = Replace$(sResult, "<?xml version=" & DoubleQuotes & "1.0" & DoubleQuotes & " encoding=" & DoubleQuotes & "UTF-16" & DoubleQuotes & "?>", vbNullString, , , vbTextCompare)
            objDom.loadXML sResult
        End If
    Else
        Debug.Print Err.Description = oXSLT.parseError.reason & vbCrLf & "Line: " & oXSLT.parseError.Line & vbCrLf & "XML: " & oXSLT.parseError.srcText
        Err.Clear
    End If
 
    strText = objDom.xml
 
    TidyXML = strText
End Function

READ MORE - Tidy XML Menggunakan XSL Transform - VB6 Source Code

Cara Yang Sangat Efisien Untuk Mengkonversi Detik

Mengenai cara yang sangat efisien untuk mengkonversi detik ke jam:menit:detik menggunakan VB6 - Kita hanya perlu 1 baris untuk mengkonversi detik ke jam:menit:detik, adapun kodenya adalah sebagai berikut:

Option Explicit

Private Sub Command1_Click()
    MsgBox Format$(DateAdd("s", SecondToConvert, 0), "hh:mm:ss")
End Sub

READ MORE - Cara Yang Sangat Efisien Untuk Mengkonversi Detik

App.Path Dalam VB6 Bisa Diganti Dengan Dot Slash

Mengenai App.path dalam VB6 yang bisa kita ganti dengan "./" (dot slash) - Misalnya kita membuat kode seperti ini:
Shell App.Path & "\Launcher.exe" bisa kita ganti menjadi Shell "./Launcher.exe" atau Shell "Launcher.exe" tanpa App.path dan "./" (dot slash".

READ MORE - App.Path Dalam VB6 Bisa Diganti Dengan Dot Slash

Mengaktifkan Horizontal ScrollBar Pada RichTextBox

Mengenai cara mengaktifkan Horizontal ScrollBar yang terdapat pada objek RichtTextBox VB6 Code - Pada saat kita mengisi text RichTextBox, maka secara otomatis RichTextBox tersebut akan melakukan aksi WordWrap, sekalipun kita telah menyeting properties RichtTextBox tersebut menjadi bernilai 3 - rtfBoth (Horizontal dan ScrollBar). Hal tersebut dikarenakan RightMargin yang terdapat pada RichtTextBox tersebut bernilai 0. Nah, untuk mengaktifkan Horizontal RichtTextBox tersebut Anda cukup meng-assign sebuah nilai properties RightMargin ke angka yang sangat besar, berikut contoh kodenya:

Private Sub Command1_Click()
    RichTextBox1.RightMargin = 500000 'aktifkan horizontal scrollbar
End Sub

Demikian mengenai cara mengaktifkan horizontal scrollbar yang terdapat pada objek RichTextBox dalam bahasa pemrogaman VB6, semoga bermanfaat.

READ MORE - Mengaktifkan Horizontal ScrollBar Pada RichTextBox

Memperoleh Tag Sebuah File MP3 - VB6 Code

Option Explicit

Private Type eTagMP3
    TagIdent As String * 3
    Title As String * 30
    Artist As String * 30
    Album As String * 30
    Year As String * 4
    Comment As String * 30
End Type

Private TagMP3 As eTagMP3

Private Function GetMP3Tag(Path As String) As String()
    Dim fNum As Integer
    fNum = FreeFile
    Open Path For Binary As fNum
        Seek #fNum, LOF(fNum) - 127
        Get #fNum, , TagMP3.TagIdent
        If TagMP3.TagIdent = "TAG" Then
            Get #fNum, , TagMP3.Title
            Get #fNum, , TagMP3.Artist
            Get #fNum, , TagMP3.Album
            Get #fNum, , TagMP3.Year
            Get #fNum, , TagMP3.Comment
        End If
    Close #fNum
End Function


Private Sub Command1_Click()
    GetMP3Tag "C:\ase.mp3"
    MsgBox TagMP3.Comment
End Sub

READ MORE - Memperoleh Tag Sebuah File MP3 - VB6 Code

Class ListBox - Untuk Memilih Item Pada Saat Klik Kanan

Mengenai cara memilih item pada ListBox dengan klik kanan menggunakan VB6 - Seperti yang telah kita ketahui, sebuah ListBox hanya dapat dipilih itemnya melalui klik kiri, nah bagaimana jika kita ingin memilih item ListBox tersebut melalui klik kanan? Di bawah ini adalah class VB6 yang saya buat untuk klik kanan pada ListBox, penggunaan class di sini bertujuan hanya untuk menyederhanakan kerumitan/kekomplekan dalam pemrograman saja, jadi Anda dapat membuat kodenya pada module atau langsung pada formnya dengan sedikit modifikasi tentunya.

Option Explicit

Private WithEvents lst As ListBox

Private Type POINTAPI
   X As Long
   Y As Long
End Type

Private Const LB_ITEMFROMPOINT As Long = &H1A9

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long

Public Function LoWord(dwValue As Long) As Integer
  CopyMemory LoWord, dwValue, 2
End Function

Public Function MAKELONG(wLow As Long, wHigh As Long) As Long
  MAKELONG = LoWord(wLow) Or (&H10000 * LoWord(wHigh))
End Function

Public Function MAKELPARAM(wLow As Long, wHigh As Long) As Long
  MAKELPARAM = MAKELONG(wLow, wHigh)
End Function

Public Property Let ListBox(New_List As ListBox)
    Set lst = New_List
End Property

Private Sub lst_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   If Button = vbRightButton Then
      Dim lParam As Long
      Dim curritem As Long
      Dim r As Long
      Dim pt As POINTAPI
      Call GetCursorPos(pt)
      Call ScreenToClient(lst.hWnd, pt)
      lParam = MAKELPARAM(pt.X, pt.Y)
      r = SendMessage(lst.hWnd, LB_ITEMFROMPOINT, 0&, ByVal lParam)
      If r > -1 Then
         curritem = LoWord(r)
         lst.Selected(curritem) = True
      End If
   End If
End Sub

Demikian Class ListBox untuk memilih item melalui klik kanan pada VB6, semoga bermanfaat.

READ MORE - Class ListBox - Untuk Memilih Item Pada Saat Klik Kanan

Apa Yang Terjadi Jika dd/mm/yyyy dirubah menjadi mm/yyyy

Mengenai merubah format "dd/mm/yyyy" yang dirubah menjadi "mm/yyyy" dalam VB6 - Judul di atas sangat jelas, Apakah yang akan terjadi dengan sebuah tanggal yang memiliki format "dd/mm/yyyy" kemudian kita rubah formatnya menjadi "mm/yyyy" dalam pemrograman Visual Basic 6.0? pemahaman ini sangat penting terutama jika kita banyak berhubungan dengan pemrograman VB6 yang melibatkan banyak format tanggal, misalnya merancang aplikasi database.

Apabila kita menginput sebuah tanggal misalnya #12/06/2012# dalam format "dd/mm/yyyy" kemudian kita rubah dengan "mm/yyyy" sehingga menjadi #06/2012# apakah yang terjadi dengan tanggal 12? tanggal 12 akan kembali ke tanggal awal atau tanggal 01. Untuk membuktikannya coba Anda buat kode yang sangat sederhana seperti di bawah ini:

Option Explicit

Private Sub Command1_Click()
    Dim d As Date
    d = #23/12/2012#
    Dim s As String
    s = Format$(d, "mm/yyyy")
    MsgBox CDate(Format$(s, "dd/mm/yyyy"))
End Sub

Apakah artinya? banyak, mari kita buat logika pemrograman sederhana dengan menggunakan pengetahuan di atas. Contoh kasus sederhana: Diketahui tanggal #30/01/2012#, ditanyakan nama hari dari awal tanggal a.k.a #01/01/2012#? maka:

Option Explicit

Private Sub Command1_Click()
    Dim d As Date
    d = #23/12/2012#
    Dim s As String
    s = Format$(d, "mm/yyyy")
    MsgBox Format$(s, "dddd")
End Sub

Bukankah kode di atas akan menghasilkan Sabtu untuk tanggal #01/12/2012# dan Minggu untuk tanggal #23/12/2012#?

READ MORE - Apa Yang Terjadi Jika dd/mm/yyyy dirubah menjadi mm/yyyy

Memperoleh Jumlah Hari Dalam Tahun Tertentu

Private Function GetDaysInYear(d As Date) As Integer()
    Dim dt As Date, i As Integer, x(7) As Integer, c As Integer, g As Date
    g = CDate(Format$(d, "mm/yyyy"))
    c = IIf(Year(d) Mod 4 = 0, 366, 365)
    For dt = g To DateAdd("d", c - 1, g)
        x(Weekday(dt)) = x(Weekday(dt)) + 1
    Next
    GetDaysInYear = x
End Function

Private Sub Command2_Click()
    Dim d() As Integer
    d = GetDaysInYear(#2/22/2011#)
    MsgBox d(1) + d(2) + d(3) + d(4) + d(5) + d(6) + d(7)
End Sub

READ MORE - Memperoleh Jumlah Hari Dalam Tahun Tertentu

Memperoleh Jumlah Hari Dalam Selisih Tanggal Tertentu

Private Function GetDaysInRange(d As Date, f As Date) As Integer()
    Dim dt As Date, x(7) As Integer
    For dt = d To f
        x(Weekday(dt)) = x(Weekday(dt)) + 1
    Next
    GetDaysInRange = x
End Function

Private Sub Command1_Click()
    Dim d() As Integer
    d = GetDaysInRange(#2/1/2012#, #2/28/2012#)
    MsgBox d(1) + d(2)
End Sub

READ MORE - Memperoleh Jumlah Hari Dalam Selisih Tanggal Tertentu

Menampilkan Tanggal Lengkap Disertai Hari

Private Function DateFull(d As Date) As String
    DateFull = Format$(d, "dddd, dd/mm/yyyy")
End Function

Private Sub Command1_Click()
    MsgBox DateFull(#12/12/2012#)
End Sub

READ MORE - Menampilkan Tanggal Lengkap Disertai Hari

Apakah Tahun Tertentu Merupakan Tahun Kabisat?

Private Function IsLeapYear(d As Date) As String
    IsLeapYear = (Year(d) Mod 4 = 0)
End Function

Private Sub Command1_Click()
    MsgBox IsLeapYear(#12/12/2012#)
End Sub

READ MORE - Apakah Tahun Tertentu Merupakan Tahun Kabisat?

Menampilkan Dialog Regional Setting Menggunakan VB6

Private Sub Command1_Click()
    Call Shell("RunDLL32.exe  Shell32.dll Control_RunDLL InetCpl.cpl", vbNormalFocus)
End Sub

READ MORE - Menampilkan Dialog Regional Setting Menggunakan VB6

Memperoleh Jumlah Hari Dalam Bulan Tertentu

Private Function GetDaysInMonth(d As Date) As Integer()
    Dim dt As Date, i As Integer, x(7) As Integer, c As Integer, g As Date
    g = CDate(Format$(d, "mm/yyyy"))
    c = Day(DateSerial(Year(d), Month(d) + 1, 0))
    For dt = g To DateAdd("d", c - 1, g)
        x(Weekday(dt)) = x(Weekday(dt)) + 1
    Next
    GetDayInWeek = x
End Function

Private Sub Command2_Click()
    Dim d() As Integer
    d = GetDaysInMonth(#2/22/2012#)
    MsgBox d(1) + d(2)
End Sub

READ MORE - Memperoleh Jumlah Hari Dalam Bulan Tertentu

Google SERP Application 1.0 - SEO Tools For You Freeware

SEO utility ini saya namakan dengan nama Google SERP Application 1.0. Semoga bermanfaat.

Apakah Google SERP Application 1.0 itu?
Google SERP Application 1.0 adalah sebuah aplikasi/software yang dibuat menggunakan bahasa pemrograman Visual Basic 6.0. Google SERP Application 1.0 digunakan untuk mempermudah melihat peringkat situs atau blog dalam sebuah mesin pencari dengan menggunakan kata kunci tertentu.

Apakah Google SERP Application bersifat Freeware?
Ya, Google SERP Application 1.0 bersifat freeware, karena jika shareware kemungkinan besar tidak akan ada yang mau membelinya disebabkan tidak memenuhi standar software komersil, atau dalam bahasa yang lebih tepat, jujur serta vulgar, kata jelek mungkin lebih mewakili.

Bagaimana cara menggunakan Google SERP Application 1.0?
Download aplikasinya terlebih dahulu pada tautan di samping: Download Google SERP Application 1.0. Selanjutnya registrasikan dua komponen pendukungnya, yaitu: MSCOMCTL.OCX dan shdocvw.dll, buka Google SERP 1.0, maka akan muncul tampilan sebagai berikut:

Pada kotak sebelah kiri bagian atas, isi dengan nama alamat blog/situs Anda, contoh:

Kemudian pilih mesin pencari, jika Anda ingin melihat peringkat situs di Thailand maka pilih google.co.th, jika Anda ingin melihat peringkat situs di jerman maka pilih google.de, jika Anda ingin melihat peringkat situs di Indonesia maka cukup pilih google.co.id seperti biasanya. Maka tampilannya sekarang menjadi seperti ini:

Nah, selesai. Saatnya Anda mengisi kata kunci. Isi kata kunci pada kotak yang paling panjang, seperti pada gambar di bawah ini:


Kemudian klik tombol Go atau tekan Enter. tunggu beberapa saat untuk melihat hasilnya.

Bagaimana jika ingin menghasilkan pencarian yang lebih dari 10 pencarian?
Jika Anda ingin menghasilkan pencarian yang lebih dari 10, misalnya 11, 12, 13, 56, dan maksimalnya 100, maka yang pertama harus Anda lakukan adalah mengklik tombol preferences, seperti pada gambar di bawah ini:


Kemudian klik tombol simpan.. Selanjutnya scroll slide sesuai jumlah pencarian yang diinginkan, seperti gambar di bawah ini.


Mohon maaf atas tampilan awal aplikasi yang selalu menampilkan http://obat-nusantara.blogspot.com (anggap saja iklan atau dalam bahasa yang lebih baik lagi pariwara). Jika Anda kurang berkenan, maka saya sarankan untuk tidak menggunakan software ini.

Catatan Penting:
Jika ada bug/error Anda bisa mengirim email ke siapa saja... maksud saya ke alamat ini: obat[dot]nusantara[at]gmail[dot]com. Terima kasih atas kunjungannya, mohon maaf atas segala dosa dan semoga tidak mengganggu perjalanan Anda.

READ MORE - Google SERP Application 1.0 - SEO Tools For You Freeware

Software Kamus Bahasa Inggris 1.0 Open Source

Project kamus bahasa inggris open source ini seperti biasa dibuat menggunakan bahasa pemrogrman Visual Basic 6.0. Untuk kekurangan dan fitur tambahan bisa Anda perbaiki dan tambahkan pada source code di bawah ini.

Mengenai cara pembuatannya, telah dijelaskan pada bagian-bagian yang dipisahkan agar mudah mempelajarinya klik tautan ini untuk mempelajarinya.

Catatan:
Untuk menggunakannya, compile terlebih dahulu ke dalam file .EXE.

Download: Kamus Inggris Source Code
Download: Kamus Inggris Setup

READ MORE - Software Kamus Bahasa Inggris 1.0 Open Source

Alternate Color/Zebra Color Untuk Listview Codejock - VB6

Di bawahi ini merupakan module untuk memberi warna-warni (alternate color/zebra color) pada row listview codejock di bawah versi 15.x.x (versi yang belum mendukung property TextBackColor.

Option Explicit 
 
'--------------------------------------------------------------------------------------------- 
' http://khoiriyyah.blogspot.com 
' Module Alternate Color Listview Codejock untuk versi di bawah 15.x.x 
'--------------------------------------------------------------------------------------------- 
 
Private Const NOERROR = &H0& 
Private Const S_OK = &H0& 
Private Const S_FALSE = &H1& 
Private Const LVM_FIRST = &H1000 
Private Const LVM_SETBKIMAGE = (LVM_FIRST + 68) 
Private Const LVM_SETTEXTBKCOLOR = (LVM_FIRST + 38) 
Private Const LVBKIF_SOURCE_URL = &H2 
Private Const LVBKIF_SOURCE_HBITMAP As Long = &H1 
Private Const LVBKIF_STYLE_TILE = &H10 
Private Const CLR_NONE = &HFFFFFFFF 
 
Private Type LVBKIMAGE 
    ulFlags As Long 
    hbm As Long 
    pszImage As String 
    cchImageMax As Long 
    xOffsetPercent As Long 
    yOffsetPercent As Long 
End Type 
 
Private Declare Sub CoUninitialize Lib "OLE32.DLL" () 
Private Declare Function CoInitialize Lib "OLE32.DLL" (ByVal pvReserved As Long) As Long 
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
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 LVM_GETITEMRECT As Long = (LVM_FIRST + 14) 
Private Const LVIR_BOUNDS As Long = 0 
 
Private Type RECT 
    Left As Long 
    Top As Long 
    Right As Long 
    Bottom As Long 
End Type 
 
Public Const vbBackColor As Long = &HFCD5C2 
 
'//Ambil satu tinggi listitem codejock untuk dibuat acuan/referensi 
Private Function ListItemHeight(lvw As XtremeSuiteControls.ListView) As Long 
    Dim rc As RECT, i As Long, c As Long, dy As Long 
    c = lvw.ListItems.Count 
    If c = 0 Then Exit Function 
    rc.Left = LVIR_BOUNDS 
    SendMessage lvw.hWnd, LVM_GETITEMRECT, ByVal 0&, rc 
    dy = rc.Bottom - rc.Top 
    ListItemHeight = (dy * Screen.TwipsPerPixelY) 
End Function 
 
'//Bikin dummy picture dari tinggi item codejock yang telah diketahui dari fungsi di atas 
Public Sub SetLvCodeJockTextBKColor(Lv As XtremeSuiteControls.ListView, ByVal BackColorOne As OLE_COLOR, ByVal BackColorTwo As OLE_COLOR, Optional bGradient As Boolean) 
 
    Dim lH As Long 
    Dim lSM As Byte 
    Dim picAlt As PictureBox 
 
    With Lv 
        If .View = xtpListViewReport And .ListItems.Count Then 
            Set picAlt = Lv.Parent.Controls.Add("VB.PictureBox", "picAlt") 
            lSM = .Parent.ScaleMode 
            .Parent.ScaleMode = vbTwips 
            lH = ListItemHeight(Lv) '.ListItems(1).Height 
            With picAlt 
                .BackColor = BackColorOne 
                .AutoRedraw = True 
                .Height = lH * 2 
                .BorderStyle = 0 
                .Width = 10 * Screen.TwipsPerPixelX 
                If bGradient Then 
                    FadeVertical picAlt, vbWhite, BackColorTwo, lH, lH * 2 
                Else 
                    picAlt.Line (0, lH)-(.ScaleWidth, lH * 2), BackColorTwo, BF 
                End If 
            End With 
            picAlt.Visible = True 
            picAlt.ZOrder 
            Lv.Parent.ScaleMode = lSM 
        End If 
    End With 
 
    SavePicture picAlt.Image, App.Path & "\alternate_color.bmp" 
 
    Lv.Parent.Controls.Remove "picAlt" 
    Set picAlt = Nothing 
    SetBackground Lv 
 
End Sub 
 
'//Jadikan gambar dummy menjadi background listview secara tile (LVBKIF_STYLE_TILE) 
'//Coba hilangkan Constanta LVBKIF_STYLE_TILE, dan lihat apa yang terjadi 
Private Sub SetBackground(lvwTest As XtremeSuiteControls.ListView) 
    Dim sI As String 
    Dim lHDC As Long 
 
    sI = App.Path & "\alternate_color.bmp" 
 
    If (Len(sI) > 0) Then 
        If (InStr(sI, "")) = 0 Then 
            sI = App.Path & "" & sI 
        End If 
        On Error Resume Next 
        If (Dir(sI) <> "") Then 
            If (Err.Number = 0) Then 
                ' Set background - tile 
                Dim tLBI As LVBKIMAGE 
                tLBI.pszImage = sI & Chr$(0) 
                tLBI.cchImageMax = Len(sI) + 1 
                tLBI.ulFlags = LVBKIF_SOURCE_URL Or LVBKIF_STYLE_TILE 
                SendMessage lvwTest.hWnd, LVM_SETBKIMAGE, 0, tLBI 
                'jadikan transparan 
                SendMessageLong lvwTest.hWnd, LVM_SETTEXTBKCOLOR, 0, CLR_NONE 
            Else 
                MsgBox "Error with File '" & sI & "' :" & Err.Description & ".", vbExclamation 
            End If 
        Else 
            MsgBox "File '" & sI & "' not found.", vbExclamation 
        End If 
    End If 
 
End Sub 
 
'//Membuat warna gradient Start(R,G,B) to End (R,G,B) 
'//FadeVertical picAlt, 255, 255, 255, 266, 233, 216, 0, lH - 20 
Private Sub FadeVertical(ByVal pic As PictureBox, iColorStart As Long, iColorEnd As Long, ByVal start_y, ByVal end_y) 
    Dim start_r As Single, start_g As Single, start_b As Single 
    Dim end_r As Single, end_g As Single, end_b As Single 
    Dim hgt As Single 
    Dim wid As Single 
    Dim r As Single 
    Dim g As Single 
    Dim b As Single 
    Dim dr As Single 
    Dim dg As Single 
    Dim db As Single 
    Dim Y As Single 
    ColorCodeToRGB iColorEnd, end_r, end_g, end_b 
    ColorCodeToRGB iColorStart, start_r, start_g, start_b 
    wid = pic.ScaleWidth 
    hgt = end_y - start_y 
    dr = (end_r - start_r) / hgt 
    dg = (end_g - start_g) / hgt 
    db = (end_b - start_b) / hgt 
    r = start_r 
    g = start_g 
    b = start_b 
    For Y = start_y To end_y 
        pic.Line (0, Y)-(wid, Y), RGB(r, g, b) 
        r = r + dr 
        g = g + dg 
        b = b + db 
    Next Y 
End Sub 
 
Public Function ColorCodeToRGB(lColorCode As Long, iRed As Single, iGreen As Single, iBlue As Single) As Boolean 
    Dim lColor As Long 
    lColor = lColorCode      'work long 
    iRed = lColor Mod &H100  'get red component 
    lColor = lColor \ &H100  'divide 
    iGreen = lColor Mod &H100 'get green component 
    lColor = lColor \ &H100  'divide 
    iBlue = lColor Mod &H100 'get blue component 
    ColorCodeToRGB = True 
End Function 

Contoh penggunaan:

SetLvCodeJockTextBKColor lvSuppliers, vbWhite, vbBackColor, True 'True untuk gradient 

Contoh Source Code: http://www.i-bego.com/post32199.html#p32199

READ MORE - Alternate Color/Zebra Color Untuk Listview Codejock - VB6

Software Kamus Bahasa Inggriis Freeware 1.0

Ini merupakan aplikasi kamus bahasa inggris versi pertama, kosakatanya belum begitu banyak hanya ada sekitar 23 ribuan. Merupakan pengembangan dari cara membuat kamus bahasa inggris yang telah dijelaskan secara panjang lebar. Kelebihan dan kekurangannya bisa Anda lihat pada link tersebut.

Download: Kamus Bahasa Inggris Freeware 1.0

READ MORE - Software Kamus Bahasa Inggriis Freeware 1.0

ComboBox Class - Mempermudah Pembuatan Aplikasi VB6

Option Explicit 
 
Private WithEvents cbo As ComboBox 
Public AutoDropDown As Boolean 
 
Private Type POINTAPI 
    x As Long 
    y As Long 
End Type 
 
Private Type RECT 
    Left As Long 
    Top As Long 
    Right As Long 
    Bottom As Long 
End Type 
 
'API Declarations 
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long 
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long 
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 Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long 
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
 
'Contanta 
Private Const CB_GETITEMHEIGHT As Long = &H154 
Private Const CB_SHOWDROPDOWN As Long = &H14F 
Private Const CB_FINDSTRING = &H14C 
Private Const CB_SETDROPPEDWIDTH = &H160 
Private Const CB_FINDSTRINGEXACT As Long = &H158 
Private Const CB_SELECTSTRING As Long = &H14D 
 
Private Const EC_LEFTMARGIN = &H1 
Private Const EC_RIGHTMARGIN = &H2 
Private Const EC_USEFONTINFO = &HFFFF& 
Private Const EM_SETMARGINS = &HD3& 
Private Const EM_GETMARGINS = &HD4& 
 
Public Sub ChangeComboDropDownHeight(Optional ItemToDisplay As Integer = 10) 
 
    Dim pt As POINTAPI 
    Dim rc As RECT 
    Dim cWidth As Long 
    Dim newHeight As Long 
    Dim oldScaleMode As Long 
    Dim numItemsToDisplay As Long 
    Dim itemHeight As Long 
 
    numItemsToDisplay = ItemToDisplay 
 
    oldScaleMode = cbo.Parent.ScaleMode 
    cbo.Parent.ScaleMode = vbPixels 
    cWidth = cbo.Width 
 
    itemHeight = SendMessage(cbo.hwnd, CB_GETITEMHEIGHT, 0, ByVal 0) 
    newHeight = itemHeight * (numItemsToDisplay + 2) 
    Call GetWindowRect(cbo.hwnd, rc) 
 
    pt.x = rc.Left 
    pt.y = rc.Top 
 
    Call ScreenToClient(cbo.Parent.hwnd, pt) 
    Call MoveWindow(cbo.hwnd, pt.x, pt.y, cbo.Width, newHeight, True) 
    cbo.Parent.ScaleMode = oldScaleMode 
 
End Sub 
 
Public Property Let ComboBox(New_ComboBox As ComboBox) 
    Set cbo = New_ComboBox 
End Property 
 
Public Sub ShowDropDown() 
    If cbo.ListCount > 0 Then 
        SendMessage cbo.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0& 
    End If 
End Sub 
 
Private Sub cbo_GotFocus() 
    If Not AutoDropDown Then Exit Sub 
    Dim ret As Long 
    ret = SendMessage(cbo.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0&) 
End Sub 
 
Public Sub SetDropWidth(lngWidth As Long) 
    SendMessageLong cbo.hwnd, CB_SETDROPPEDWIDTH, lngWidth, 0 
End Sub 
 
Public Function GetEditHwnd() As Long 
    GetEditHwnd = FindWindowEx(cbo.hwnd, 0, "EDIT", vbNullString) 
End Function 
 
Public Function Find(FindText As String, Optional SetTopIndex As Boolean) As Boolean 
    Dim ret As Long 
    ret = SendMessage(cbo.hwnd, CB_FINDSTRING, -1, ByVal FindText) 
    If ret > -1 Then 
        Find = True 
        If SetTopIndex Then 
            cbo.TopIndex = ret 
            cbo.ListIndex = ret 
        Else 
            cbo.ListIndex = ret 
        End If 
    End If 
End Function 
 
Public Function FindExact(ByVal SearchString As String, Optional ByVal StartFrom As Long = -1) As Long 
    FindExact = SendMessage(cbo.hwnd, CB_FINDSTRINGEXACT, StartFrom, ByVal SearchString) 
End Function 
 
Public Function FindSelect(ByVal SearchString As String, Optional ByVal StartFrom As Long = -1) As Long 
    FindSelect = SendMessage(cbo.hwnd, CB_SELECTSTRING, StartFrom, ByVal SearchString) 
End Function 
 
Public Sub DisableScroll() 
    Call pUnSubClassCombo(cbo) 
    glPrevWndProcC = fSubClassCombo(cbo) 
End Sub 
 
Private Sub Class_Terminate() 
    Call pUnSubClassCombo(cbo) 
End Sub 

READ MORE - ComboBox Class - Mempermudah Pembuatan Aplikasi VB6

ComboBox SubClassing - Private Collections

Option Explicit 
 
 
Public glPrevWndProc As Long 
Public glPrevWndProcC As Long 
 
Private Const GWL_WNDPROC = (-4) 
Private Const WM_RBUTTONUP = &H205 
Private Const WM_RBUTTONDOWN = &H204 
Private Const WM_PARENTNOTIFY = &H210 
Private Const WM_MOUSEMOVE = &H200 
Private Const WM_MOUSEWHEEL As Long = &H20A 
 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
 
'ComboBox 
Public Sub pUnSubClassCombo(cbo As ComboBox) 
    Call SetWindowLong(cbo.hwnd, GWL_WNDPROC, glPrevWndProcC) 
End Sub 
 
Public Function pMyWindowProcC(ByVal hw As Long, ByVal uMsg As Long, _ 
    ByVal wParam As Long, ByVal lParam As Long) As Long 
    If uMsg = WM_PARENTNOTIFY And wParam = WM_RBUTTONDOWN Then 
'        Call frmMain.Text2_MouseUp(vbRightButton, 0, 0, 0) 
        Exit Function 
    ElseIf uMsg = WM_MOUSEWHEEL Then 
        Exit Function 
    End If 
    pMyWindowProcC = CallWindowProc(glPrevWndProcC, hw, uMsg, wParam, lParam) 
End Function 
 
Public Function fSubClassCombo(cbo As ComboBox) As Long 
    fSubClassCombo = SetWindowLong(cbo.hwnd, GWL_WNDPROC, AddressOf pMyWindowProcC) 
End Function 
 
'TextBox 
Public Function pMyWindowProc(ByVal hw As Long, ByVal uMsg As Long, _ 
    ByVal wParam As Long, ByVal lParam As Long) As Long 
    If uMsg = WM_RBUTTONUP Then 
'        Call frmMain.Text2_MouseUp(vbRightButton, 0, 0, 0) 
        Exit Function 
    End If 
    pMyWindowProc = CallWindowProc(glPrevWndProc, hw, uMsg, wParam, lParam) 
End Function 
 
Public Function fSubClass(txt As TextBox) As Long 
    fSubClass = SetWindowLong(txt.hwnd, GWL_WNDPROC, AddressOf pMyWindowProc) 
End Function 
 
Public Sub pUnSubClass(txt As TextBox) 
    Call SetWindowLong(txt.hwnd, GWL_WNDPROC, glPrevWndProc) 
End Sub 

READ MORE - ComboBox SubClassing - Private Collections

Memahami License Key Pada Pembuatan OCX - Bisnis OCX

Apabila kita membuat sebuah OCX maka, pada VB6 IDE yaitu pada project properties >> tab General, kita akan mendapati tulisan "Require License Key" (sebelah kiri bawah). Nah, pertanyaannya apa yang terjadi bila checkbox tersebut kita beri centang? Untuk menjawab pertanyaan di atas, sebaiknya Anda membuat sebuah project ocx sederhana kemudian mencentang checkbox bertuliskan "Require License Key" dan mengcompile project tersebut serta memperhatikan pengaruhnya. Apakah ada pengaruhnya? sepertinya atau lebih tepatnya seakan-akan tidak ada.

Perlu diketahui dengan dicentangnya tulisan "Require License Key" maka pada saat mengkompail OCX, VB6 akan secara otomatis membuat satu dari beberapa key baru pada registry, yaitu pada alamat: HKEY\CLASSES_ROOT\Licenses\{OCX GUID Anda}. secara bersamaan VB6 juga mengenerate file yang berektensi *.VBL (bisa Anda buka menggunakan Notepad untuk melihat isinya). Nah, key inilah yang membuat kita bisa menggunakannya pada saat DesignTime.

Untuk memahaminya lebih baik, saya membuat sebuah simulasi penjualan Shadow.OCX. Ikuti langkah-langkah berikut:

• Download terlebih dahulu Amazing Fade Effect - Shadow.OCX. Akan terdapat 3 file di dalamnya:


1. prjAmazingShadow.exe
2. Shadow.ocx
3. Install.bat


• Klik Install.bat untuk meregistrasikan komponen OCX.
• Klik prjAmazingShadow.exe untuk melihat demo shadow.ocx.

Langkah kedua:

• Buat project baru.
• Tambahkan komponen prjShadowCtl (Shadow.OCX).
• Tambahkan ucShadow (Shadow.OCX) ke dalam Form. Apakah Anda bisa melakukannya? tidak, yang ada hanyalah pesan error/pemberitahuan seperti pada gambar di bawah ini:

Keterangan:
Shadow.ocx dibuat oleh Paul Caton. Shadow.ocx merupakan sebuah komponen untuk membuat effect bayangan dan efek fade-in fade-out pada aplikasi, keunggulannya adalah Anda hanya perlu menempelkannya ke dalam Form dan selesai (tanpa membutuhkan kode). Memiliki beberapa properties yang bisa Anda atur untuk disesuaikan dengan selera Anda. Menggunakan teknik SubClassing aman yang diperkenalkan oleh Paul Caton.

READ MORE - Memahami License Key Pada Pembuatan OCX - Bisnis OCX

Membuat GUI Tanpa Terpengaruh Resolusi Screen - Tips dan Trik VB

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 - Membuat GUI Tanpa Terpengaruh Resolusi Screen - Tips dan Trik VB

Memasukan Gambar ke Dalam OCX - Teka-Teki VB6

Setelah teka-teki ShellContextMenu (untuk mengintegrasikan aplikasi dengan Windows Explorer), sekarang saya memiliki teka-teki sederhana yang lain, yakni mengenai cara memasukan gambar ke dalam .OCX (default VB atau third party).

Seperti yang kita ketahui, untuk membuat generator code yang baik salah satunya kita harus dapat memasukan gambar ke dalam .OCX yang kita butuhkan. Untuk .OCXnya saya menggunakan ImageList saja (bukan third party, pada dasarnya ia bisa digunakan untuk segala macam .OCX yang membutuhkan gambar).

Teka-tekinya sederhana, hanya memasukan gambar ke dalam objek ImageList, tentu Anda dapat memecahkannya. Apabila Anda menyukai teka-tekinya silakan download pada link di bawah ini:

Download: Teka-Teki Pemrograman VB6

READ MORE - Memasukan Gambar ke Dalam OCX - Teka-Teki VB6

Class TextBox - Untuk Mempermudah Pembuatan Aplikasi

<span style="color: #0000FF; text-decoration: underline; cursor: pointer;" onClick="toggleOverflowText('hiddenText2', this, 'Collapse Code...', 'Expand Code...', '300px');">Expand Code...</span> 
<pre class=codewhite id="hiddenText2" style="height: 300px";>Option Explicit 
 
'------------------------------------------------------------------------------- 
' ucTextBox (User Control TextBox for Database) 
' http://khoiriyyah.blogspot.com 
' -- Asep Hibban -- 
'------------------------------------------------------------------------------- 
 
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long 
 
Private Const EM_SETMARGINS = &HD3 
Private Const EC_LEFTMARGIN = &H1 
Private Const EC_RIGHTMARGIN = &H2
 
Private Type RECT 
    Left As Long 
    Top As Long 
    Right As Long 
    Bottom As Long 
End Type 
 
Private Type COMBOBOXINFO 
    cbSize As Long 
    rcItem As RECT 
    rcButton As RECT 
    stateButton  As Long 
    hwndCombo  As Long 
    hwndEdit  As Long 
    hwndList As Long 
End Type 
 
Private Const ECM_FIRST As Long = &H1500 
Private Const EM_SETCUEBANNER As Long = (ECM_FIRST + 1) 
 
Public Enum eTextConvertion 
    [GeneralConvertion] = 0 
    [UpperCase] = 1 
    [LowerCase] = 2 
    [ProperCase] = 3 
End Enum 
 
Public Enum eTextValidation 
    [GeneralValidation] = 0 
    [Alphabet] = 1 
    [AlphaNumeric] = 2 
    [Numeric] = 3 
End Enum 
 
Public Enum eAppearance 
    [Flat] = 0 
    [3D] = 1 
End Enum 
 
Public Enum eStyle 
    [Classic] = 0 
    [XP] = 1 
End Enum 
 
Public Enum eAlignment 
    [Left Justify] = 0 
    [Right Justify] = 1 
    [Center] = 2 
End Enum 
 
Public Enum eBorderStyle 
    [None] = 0 
    [Fixed Single] = 1 
End Enum 
 
Public Enum eDragMode 
    [Manual] = 0 
    [Automatic] = 1 
End Enum 
 
Public Enum eLinkMode 
    [None] = 0 
    [Automatic] = 1 
    [Manual] = 2 
    [Notify] = 3 
End Enum 
 
Public Enum eOLEDropMode 
    [None] = 0 
    [Manual] = 1 
    [Automatic] = 2 
End Enum 
 
Public Enum eOLEDragMode 
    [Manual] = 0 
    [Automatic] = 1 
End Enum 
 
Public Enum eScrollBars 
    [None] = 0 
    [Horizontal] = 1 
    [Vertical] = 2 
    [Both] = 3 
End Enum 
 
Public Enum eScaleMode 
    [User] = 0 
    [Twip] = 1 
    [Point] = 2 
    [Pixel] = 3 
    [Character] = 4 
    [Inch] = 5 
    [Millimeter] = 6 
    [Centimeter] = 7 
End Enum 
 
Public Enum eMousePointer 
    [Default] = 0 
    [arrow] = 1 
    [Cross] = 2 
    [i -Beam] = 3 
    [Icon] = 4 
    [Size] = 5 
    [Size NE SW] = 6 
    [Size N S] = 7 
    [Size NW SE] = 8 
    [Size W E] = 9 
    [Up arrow] = 10 
    [Hourglass] = 11 '(wait) 
    [No Drop] = 12 
    [Arrow and Hourglass] = 13 
    [Arrow and Question] = 14 
    [Size All] = 15 
    [Custom] = 99 
End Enum 
 
Public AutoSelection As Boolean 
Public AutoTab As Boolean 
Public TextConvertion As eTextConvertion 
Public TextValidation As eTextValidation 
Public AllowDecimal As Boolean 
Public Required As Boolean 
Public Information As Variant 
Private m_marginLeft As Integer 
Private m_marginRight As Integer 
Private m_CueBanner As String 
 
Event Click() 
Event DblClick() 
Event KeyDown(KeyCode As Integer, Shift As Integer) 
Event KeyPress(KeyAscii As Integer) 
Event KeyUp(KeyCode As Integer, Shift As Integer) 
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
 
Public Property Get BackColor() As OLE_COLOR 
    BackColor = Text1.BackColor 
End Property 
 
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR) 
    Text1.BackColor() = New_BackColor 
    PropertyChanged "BackColor" 
End Property 
 
Public Property Get ForeColor() As OLE_COLOR 
    ForeColor = Text1.ForeColor 
End Property 
 
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR) 
    Text1.ForeColor() = New_ForeColor 
    PropertyChanged "ForeColor" 
End Property 
 
Public Property Get Enabled() As Boolean 
    Enabled = Text1.Enabled 
End Property 
 
Public Property Let Enabled(ByVal New_Enabled As Boolean) 
    Text1.Enabled() = New_Enabled 
    PropertyChanged "Enabled" 
End Property 
 
Public Property Get Font() As Font 
    Set Font = Text1.Font 
End Property 
 
Public Property Set Font(ByVal New_Font As Font) 
    Set Text1.Font = New_Font 
    PropertyChanged "Font" 
End Property 
 
Public Property Get BorderStyle() As eBorderStyle 
    BorderStyle = Text1.BorderStyle 
End Property 
 
Public Property Let BorderStyle(ByVal New_BorderStyle As eBorderStyle) 
    Text1.BorderStyle() = New_BorderStyle 
    PropertyChanged "BorderStyle" 
End Property 
 
Public Sub Refresh() 
    Text1.Refresh 
End Sub 
 
Private Sub Text1_Click() 
    RaiseEvent Click 
End Sub 
 
Private Sub Text1_DblClick() 
    RaiseEvent DblClick 
End Sub 
 
Private Sub Text1_GotFocus() 
    On Error Resume Next 
    If AutoSelection Then 
        Text1.SelStart = 0 
        Text1.SelLength = Len(Text1.Text) 
    End If 
End Sub 
 
Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer) 
    RaiseEvent KeyDown(KeyCode, Shift) 
End Sub 
 
Private Sub Text1_KeyPress(KeyAscii As Integer) 
    Dim intSelStart As Integer 
    Dim strText As String 
 
    RaiseEvent KeyPress(KeyAscii) 
    If AutoTab Then 
        If KeyAscii = 13 Then SendKeys "{Tab}" 
    End If 
    If KeyAscii = 8 Then 
        Exit Sub 
    End If 
    Select Case TextConvertion 
        Case GeneralConvertion 
        Case UpperCase 
            KeyAscii = Asc(StrConv(Chr(KeyAscii), vbUpperCase)) 
        Case LowerCase 
            KeyAscii = Asc(StrConv(Chr(KeyAscii), vbLowerCase)) 
        Case ProperCase 
            intSelStart = Text1.SelStart 
            strText = Text1.Text 
            strText = StrConv(strText, vbProperCase) 
            Text1.Text = strText 
            If Text1.SelLength = Len(Text1.Text) Then 
                Text1.SelStart = Len(Text1.Text) 
            Else 
                Text1.SelStart = intSelStart 
            End If 
    End Select 
 
    If TextValidation = Numeric Then 
        Dim intDummyDecimalSymbol As Integer 
        strText = Text1.Text 'hanya untuk mempercepat & mencegah dari terjadinya flick 
        intDummyDecimalSymbol = IIf(InStr(1, strText, Chr(GetDecimalSymbol)) = 0, GetDecimalSymbol, 0) 
        If Not ((KeyAscii >= 48 And KeyAscii <= 57) Or _ 
        KeyAscii = 8 Or KeyAscii = 45 Or KeyAscii = intDummyDecimalSymbol) Then 
        KeyAscii = 0 
    End If 
    On Error Resume Next 
    Text1.Text = strText 
    Exit Sub 
End If 
 
Select Case TextValidation 
    Case Alphabet 
        If Not Chr(KeyAscii) Like "*[a-zA-Z]*" Then 
            KeyAscii = 0 
        End If 
    Case AlphaNumeric 
        If Not Chr(KeyAscii) Like "*[a-zA-Z0-9]*" Then 
            KeyAscii = 0 
        End If 
End Select 
 
End Sub 
 
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer) 
    RaiseEvent KeyUp(KeyCode, Shift) 
End Sub 
 
Private Sub Text1_LostFocus() 
    PropertyChanged "Text" 
End Sub 
 
Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    RaiseEvent MouseDown(Button, Shift, X, Y) 
End Sub 
 
Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    RaiseEvent MouseMove(Button, Shift, X, Y) 
End Sub 
 
Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    RaiseEvent MouseUp(Button, Shift, X, Y) 
End Sub 
 
Public Property Get Alignment() As eAlignment 
    Alignment = Text1.Alignment 
End Property 
 
Public Property Let Alignment(ByVal New_Alignment As eAlignment) 
    Text1.Alignment() = New_Alignment 
    PropertyChanged "Alignment" 
End Property 
 
Public Property Get Appearance() As eAppearance 
    Appearance = Text1.Appearance 
End Property 
 
Public Property Let Appearance(ByVal New_Appearance As eAppearance) 
    Text1.Appearance() = New_Appearance 
    PropertyChanged "Appearance" 
End Property 
 
Public Property Get CausesValidation() As Boolean 
    CausesValidation = Text1.CausesValidation 
End Property 
 
Public Property Let CausesValidation(ByVal New_CausesValidation As Boolean) 
    Text1.CausesValidation() = New_CausesValidation 
    PropertyChanged "CausesValidation" 
End Property 
 
Public Property Get HideSelection() As Boolean 
    HideSelection = Text1.HideSelection 
End Property 
 
Public Property Get LinkItem() As String 
    LinkItem = Text1.LinkItem 
End Property 
 
Public Property Let LinkItem(ByVal New_LinkItem As String) 
    Text1.LinkItem() = New_LinkItem 
    PropertyChanged "LinkItem" 
End Property 
 
Public Property Get LinkMode() As eLinkMode 
    LinkMode = Text1.LinkMode 
End Property 
 
Public Property Let LinkMode(ByVal New_LinkMode As eLinkMode) 
    Text1.LinkMode() = New_LinkMode 
    PropertyChanged "LinkMode" 
End Property 
 
Public Property Get LinkTimeout() As Integer 
    LinkTimeout = Text1.LinkTimeout 
End Property 
 
Public Property Let LinkTimeout(ByVal New_LinkTimeout As Integer) 
    Text1.LinkTimeout() = New_LinkTimeout 
    PropertyChanged "LinkTimeout" 
End Property 
 
Public Property Get LinkTopic() As String 
    LinkTopic = Text1.LinkTopic 
End Property 
 
Public Property Let LinkTopic(ByVal New_LinkTopic As String) 
    Text1.LinkTopic() = New_LinkTopic 
    PropertyChanged "LinkTopic" 
End Property 
 
Public Property Get Locked() As Boolean 
    Locked = Text1.Locked 
End Property 
 
Public Property Let Locked(ByVal New_Locked As Boolean) 
    Text1.Locked() = New_Locked 
    PropertyChanged "Locked" 
End Property 
 
Public Property Get MaxLength() As Long 
    MaxLength = Text1.MaxLength 
End Property 
 
Public Property Let MaxLength(ByVal New_MaxLength As Long) 
    Text1.MaxLength() = New_MaxLength 
    PropertyChanged "MaxLength" 
End Property 
 
Public Property Get MouseIcon() As Picture 
    Set MouseIcon = Text1.MouseIcon 
End Property 
 
Public Property Set MouseIcon(ByVal New_MouseIcon As Picture) 
    Set Text1.MouseIcon = New_MouseIcon 
    PropertyChanged "MouseIcon" 
End Property 
 
Public Property Get MousePointer() As eMousePointer 
    MousePointer = Text1.MousePointer 
End Property 
 
Public Property Let MousePointer(ByVal New_MousePointer As eMousePointer) 
    Text1.MousePointer() = New_MousePointer 
    PropertyChanged "MousePointer" 
End Property 
 
Public Property Get MultiLine() As Boolean 
    MultiLine = Text1.MultiLine 
End Property 
 
Public Property Get OLEDragMode() As eOLEDragMode 
    OLEDragMode = Text1.OLEDragMode 
End Property 
 
Public Property Let OLEDragMode(ByVal New_OLEDragMode As eOLEDragMode) 
    Text1.OLEDragMode() = New_OLEDragMode 
    PropertyChanged "OLEDragMode" 
End Property 
 
Public Property Get OLEDropMode() As eOLEDropMode 
    OLEDropMode = Text1.OLEDropMode 
End Property 
 
Public Property Let OLEDropMode(ByVal New_OLEDropMode As eOLEDropMode) 
    Text1.OLEDropMode() = New_OLEDropMode 
    PropertyChanged "OLEDropMode" 
End Property 
 
Public Property Get PasswordChar() As String 
    PasswordChar = Text1.PasswordChar 
End Property 
 
Public Property Let PasswordChar(ByVal New_PasswordChar As String) 
    Text1.PasswordChar() = New_PasswordChar 
    PropertyChanged "PasswordChar" 
End Property 
 
Public Property Get RightToLeft() As Boolean 
    RightToLeft = Text1.RightToLeft 
End Property 
 
Public Property Let RightToLeft(ByVal New_RightToLeft As Boolean) 
    Text1.RightToLeft() = New_RightToLeft 
    PropertyChanged "RightToLeft" 
End Property 
 
Public Property Get ScrollBars() As eScrollBars 
    ScrollBars = Text1.ScrollBars 
End Property 
 
Public Property Get SelLength() As Long 
    SelLength = Text1.SelLength 
End Property 
 
Public Property Let SelLength(ByVal New_SelLength As Long) 
    Text1.SelLength() = New_SelLength 
    PropertyChanged "SelLength" 
End Property 
 
Public Property Get SelStart() As Long 
    SelStart = Text1.SelStart 
End Property 
 
Public Property Let SelStart(ByVal New_SelStart As Long) 
    Text1.SelStart() = New_SelStart 
    PropertyChanged "SelStart" 
End Property 
 
Public Property Get SelText() As String 
    SelText = Text1.SelText 
End Property 
 
Public Property Let SelText(ByVal New_SelText As String) 
    Text1.SelText() = New_SelText 
    PropertyChanged "SelText" 
End Property 
 
Public Property Get Text() As String 
    Text = Text1.Text 
End Property 
 
Public Property Let Text(ByVal New_Text As String) 
    Text1.Text() = New_Text 
    PropertyChanged "Text" 
End Property 
 
Public Property Get WhatsThisHelpID() As Long 
    WhatsThisHelpID = Text1.WhatsThisHelpID 
End Property 
 
Public Property Let WhatsThisHelpID(ByVal New_WhatsThisHelpID As Long) 
    Text1.WhatsThisHelpID() = New_WhatsThisHelpID 
    PropertyChanged "WhatsThisHelpID" 
End Property 
 
Private Sub UserControl_Initialize() 
    AutoSelection = True 
    AutoTab = True 
    AllowDecimal = False 
End Sub 
 
Private Sub MoveTextBox() 
    Text1.Move 0, 0, ScaleWidth, ScaleHeight 
End Sub 
 
Private Sub UserControl_ReadProperties(PropBag As PropertyBag) 
    MoveTextBox 
    Text1.Text = PropBag.ReadProperty("Text", "Text1") 
    Text1.BackColor = PropBag.ReadProperty("BackColor", &H80000005) 
    Text1.ForeColor = PropBag.ReadProperty("ForeColor", &H80000008) 
    Text1.Enabled = PropBag.ReadProperty("Enabled", True) 
    Set Text1.Font = PropBag.ReadProperty("Font", Ambient.Font) 
    Text1.BorderStyle = PropBag.ReadProperty("BorderStyle", 1) 
    Text1.Alignment = PropBag.ReadProperty("Alignment", 0) 
    Text1.Appearance = PropBag.ReadProperty("Appearance", 1) 
    Text1.CausesValidation = PropBag.ReadProperty("CausesValidation", True) 
    Text1.LinkItem = PropBag.ReadProperty("LinkItem", "") 
    Text1.LinkMode = PropBag.ReadProperty("LinkMode", 0) 
    Text1.LinkTimeout = PropBag.ReadProperty("LinkTimeout", 50) 
    Text1.LinkTopic = PropBag.ReadProperty("LinkTopic", "") 
    Text1.Locked = PropBag.ReadProperty("Locked", False) 
    Text1.MaxLength = PropBag.ReadProperty("MaxLength", 0) 
    Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing) 
    Text1.MousePointer = PropBag.ReadProperty("MousePointer", 0) 
    Text1.OLEDragMode = PropBag.ReadProperty("OLEDragMode", 0) 
    Text1.OLEDropMode = PropBag.ReadProperty("OLEDropMode", 0) 
    Text1.PasswordChar = PropBag.ReadProperty("PasswordChar", "") 
    Text1.RightToLeft = PropBag.ReadProperty("RightToLeft", False) 
    Text1.SelLength = PropBag.ReadProperty("SelLength", 0) 
    Text1.SelStart = PropBag.ReadProperty("SelStart", 0) 
    Text1.SelText = PropBag.ReadProperty("SelText", "") 
    Text1.WhatsThisHelpID = PropBag.ReadProperty("WhatsThisHelpID", 0) 
    AutoSelection = PropBag.ReadProperty("AutoSelection", True) 
    AutoTab = PropBag.ReadProperty("AutoTab", True) 
    TextConvertion = PropBag.ReadProperty("TextConvertion", 0) 
    TextValidation = PropBag.ReadProperty("TextValidation", 0) 
    AllowDecimal = PropBag.ReadProperty("AllowDecimal", False) 
    Required = PropBag.ReadProperty("Required", True) 
    Information = PropBag.ReadProperty("Information", "") 
    m_marginLeft = PropBag.ReadProperty("MarginLeft", 0) 
    m_marginRight = PropBag.ReadProperty("MarginRight", 0) 
    m_CueBanner = PropBag.ReadProperty("CueBanner", "") 
    SetCueBanner Text1, m_CueBanner 
    SetMargin 
End Sub 
 
Private Sub UserControl_Resize() 
    MoveTextBox 
End Sub 
 
Private Sub UserControl_Show() 
    UserControl.Refresh 
    Text1.Refresh 
End Sub 
 
Private Sub UserControl_WriteProperties(PropBag As PropertyBag) 
    Call PropBag.WriteProperty("BackColor", Text1.BackColor, &H80000005) 
    Call PropBag.WriteProperty("ForeColor", Text1.ForeColor, &H80000008) 
    Call PropBag.WriteProperty("Enabled", Text1.Enabled, True) 
    Call PropBag.WriteProperty("Font", Text1.Font, Ambient.Font) 
    Call PropBag.WriteProperty("BorderStyle", Text1.BorderStyle, 1) 
    Call PropBag.WriteProperty("Alignment", Text1.Alignment, 0) 
    Call PropBag.WriteProperty("Appearance", Text1.Appearance, 1) 
    Call PropBag.WriteProperty("CausesValidation", Text1.CausesValidation, True) 
    Call PropBag.WriteProperty("LinkItem", Text1.LinkItem, "") 
    Call PropBag.WriteProperty("LinkMode", Text1.LinkMode, 0) 
    Call PropBag.WriteProperty("LinkTimeout", Text1.LinkTimeout, 50) 
    Call PropBag.WriteProperty("LinkTopic", Text1.LinkTopic, "") 
    Call PropBag.WriteProperty("Locked", Text1.Locked, False) 
    Call PropBag.WriteProperty("MaxLength", Text1.MaxLength, 0) 
    Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing) 
    Call PropBag.WriteProperty("MousePointer", Text1.MousePointer, 0) 
    Call PropBag.WriteProperty("OLEDragMode", Text1.OLEDragMode, 0) 
    Call PropBag.WriteProperty("OLEDropMode", Text1.OLEDropMode, 0) 
    Call PropBag.WriteProperty("PasswordChar", Text1.PasswordChar, "") 
    Call PropBag.WriteProperty("RightToLeft", Text1.RightToLeft, False) 
    Call PropBag.WriteProperty("SelLength", Text1.SelLength, 0) 
    Call PropBag.WriteProperty("SelStart", Text1.SelStart, 0) 
    Call PropBag.WriteProperty("SelText", Text1.SelText, "") 
    Call PropBag.WriteProperty("Text", Text1.Text, "") 
    Call PropBag.WriteProperty("WhatsThisHelpID", Text1.WhatsThisHelpID, 0) 
    Call PropBag.WriteProperty("AutoSelection", AutoSelection, True) 
    Call PropBag.WriteProperty("AutoTab", AutoTab, True) 
    Call PropBag.WriteProperty("TextConvertion", TextConvertion, 0) 
    Call PropBag.WriteProperty("TextValidation", TextValidation, 0) 
    Call PropBag.WriteProperty("Text", Text1.Text, "Text1") 
    Call PropBag.WriteProperty("AllowDecimal", AllowDecimal, False) 
    Call PropBag.WriteProperty("Required", Required, True) 
    Call PropBag.WriteProperty("Information", Information, "") 
    Call PropBag.WriteProperty("MarginLeft", m_marginLeft, 0) 
    Call PropBag.WriteProperty("MarginRight", m_marginRight, 0) 
    Call PropBag.WriteProperty("CueBanner", m_CueBanner, "") 
End Sub 
 
Private Sub Text1_Change() 
    PropertyChanged "Text" 
End Sub 
 
Public Function GetDecimalSymbol() As Integer 
    If AllowDecimal Then GetDecimalSymbol = Asc(Mid$(1 / 2, 2, 1)) 
End Function 
 
Public Property Get MarginLeft() As Integer 
    MarginLeft = m_marginLeft 
End Property 
 
Public Property Let MarginLeft(ByVal New_MarginLeft As Integer) 
    m_marginLeft = New_MarginLeft 
    PropertyChanged "MarginLeft" 
    SetMargin 
End Property 
 
Public Property Get MarginRight() As Integer 
    MarginRight = m_marginRight 
End Property 
 
Public Property Let MarginRight(ByVal New_MarginRight As Integer) 
    m_marginRight = New_MarginRight 
    PropertyChanged "MarginRight" 
    SetMargin 
End Property 
 
Private Sub SetMargin() 
    Dim long_value As Long 
    Dim s As String 
    long_value = m_marginRight * &H10000 + m_marginLeft 
    SendMessage Text1.hwnd, EM_SETMARGINS, EC_LEFTMARGIN Or EC_RIGHTMARGIN, long_value 
    s = Text1.Text 
    Text1.Text = "" 
    Text1.Text = s 
End Sub 
 
Public Property Get CueBanner() As String 
    CueBanner = m_CueBanner 
End Property 
 
Public Property Let CueBanner(ByVal New_CueBanner As String) 
    m_CueBanner = New_CueBanner 
    PropertyChanged "CueBanner" 
    SetCueBanner Text1, m_CueBanner 
End Property 
 
Private Sub SetCueBanner(obj As Object, str As String) 
    Dim s As String 
    s = StrConv(str, vbUnicode) 
    Call SendMessage(obj.hwnd, EM_SETCUEBANNER, 0&, ByVal s) 
End Sub  
 
 

READ MORE - Class TextBox - Untuk Mempermudah Pembuatan Aplikasi