Menonaktifkan Keyboard dan Mouse - BlockInput

Option Explicit 
 
Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long 
 
Private Sub Command1_Click() 
    Timer1.Enabled = True 
    BlockInput True 
End Sub 
 
'Gunakan kode di bawah, agar komputer Anda tidak usah di restart 
Private Sub Form_Load() 
    Timer1.Interval = 1000 '1 detik 
    Timer1.Enabled = False 
End Sub 
 
'Timer1.Interval = 1000 '1 detik 
Private Sub Timer1_Timer() 
    Static i As Integer 
    i = i + 1 
    If i > 5 Then 'tunggu 5 detik 
        BlockInput False 'aktifkan kembali keyboard dan mouse 
        i = 0 
    End If 
End Sub

READ MORE - Menonaktifkan Keyboard dan Mouse - BlockInput

Mouse Properties Dialog, Bagaimana Cara Menampilkannya?

Di bawah merupakan kode untuk menampilkan mouse properties dialog menggunakan VB6 (Visual Basic 6) - Bagaimana menampilkan mouse properties dialog ini, bisa Anda lihat di bawah:

Option Explicit 
 
Private Sub Command1_Click() 
    Dim dblReturn As Double 
    dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", 5) 
End Sub 

READ MORE - Mouse Properties Dialog, Bagaimana Cara Menampilkannya?

Cara Menampilkan Dialog Properties KeyBoard Menggunakan VB6

Berikut merupakan VB6 kode untuk menampilkan kotak dialog properties keyboard:

Option Explicit 
 
Private Sub Command1_Click() 
    Dim dblReturn As Double 
    dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", 5) 
End Sub 

READ MORE - Cara Menampilkan Dialog Properties KeyBoard Menggunakan VB6

Mengubah Format DOS 8.3 menjadi Long Filename

Mengubah format DOS 8.3 menjadi long filename, contohnya: G:\PROJEC~1\BILLIN~1\BILLIN~1\Client\CLIENT~1.EXE menjadi: G:\Project-ku\Billing Warnet\Billing Warnet\Client\Client Cafe.exe. Nah bagaimana kode konversi format DOS 8.3 ini, bisa Anda perhatikan di bawah:

Option Explicit 
 
Private Declare Function GetLongPathName Lib "kernel32" Alias "GetLongPathNameA" (ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal cchBuffer As Long) As Long 
 
Public Function GetLongPath(ByVal Filename As String) As String 
    On Error Resume Next 
    Dim length As Long 
    Dim s As String 
    s = String$(MAX_PATH, 0) 
    length = GetLongPathName(Filename, s, Len(s)) 
    If (length And Err = 0) Then GetLongPath = Left$(s, length) 
End Function 

Contoh penggunaan kode di atas:

Private Sub Command1_Click() 
    MsgBox GetLongPath("G:\PROJEC~1\BILLIN~1\BILLIN~1\Client\CLIENT~1.EXE") 
End Sub 

READ MORE - Mengubah Format DOS 8.3 menjadi Long Filename

GetShortPathName - Mengubah Filename Menjadi DOS 8.3 Format

Di bawah ini merupakan kode untuk mengubah nama file menjadi format DOS 8.3 - Contoh: G:\Project-ku\Billing Warnet\Billing Warnet\Client\Client Cafe.exe menjadi: G:\PROJEC~1\BILLIN~1\BILLIN~1\Client\CLIENT~1.EXE. Bagaimana kode mengenai cara mengubah filename menjadi DOS 8.3, bisa Anda lihat di bawah:

Option Explicit 
 
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long 
Const MAX_PATH = 260 
 
Public Function GetShortPath(ByVal Filename As String) As String 
    Dim length As Long 
    GetShortPath = Space(1024) 
    length = GetShortPathName(Filename, GetShortPath, Len(GetShortPath)) 
    GetShortPath = Left(GetShortPath, length) 
End Function 

Contoh penggunaan kode di atas:

Private Sub Command1_Click() 
    MsgBox GetShortPath("G:\Project-ku\Billing Warnet\Billing Warnet\Client\Client Cafe.exe") 
End Sub 

READ MORE - GetShortPathName - Mengubah Filename Menjadi DOS 8.3 Format

Notify Form Dengan Effect Transparent Hover

Menjelaskan mengenai cara membuat notify form yang menggunakan effect transparent hover - Apa yang dimaksud dengan notify form itu? notify form adalah form yang bertugas memberitahukan sesuatu kepada user, umumnya notify form muncul sebelah kanan bagian bawah. Beberapa software yang menggunakan notify form diantaranya: Mozilla Firefox, Orbit Downloader, IDM, Avira, software-software Anti Virus, dan banyak lagi. Untuk membuat notify form, khususnya yang memiliki effect transparent hover (terinspirasi dari software notepad++ pada dialog findnya), copy dan pastekan kode di bawah ini:

'---------------------------------------------------------------------------------------------------------- 
'http://khoiriyyah.blogspot.com 
'coder: Administrator 
'---------------------------------------------------------------------------------------------------------- 
Option Explicit 
 
Dim blnHighlighted As Boolean 
Dim blnMouseDownClick As Boolean 'bug fixed on flickering 
 
Private Type POINTAPI 
    X As Long 
    Y As Long 
End Type 
 
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long 
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long 
Private Declare Sub InitCommonControls Lib "COMCTL32.DLL" () 
 
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long 
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 SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal color As Long, ByVal X As Byte, ByVal alpha As Long) As Boolean 
 
Const LWA_BOTH = 3 
Const LWA_ALPHA = 2 
Const LWA_COLORKEY = 1 
Const GWL_EXSTYLE = -20 
Const WS_EX_LAYERED = &H80000 
 
Dim iTransparant As Integer 
Dim blnUp As Boolean 
 
Private Sub Form_Initialize() 
    InitCommonControls 
End Sub 
 
Private Sub MakeTransparan(hWndBro As Long, iTransp As Integer) 
   On Error Resume Next 
   
   Dim ret As Long 
   ret = GetWindowLong(hWndBro, GWL_EXSTYLE) 
   
   SetWindowLong hWndBro, GWL_EXSTYLE, ret Or WS_EX_LAYERED 
   SetLayeredWindowAttributes hWndBro, RGB(255, 255, 0), iTransp, LWA_ALPHA 
   Exit Sub 
 
End Sub 
 
Private Sub cmdOK_Click() 
    'Kode selanjutnya disini .... 
    blnUp = False 
    tmrNotify.Enabled = True 
End Sub 
 
Private Sub cmdCancel_Click() 
    'kode selanjutnya disini .... 
    blnUp = False 
    tmrNotify.Enabled = True 
End Sub 
 
Private Sub Form_Load() 
    MakeTransparan Me.hwnd, 100 
    Top = ((GetSystemMetrics(17) + GetSystemMetrics(4)) * Screen.TwipsPerPixelY) 
    Left = (GetSystemMetrics(16) * Screen.TwipsPerPixelX) - Width 
    blnUp = True 
End Sub 
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    blnMouseDownClick = True 
End Sub 
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    If blnHighlighted Then Exit Sub 
    blnHighlighted = True 
    tmrSemiTransparent.Enabled = True 
    MakeTransparan Me.hwnd, 255 
End Sub 
 
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    blnMouseDownClick = False 
End Sub 
 
Private Sub tmrSemiTransparent_Timer() 
    If blnMouseDownClick Then Exit Sub 
    Dim pt As POINTAPI 
    GetCursorPos pt 
    ScreenToClient hwnd, pt 
    If (pt.X < 0 Or pt.Y < 0) Or _ 
    (pt.X > (Me.ScaleLeft + Me.ScaleWidth) / Screen.TwipsPerPixelX) Or _ 
       (pt.Y > (Me.ScaleTop + Me.ScaleHeight) / Screen.TwipsPerPixelY) Then 
        blnHighlighted = False 
        tmrSemiTransparent.Enabled = False 
        MakeTransparan Me.hwnd, 100 
    End If 
End Sub 
 
Private Sub tmrNotify_Timer() 
    Const s = 100 
    Dim v As Single 
    v = (GetSystemMetrics(17) + GetSystemMetrics(4)) * Screen.TwipsPerPixelY 
    If blnUp = True Then 
        If Top - s <= v - Height Then 
            Top = Top - (Top - (v - Height)) 
            tmrNotify.Enabled = False 
        Else 
            Top = Top - s 
        End If 
    Else 
        Top = Top + s 
        If Top >= v Then End 
    End If 
End Sub

READ MORE - Notify Form Dengan Effect Transparent Hover

Memeriksa Apakah Pointer Mouse Masuk Di atas Sebuah Objek

Menjelaskan mengenai cara untuk memeriksa apakah pointer/cursor mouse berada di atas sebuah objek - Terkadang kita memerlukan sebuah kode untuk memeriksa apakah cursor atau pointer berada di atas sebuah objek, misalnya untuk keperluan hover, dsb. Untuk kasus objek yang memiliki property .hwnd hal tersebut mudah sekali dilakukan yaitu dengan memanggil fungsi API SetCapture dan ReleaseCapture, tapi bagaimana jika objek tersebut tidak memiliki property .hwnd, misalnya objek label atau image?

Di bawah ini merupakan module untuk memeriksa apakah pointer atau cursor berada di atas sebuah objek, untuk mengujinya sediakan 1 Timer dengan property Name = tmrInBox, kemudian 1 PictureBox dengan properpty Name = Picture1 (default).

'simpan kode di bawah pada sebuah module 
Option Explicit 
 
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long 
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 
 
Private Type POINTAPI 
    x As Long 
    y As Long 
End Type 
 
Public Function InBox(ctl As Control) As Boolean 
    Dim pt As POINTAPI 
    GetCursorPos pt 
    ScreenToClient ctl.Parent.hwnd, pt 
    InBox = Not (pt.x < ctl.Left Or pt.y < ctl.Top Or pt.x > ctl.Left + ctl.Width Or pt.y > ctl.Top + ctl.Height) 
End Function 

'simpan kode di bawah pada form 
Option Explicit 
 
Dim blnFlag As Boolean 
 
Private Sub Form_Load() 
    Form1.ScaleMode = vbPixels 'pixels units 
    tmrInBox.Interval = 10 'or 1 if posible 
End Sub 
 
Private Sub tmrInBox_Timer() 
    If Not InBox(Picture1) Then 
        blnFlag = False 
        tmrInBox.Enabled = False 
        Picture1.BackColor = vbBlack 
    End If 
End Sub 
 
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 
    If blnFlag Then Exit Sub 
    blnFlag = True 
    tmrInBox.Enabled = True 
    Picture1.BackColor = vbWhite 
End Sub 

READ MORE - Memeriksa Apakah Pointer Mouse Masuk Di atas Sebuah Objek

Mengenai cara menampilkan kotak dialog About

Mengenai cara menampilkan kotak dialog About default windows menggunakan Visual Basic 6 - Apabila kita malas membuat tampilan kotak dialog About, mungkin kode di bawah adalah alternatif yang tepat, selain itu ia memiliki tampilan (GUI) yang menarik, adapun cara menampilkan kotak dialog about default windows adalah sebagai berikut:

'simpan kode di bawah ini pada module 
Option Explicit 
 
Public Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long 
 
Public Sub ShowAboutDialog(hwnd As Long, Caption As String, Txt As String, Icon As Long) 
    Call ShellAbout(hwnd, Caption, Txt, Icon) 
End Sub 

Contoh penggunaan kode untuk menampilkan kotak dialog about:

'simpan kode di bawah ini dalam module 
Option Explicit 
 
Private Sub cmdAbout_Click() 
    ShowAboutDialog Me.hwnd, "About My-Sofware", "Software Versi ke-1", Me.Icon 
End Sub 

READ MORE - Mengenai cara menampilkan kotak dialog About

Membuat HyperLink Label Menggunakan Visual Basic 6

Mengenai cara membuat link label atau hyperlink label menggunakan VB6 - Link label atau hyperlink label merupakan label yang apabila diklik akan membuka browser dengan alamat website atau blog yang kita miliki. Bagaimana kode mengenai hiperlink label ini, berikut merupakan kode untuk membuat link label atau hyperlink label menggunakan Visual Basic 6:

'simpan kode ini pada module, atau satukan dengan form, jika ingin disatukan dengan form 
'gantilah Public menjadi Private 
Option Explicit 
 
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long 
Public Const SW_SHOW = 5 

contoh penggunaan fungsi API di atas:

'simpan kode ini pada form 
'gantilah label caption dengan alamat blog atau website 
Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    ShellExecute hwnd, "open", "http://khoiriyyah.blogspot.com", vbNullString, vbNullString, SW_SHOW 
End Sub 

Demikianlah mengenai cara pembuatan hyperlink label atau link label menggunakan Visual Basic 6. Selamat mencoba.

READ MORE - Membuat HyperLink Label Menggunakan Visual Basic 6

Cara Mengatasi Aplikasi Crash Akibat OCX Third Party

Bagaimana kita dapat mengatasi aplikasi yang menjadi crash pada saat keluar (exit) dari program akibat dari ocx yang dibuat oleh pihak ketiga (third party)? Penggunaan ocx yang kurang stabil (pada aplikasi yang telah dicompile/dijadikan exe), seringkali menyebabkan crash yaitu pada saat keluar dari aplikasi tersebut. Kondisi ini tentu saja sangat mengganggu, karena aplikasi, tidak akan pernah menjalankan kode-kode yang berada pada event Unload atau QueryUnload, seperti kode untuk mengatur settingan pada registry, settingan pada file .ini, dsb. Bagaimana cara mengatasi keadaan tersebut? ikuti langkah-langkah berikut:

• Tambahkan satu CommonDialog biarkan dengan nama default CommondDialog1
• Tambahkan satu UserControl biarkan dengan nama default UserControl1
• Biarkan CommonDialog dan UserControl tersebut tanpa ditambahkan kode.

Lakukan compile ulang, dan lihatlah hasilnya, dalam banyak kasus kondisi di atas bisa diatasi, tapi bila masih crash sebaiknya Anda mencari pengganti dari ocx tersebut.

READ MORE - Cara Mengatasi Aplikasi Crash Akibat OCX Third Party

Tips Menempatkan CommonDialog Pada Posisi Yang Diinginkan

Posting mengenai cara mudah menempatkan CommonDialog pada koordinat yang diinginkan - Dari beberapa common dialog yang terdapat pada COMDLG32.OCX, ada beberapa common dialog yang sulit untuk diatur posisinya, dalam arti ia selalu tampil pada sisi kiri bagian atas, mengapa demikian? karena sebelum tampil ia (COMDLG32.OCX) membaca terlebih dahulu koordinat yang diperoleh dari hwnd parentnya. Nah, untuk memposisikan commondialog pada saat tampil, ikuti langkah-langkah berikut:

1. Pada form tambahkan satu PictureBox jadikan property visible = false
2. Samakan ukurannya dengan COMDLG32.OCX (agar tidak menghabiskan space).
3. Masukan COMDLG32.OCX pada PictureBox tadi
4. Aturlah posisi PictureBox tadi pada koordinat tertentu

Sekarang CommonDialog akan selalu tampil mengikuti koordinat PictureBox yang menjadi parentnya. Untuk mengujinya (dengan mengikuti langkah di atas) buatlah kode seperti di bawah ini:

'kode di bawah simpan pada form 
'tambahkan CommandButton dengan nama default Command1 
'tambahkan CommonDialog dengan nama default CommonDialog1 
Option Explicit 
 
Private Sub Command1_Click() 
    CommonDialog1.ShowColor 
End Sub 

Selanjutnya jadikan property form WindowState = 2 - Maximize, bandingkan hasilnya sebelum dan sesudah menggunakan PictureBox. Demikian mengenai cara menempatkan CommonDialog pada posisi yang diinginkan. Semoga bermanfaat.

READ MORE - Tips Menempatkan CommonDialog Pada Posisi Yang Diinginkan

Cara Membuat Prosedure Generator Nama Secara Acak (Random)

Fungsi untuk membuat nama secara random (acak) - Di bawah ini merupakan prosedur yang digunakan untuk membuat nama secara acak, fungsi ini memiliki satu parameter untuk mengatur jumlah huruf yang akan digenerate, sedangkan nilai defaultnya adalah 4 huruf. Bagaimana fungsi generator nama secara acak atau random, bisa Anda lihat di bawah ini:

Option Explicit 
 
Private Function NamaAcak(Optional k As Integer = 4) As String 
    Dim s(1) As String, l As String 
    Randomize 
    s(0) = ("aiueo") 
    s(1) = ("bcdfghjklmnpqrstvwxyz") 
    For i = 1 To k 
        l = l & Mid(s(i Mod 2), Int((4 * Rnd) + 1), 1) 
    Next 
    NamaAcak = l 
End Function 

Contoh penggunaan fungsi di atas:

Private Sub Command1_Click() 
    MsgBox NamaAcak(10) 'menampilkan nama acak yang memiliki jumlah huruf 10 
    'sedangkan contoh di bawah akan mengenerate 20 nama acak 
    'dengan jumlah huruf 10 karakter 
    Dim i As Integer 
    List1.Clear 
    For i = 1 To 20 
        List1.AddItem NamaAcak(6) 
    Next 
End Sub 

Apakah kegunaan dari generator nama secara acak/random ini? saya juga tidak tahu, mungkin Anda tahu?

READ MORE - Cara Membuat Prosedure Generator Nama Secara Acak (Random)

Spoiler Kode Seperti Yang Terdapat pada Spoiler Wikipedia?

Mengenai cara membuat spoiler seperti yang terdapat pada Wikipedia. Untuk menjalankannya copy dan pastekan kode di bawah ini, selanjutnya gantilah Spoiler Title: dan Text Spoiler.

<div style="padding: 10px; border:1px solid #ccc;background:#f9f9f9"><div style="margin-bottom: 0px;font-family: arial;font-size:12px;"><b>Spoiler Title:</b><input value="Show" style="border:0px solid #000;margin:0px;color:#0000FF;font-family: arial; font-size: 12px; height:16; background:#f9f9f9" onclick="if (this.parentNode.parentNode.getElementsByTagName('div')[1].getElementsByTagName('div')[0].style.display != '') { this.parentNode.parentNode.getElementsByTagName('div')[1].getElementsByTagName('div')[0].style.display = ''; this.innerText = ''; this.value = 'Hide'; } else { this.parentNode.parentNode.getElementsByTagName('div')[1].getElementsByTagName('div')[0].style.display = 'none'; this.innerText = ''; this.value = 'Show'; }" type="button"> </div><div style="margin: 0 10px 0px 10px; padding: 0px; border: 0px inset #fff;"><div style='display:none'><br/>Text Spoiler</div></div></div>

Demo spoiler code ala Wikipedia:

Enhanced Pair-Bi:

'simpan kode di bawah pada Form 
Option Explicit 
'buatlah satu project dengan 1 Form, 1 CommandButton, 1 TextBox 
Private Sub Command1_Click() 
    Dim g As String 
    Dim i As Integer 
    Dim s() As String 
    Dim x As String 
    g = Text1.Text 
    g = RemoveEndCrlf(g) 
    If Trim(g) = "" Then Exit Sub 
    If InStr(1, g, "<b></b>") > 0 Then 
        g = Replace(g, "<b></b>", "") 
        Text1.Text = RemoveEndCrlf(g) 
        Exit Sub 
    Else 
        s = Split(g, vbCrLf) 
        For i = 0 To UBound(s) 
            x = x & "<b></b>" & s(i) & vbCrLf 
        Next 
    End If 
    Text1.Text = RemoveEndCrlf(x) 
End Sub 
 
'fungsi di bawah digunakan untuk menghilangkan karakter CRLF 
'yang terdapat pada akhir kode 
Private Function RemoveEndCrlf(s As String) 
    Dim str As String 
    str = s 
    If Right(str, 2) = vbCrLf Then 
        Do While Right(str, 2) = vbCrLf 
            str = Left(str, Len(str) - 2) 
        Loop 
    End If 
    RemoveEndCrlf = str 
End Function 

Selain menggunakan untuk text spoiler juga bisa digunakan untuk menampilkan dan menyembunyikan gambar.

Catatan Penting: kode-kode HTML/XML yang akan dijalankan (bukan tulisan [ seperti kode spoiler di atas]) harus dibuat satu baris, mengapa demikian?

READ MORE - Spoiler Kode Seperti Yang Terdapat pada Spoiler Wikipedia?

VB6 Code - Mengambil URL Dari Address Bar IE

Mengenai cara mengambil URL dari adress bar yang terdapat pada IE menggunakan fungsi API, dengan melakukan spy terhadap HWND induk dan turunannya. Selain dengan API di bawah ini, kita pun bisa mengambil URL yang terdapat pada adress bar IE atau Firefox dengan menggunakan DDE.

Option Explicit 
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) 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 WM_GETTEXT = &HD 
Private Const WM_GETTEXTLENGTH = &HE 
 
Private Sub FindIt(ByVal sClassName As String) 
On Error GoTo CallErrorA 
    lhWnd = FindWindowEx(lhWnd, 0, sClassName, vbNullString) 
End Sub 
Private Function GetAddressText() As String 
On Error GoTo CallErrorA 
    Dim usText() As Byte  
    Dim iPos As Integer 
    lhWnd = 0 
    Call FindIt("IEFrame") 
    Call FindIt("WorkerA") 
    Call FindIt("ReBarWindow32") 
    Call FindIt("ComboBoxEx32") 
    Call FindIt("ComboBox") 
    Call FindIt("Edit") 
    ReDim usText(0 To SendMessage(lhWnd, WM_GETTEXTLENGTH, 0, ByVal 0&) + 1)  
    If UBound(usText) = 1 Then 
        GetAddressText = "" 
    Else 
        usText(0) = UBound(usText) And 255 
        usText(1) = UBound(usText)  256 
        Call SendMessage(lhWnd, WM_GETTEXT, UBound(usText), usText(0)) 
        GetAddressText = StrConv(usText, vbUnicode) 
        iPos = InStr(GetAddressText, vbNullChar) 
        If iPos > 0 Then GetAddressText = Left(GetAddressText, iPos - 1) 
    End If 
End Function 

READ MORE - VB6 Code - Mengambil URL Dari Address Bar IE

Cara Membuat Direktori lebih dari 1 level - (Pengelolaan Fil

Fungsi yang menjelaskan mengenai cara membuat direktori lebih dari satu level, 2, 3 dan seterusnya - Mengenai kode membuat direktori lebih dari 1 level bisa Anda lihat di bawah ini:

Option Explicit 
 
Private Function CreateDir(strDir As String) As Boolean 
On Error Resume Next 
    Dim s() As String 
    s = Split(strDir, "\") 
    Dim i As Integer 
    For i = 1 To UBound(s) 
        s(0) = s(0) & "\" & s(i) 
        MkDir s(0) 
    Next 
End Function 
 
'contoh penggunaan fungsi di atas 
Private Sub Command1_Click() 
    CreateDir "C:\test1\test2\test3\test4 dan test5\test6\test7 dan test8" 
End Sub 

READ MORE - Cara Membuat Direktori lebih dari 1 level - (Pengelolaan Fil

Memahami Drag and Drop Dalam Visual Basic 6

Posting mengenai contoh operasi Drag and Drop menggunakan OLE pada VB6, Sebelum Anda mencoba kode drag and drop di bawah ini, settinglah property objek Picture1 OLEDropMode = 1 - Manual dan Property AutoSize = True.

Private Sub Picture1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)  
On Error GoTo ErrHandler  
    Picture1.Picture = LoadPicture(Data.Files(1)) 
   Exit Sub  
ErrHandler:  
    MsgBox "Error gambar tidak bisa diload" 
End Sub 

Untuk melihat cara kerjanya, bukalah Windows Explorer draglah satu file gambar yang terdapat pada Windows Explorer tersebut, selanjutnya drop tepat di atas object PictureBox.

READ MORE - Memahami Drag and Drop Dalam Visual Basic 6

VB6 Code - Compact And Repair Database MS Access

Di bawah ini merupakan fungsi untuk mengcompact dan merepair database Microsoft Access. Kegunaan Compact And Repair database untuk menghilangkan secara permanen data-data yang terhapus. Bagaimana Fungsi mengenai Compact And Repair Database MS Access.

Option Explicit 
 
Private Function CompactDB(Filename As String) As Boolean 
On Error GoTo ErrHandler 
 
    Dim DC As New DBEngine 
 
    Screen.MousePointer = vbHourglass 
    DC.CompactDatabase Filename, App.Path & "\~database.tmp" 
    Kill Filename 
    Name App.Path & "\~database.tmp" As Filename 
    Screen.MousePointer = vbDefault 
    CompactDB = True 
    Exit Function 
 
ErrHandler: 
 
    CompactDB = False 
 
End Function 

Contoh penggunaan Compact and Repair Database:

Private Sub Command1_Click() 
   MsgBox CompactDB(App.Path & "\database.mdb") 'true jika database sukses di compact dan repair 
End Sub

READ MORE - VB6 Code - Compact And Repair Database MS Access

Kode VB untuk Mencetak Sebuah Garis Ke Printer

Di bawah ini merupakan contoh sederhana untuk mencetak sebuah garis ke printer menggunakan Visual Basic 6, diharapkan Anda dapat mengembangkannya lebih lanjut, adapun kode untuk mencetak sebuah garis ke printer adalah sebagai berikut:

Private Sub PrintLine(LineWidth As Single) 
    Printer.Line (0, Printer.CurrentY)-(Printer.ScaleWidth, Printer.CurrentY + LineWidth), , BF 
    Printer.EndDoc 
End Sub 

Contoh penggunaan kode untuk mencetak garis ke printer:

Private Sub Command1_Click() 
    PrintLine (60) '60 adalah lebar garis 
End Sub 

READ MORE - Kode VB untuk Mencetak Sebuah Garis Ke Printer

Memeriksa Apakah Terdapat Printer Yang Terinstall - Visual B

Di bawah ini merupakan kode untuk memeriksa apakah komputer memiliki printer yang terinstall menggunakan Visual Basic 6, Adapun kode untuk memeriksa printer yang terinstall dalam komputer sebagai berikut:

Public Function IsPrinterInstalled() As Boolean 
    If VB.Printers.Count <= 0 Then
        IsPrinterInstalled = False
        Exit Sub
    Else
        IsPrinterInstalled = True
    End If
End Function 

Atau Anda pun dapat merubah juga kode di atas (agar lebih simple) seperti di bawah ini (hasilnya akan sama):

Public Function IsPrinterInstalled() As Boolean 
    IsPrinterInstalled = (VB.Printers.Count > 0)
End Function 

READ MORE - Memeriksa Apakah Terdapat Printer Yang Terinstall - Visual B

Menentukan Objek Font Yang Dikirimkan Ke Printer

Contoh sederhana untuk menentukan name, underline, bold, italic, size (properties objek font) yang dikirimkan ke sebuah printer. Adapun contohnya sebagai berikut:

Private Sub Command1_Click() 
    With Printer 
        .FontName = "Arial" 
        .FontUnderline = False 
        .FontBold = False
        .FontItalic = True
        .FontSize = "30"
        .Print "Ini contoh objek font dalam printer" 
        .EndDoc 
    End With 
End Sub 

READ MORE - Menentukan Objek Font Yang Dikirimkan Ke Printer

Membuat About Box Dengan Memanfaatkan Default Windows

Mengenai cara menampilkan kotak dialog About default windows menggunakan Visual Basic 6 - Apabila kita malas membuat tampilan kotak dialog About, mungkin kode di bawah adalah alternatif yang tepat, selain itu ia memiliki tampilan (GUI) yang menarik, adapun cara menampilkan kotak dialog about default windows adalah sebagai berikut:

'simpan kode di bawah ini dalam module 
Option Explicit 
 
Public Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long 
 
Public Sub ShowAboutDialog(hwnd As Long, Caption As String, Txt As String, Icon As Long) 
    Call ShellAbout(hwnd, Caption, Txt, Icon) 
End Sub 

Contoh penggunaan kode untuk menampilkan kotak dialog about:

Private Sub cmdAbout_Click() 
    ShowAboutDialog Me.hwnd, "About My-Sofware", "Software Versi ke-1", Me.Icon 
End Sub 

READ MORE - Membuat About Box Dengan Memanfaatkan Default Windows

Animasi Copy Seperti Di Windows Explorer

Option Explicit 
 
Private Const FO_COPY = &H2& 
Private Const FO_DELETE = &H3& 
Private Const FO_MOVE = &H1& 
Private Const FO_RENAME = &H4& 
Private Const FOF_ALLOWUNDO = &H40& 
Private Const FOF_CONFIRMMOUSE = &H2& 
Private Const FOF_CREATEPROGRESSDLG = &H0& 
Private Const FOF_FILESONLY = &H80& 
Private Const FOF_MULTIDESTFILES = &H1& 
Private Const FOF_NOCONFIRMATION = &H10& 
Private Const FOF_NOCONFIRMMKDIR = &H200& 
Private Const FOF_RENAMEONCOLLISION = &H8& 
Private Const FOF_SILENT = &H4& 
Private Const FOF_SIMPLEPROGRESS = &H100& 
Private Const FOF_WANTMAPPINGHANDLE = &H20& 
 
Private Type SHFILEOPSTRUCT 
    hwnd As Long 
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Long
    hNameMappings As Long
    lpszProgressTitle As String
End Type 
 
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long) 
Private Declare Function SHFileOperation Lib "Shell32.dll" Alias "SHFileOperationA" (lpFileOp As Any) As Long 
 
Private Sub cmdCopy_Click() 
    Dim result As Long 
    Dim lenFileop As Long
    Dim foBuf() As Byte
    Dim fileop As SHFILEOPSTRUCT
     
    lenFileop = LenB(fileop)
    ReDim foBuf(1 To lenFileop) 
     
    With fileop
        .hwnd = Me.hwnd 
        .wFunc = FO_COPY 
        .pFrom = App.Path & "\readme.html" & vbNullChar & App.Path & "\readme.doc" & vbNullChar & App.Path & "\readme.txt" & vbNullChar & vbNullChar 
        .pTo = "C:\" 
        .fFlags = FOF_CREATEPROGRESSDLG 
        .lpszProgressTitle = "VB HowTo Copy Example " & vbNullChar & vbNullChar 
    End With 
     
    Call CopyMemory(foBuf(1), fileop, lenFileop)
    Call CopyMemory(foBuf(19), foBuf(21), 12) 
     
    result = SHFileOperation(foBuf(1))
     
    If result <> 0 Then
        MsgBox Err.LastDllError
    Else 
        If fileop.fAnyOperationsAborted <> 0 Then
            MsgBox "Operation Failed"
        End If 
    End If
     
End Sub 

READ MORE - Animasi Copy Seperti Di Windows Explorer

Memutarkan huruf pada watermark, bagaimana caranya?

Mengenai cara memutarkan atau merotasi font pada watermark menggunakan VB6 (belajar Visual Basic 6 untuk pemula) - Posting ini merupakan kelanjutan dari posting yang telah ditulis terdahulu. Disini kita akan menambahkan beberapa kemampuan pada project watermark yang sedang kita buat. Perhatikan kode di bawah ini:

'--------------------------------------------------------------------------------------- 
' http://khoiriyyah.blogspot.com 
' coder: Administrator 
'--------------------------------------------------------------------------------------- 
Option Explicit 
 
Private Declare Sub InitCommonControls Lib "comctl32.dll" () 
 
Dim intCurrentX As Integer 'variabel untuk menyimpan koordinat X 
Dim intCurrentY As Integer 'variabel untuk menyimpan koordinat Y 
 
Private Sub Command1_Click() 
    'memanggil prosedur RotateFont 
    RotateFont Picture1, Val(txtSize), txtFontName, intCurrentX, intCurrentY, Val(txtDegree), txtWatermark 
    'menyimpan hasil gambar yang telah diberi teks 
    SavePicture Picture1.Image, App.Path & "\watermark_sample.bmp" 'and save  Exit Sub 
End Sub 
 
Private Sub Form_Initialize() 
    InitCommonControls 'XP style 
End Sub 
 
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 
    Label3 = "X: " & x 'menampilkan koordinat X ke dalam label 
    Label4 = "Y: " & y 'menampilkan koordinat Y ke dalam label 
    intCurrentX = x 'simpan koordinat x dalam variabel intCurrentX 
    intCurrentY = y 'simpan koordinat y dalam variabel intCurrentY 
    WaterMarkIt 'panggil prosedur WaterMarkIt 
End Sub 
 
Private Sub txtDegree_Change() 
    'apabila bukan angka, jadikan txtDegree.Text = 90 
  If Not IsNumeric(txtDegree.Text) Then txtDegree.Text = "90" 
End Sub 
 
Private Sub VScroll1_Scroll() 
    'panggil prosedur WaterMarkIt pada saat terjadi Scroll 
    WaterMarkIt 
End Sub 
 
Private Sub VScroll1_Change() 
    'panggil prosedur WaterMarkIt pada saat terjadi perubahan nilai 
    WaterMarkIt 
End Sub 
 
Private Sub VScroll2_Change() 
    WaterMarkIt 'panggil prosedur WaterMarkIt 
End Sub 
 
Private Sub VScroll2_Scroll() 
    WaterMarkIt 'panggil prosedur WaterMarkIt 
End Sub 
'-------------------------------------------------------------------- 
' Prosedur WaterMarkIt 
'-------------------------------------------------------------------- 
Private Sub WaterMarkIt() 
    Command1_Click 'panggil Command1_Click (Rotasi dan simpan image) 
    txtDegree.Text = VScroll1.Value 'txtDegree berdasarkan nilai VScroll1 
    txtSize.Text = VScroll2.Value 'txtSize berdasarkan nilai VScroll2 
End Sub 

Download Project

READ MORE - Memutarkan huruf pada watermark, bagaimana caranya?

Membuat Spoiler Pada Blog di Blogspot

Menjelaskan cara membuat spoiler pada blog khususnya di blogspot/blogger - Untuk membuat spoiler pada blog copy dan pastekan kode di bawah ini:

<div style="margin: 5px 10px 10px;"> <div class="smallfont" style="margin-bottom: 1px;"> <b> <strong>Judul</strong> </b> <br /> <input onclick="if (this.parentNode.parentNode.getElementsByTagName('div')[1].getElementsByTagName('div')[0].style.display != '') { this.parentNode.parentNode.getElementsByTagName('div')[1].getElementsByTagName('div')[0].style.display = ''; this.innerText = ''; this.value = 'Hide'; } else { this.parentNode.parentNode.getElementsByTagName('div')[1].getElementsByTagName('div')[0].style.display = 'none'; this.innerText = ''; this.value = 'Show'; }" style="font-size: 10px; margin: 0px; padding: 0px; width: 70px;" type="button" value="Show" /> </div> <br /> <div class="alt2" style="border: 1px inset; margin: 0px; padding: 6px;"> <div style="display: none;"> <strong>Text spoiler yang akan ditampilkan</strong> </div> </div> </div>

Maka dari kode di atas, hasil yang ditampilkan adalah seperti di bawah ini:

Judul

Text spoiler yang akan ditampilkan

Rubahlah judul dan text spoilernya untuk disesuaikan dengan kebutuhan.

Catatan: Kode di atas harus di buat satu baris.

READ MORE - Membuat Spoiler Pada Blog di Blogspot

Rotasi Font Menggunakan Visual Basic 6.0

Modul untuk memutarkan atau merotasi font berdasarkan derajat tertentu serta koordinat tertentu menggunakan VB6 - Bagaimana kode serta contoh penggunaannya, bisa Anda lihat di bawah ini:

Option Explicit 
 
Public Type LOGFONT 
  lfHeight As Long 
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte
  lfUnderline As Byte
  lfStrikeOut As Byte
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
  lfFacename As String * 33
End Type 
 
Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long 
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long 
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long 
 
Public Sub RotateFont(pic As PictureBox, fontsize As Integer, fontname As String, x As Integer, y As Integer, degree As Integer, txt As String) 
         
    On Error GoTo ErrHandler
     
    Dim F As LOGFONT
    Dim hPrevFont As Long 
    Dim hFont As Long
    pic.Cls
 
    F.lfEscapement = 10 * Val(degree)
    F.lfFacename = fontname 
    F.lfHeight = (fontsize * -20) / Screen.TwipsPerPixelY 
    pic.fontname = "Arial Black" + Chr$(0) 
    hFont = CreateFontIndirect(F) 
    hPrevFont = SelectObject(pic.hdc, hFont) 
 
    pic.CurrentX = x
    pic.CurrentY = y
    pic.Print txt
     
    hFont = SelectObject(pic.hdc, hPrevFont)
    DeleteObject hFont 
    Exit Sub 
    
ErrHandler: 
 
    MsgBox Err.Description
     
End Sub 

Modul di atas memiliki 7 parameter, Adapun contoh penggunaannya sebagai berikut:

Private Sub Command1_Click() 
    RotateFont Picture1, 12, "Arial", 90, 2500, _ 
    40, "khoiriyyah.blogspot.com" 
'Keterangan: 
'    1. Picture1 = PictureBox 
'    2. 12 = ukuran huruf 
'    3. Arial = nama huruf 
'    4. 90 = koordinat X 
'    5. 2500 = koordinat Y 
'    6. 40 = derajat putaran (0 derajat = normal, 90 derajat = tegak lurus) 
'    7. khoiriyyah.blogspot.com = text yang dimasukan ke dalam PictureBox 
End Sub 

READ MORE - Rotasi Font Menggunakan Visual Basic 6.0

Menentukan Titik Koordinat Text Pada Watermark | VB6

Artikel yang menjelaskan cara menempatkan text (watermark) berdasarkan titik koordinat, posting ini merupakan kelanjutan dari posting sebelumnya mengenai dasar-dasar membuat software watermark (Belajar Visual Basic 6 untuk pemula melalui praktik). Selanjutnya agar text watermark dapat ditempatkan sesuai keinginan, maka kita harus menentukan titik koordinatnya terlebih dahulu. Adapun kode lengkap untuk menentukan titik koordinat text watermark adalah sebagai berikut:

'--------------------------------------------------------------------------------------- 
' http://khoiriyyah.blogspot.com 
' coder: Administrator 
'--------------------------------------------------------------------------------------- 
Option Explicit 

Dim intCurrentX As Integer 'variabel untuk menyimpan koordinat X 
Dim intCurrentY As Integer 'variabel untuk menyimpan koordinat Y 
 
Private Sub Command1_Click() 
    Picture1.Cls 'bersihkan Picture1 dari seluruh text 
    Picture1.CurrentX = intCurrentX 'ambil nilai X dari variabel di atas 
    Picture1.CurrentY = intCurrentY 'ambil nilai Y dari variabel di atas 
    Picture1.Print "http://khoiriyyah.blogspot.com" 'beri watermark! 
    SavePicture Picture1.Image, App.Path & "\watermark_sample.bmp" 'jadikan file dan simpan. 
End Sub 

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    intCurrentX = X 'masukan nilai X pada variabel berdasarkan koordinat klik mouse 
    intCurrentY = Y 'masukan nilai Y pada variabel berdasarkan koordinat klik mouse 
End Sub 

Dengan menggunakan kode di atas, maka kita dapat menentukan titik koordinat text watermark seperti pada gambar berikut:

Download Project

READ MORE - Menentukan Titik Koordinat Text Pada Watermark | VB6

Menonaktifkan/Disable Task Manager Menggunakan VB6

Posting yang menjelaskan mengenai cara menonaktifkan task manager melalui kode Visual Basic 6.0 - Mendisable atau menonaktifkan task manager terkadang diperlukan untuk pembuatan aplikasi-aplikasi tertentu sebut saja billing warnet. Umumnya kode yang digunakan untuk menonaktifkan task manager dengan mengubah nilai registry, namun berbeda dengan kode di bawah ini yang mendisable task manager tanpa mengubah nilai registry. Bagaimana implementasi kode untuk mendisable task manager, bisa Anda lihat di bawah ini:

'simpan kode di bawah pada module 
Option Explicit 

Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 

Private Type NOTIFYICONDATA 
    cbSize As Long 
    hWnd As Long
    uId As Long
    uFlags As Long
    ucallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type 

Private Const NIM_DELETE = &H2 
 
Public Function DisableTaskManager() 
    Dim tskWin As Long, t As NOTIFYICONDATA 
    Shell "taskmgr.exe", vbHide 
    Do Until tskWin <> 0 
        tskWin = FindWindow("#32770", "Windows Task Manager") 
    Loop 
    t.hWnd = tskWin
    Shell_NotifyIcon NIM_DELETE, t 
End Function 

Contoh penggunaan kode di atas:

Option Explicit 'simpan kode ini pada form 
 
Private Sub Form_Load() 
    DisableTaskManager 
End Sub 

READ MORE - Menonaktifkan/Disable Task Manager Menggunakan VB6

VB6 Code - 2 Baris Kode Inti Membuat Software Watermark

Apakah gambar yang diberi watermark itu? mengapa gambar diberi watermark? mengenai hal ini, saya percaya Anda (blogger) lebih tahu jawabannya. Posting kali ini kita akan membahas tentang project VB6 step by step tentang pembuatan software watermark. Dalam membuat software, tentu kita harus dapat membedakan mana yang menjadi kode inti (primer) mana yang menjadi kode tambahan (sekunder). Dengan demikian, maka kita akan dengan mudah mengatur, memelihara, menambah, mengurangi, menghilangkan, mengupdate, software tersebut. Kode inti merupakan kode utama pembentuk software. Sedangkan kode tambahan (sekunder) kode-kode yang melengkapi kode primer tadi, sehingga bisa disebut: plug-ins, add-ons, add-ins, fasilitas, tambahan, pelengkap, penyempurna, dan seluruh kata yang setara dengan itu. Umumnya dengan kode-kode sekunder tadi maka sebuah software akan memiliki versi-versi, versi 1.0, versi 1.0.1, versi 1.0.2 dan seterusnya, lengkap dengan history, bug fixed, kekurangan, serta kelebihannya. Disini saya memiliki contoh yang baik mengenai hal yang telah dijelaskan di atas, yaitu mengenai pembuatan software watermark. Kode intinya hanya 2 baris saja. Berikut kode inti dari software watermark tersebut:

'--------------------------------------------------------------------------------------- 
' http://khoiriyyah.blogspot.com 
' coder: Administrator 
'--------------------------------------------------------------------------------------- 
Option Explicit 
 
Private Sub Command1_Click() 
    Picture1.Print "http://khoiriyyah.blogspot.com" 'watermark! 
    SavePicture Picture1.Image, App.Path & "\watermark_sample.bmp" 'and save 
End Sub 

dan hasilnya (walaupun harus menggunakan yang lain untuk mengkonversi dari bmp ke jpg):

contoh gambar yang sudah diberi watermark

Untuk selanjutnya (To Do):

1. Mencari/membuat class, module, ocx, dll untuk merubah ke format lain (gif, jpg, jpeg, png, dsb)
2. Rotasi huruf
3. Memindahkan huruf berdasarkan koordinat
4. dsb saja (terlalu banyak untuk dituliskan).

[Download Project]

READ MORE - VB6 Code - 2 Baris Kode Inti Membuat Software Watermark

VB Code - Membuat Sound Beep ala Anti Virus AVIRA

Mengenai cara membuat suara beep seperti yang terdapat pada antivirus Avira menggunakan VB6 Code - Pada saat mendeteksi sebuah virus/malware, biasanya anti virus Avira akan mengeluarkan suara yang khas melalui internal speaker. Nah, di bawah ini merupakan cara membuat sound beep ala Avira dengan memanggil fungsi API Beep yang terdapat pada liblary Kernel32. Cobalah untuk mengkalibrasi frekuensi serta durasinya!

Option Explicit 

Private Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long 

Private Sub AvirasBeep() 
    Beep 1500, 100 'frekuensi 1500khz, durasi 100 milidetik 
    Beep 2000, 80 'frekuensi 2000khz, durasi 80 milidetik 
    Beep 3200, 70 'frekuensi 3200khz, durasi 70 milidetik 
End Sub 

Private Sub Command1_Click() 
    AvirasBeep 
End Sub 

READ MORE - VB Code - Membuat Sound Beep ala Anti Virus AVIRA

VB6 Code - Menghilangkan Tombol Max-Min Pada Saat Runtime

Mengenai cara menghilangkan tombol max dan tombol min yang terdapat pada sebelah kanan atas sebuah form - Seperti yang kita tahu bahwa pada form sebelah kanan bagian atas terdapat 3 tombol, yaitu: tombol max, tombol min, dan tombol close. Nah pada kesempatan kali ini kita akan menyembunyikan seluruh tombol menggunakan fungsi API, adapun kodenya adalah sebagai berikut:

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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long 
  
Const WS_MINIMIZEBOX = &H20000 
Const WS_MAXIMIZEBOX = &H10000 
Const GWL_STYLE = (-16) 
Const WS_SYSMENU = &H80000 
 
Private Sub Form_Load() 
    Dim l As Long 
    l = GetWindowLong(Me.hwnd, GWL_STYLE) 
    l = (l And Not WS_SYSMENU) 
    l = SetWindowLong(Me.hwnd, GWL_STYLE, l) 
End Sub 

READ MORE - VB6 Code - Menghilangkan Tombol Max-Min Pada Saat Runtime

VB6 Code - Form SDI, Cara Menonaktifkan Tombol Close

Sebelumnya telah diposting mengenai cara mendisable tombol close pada MDI form, nah sekarang mengenai cara menonaktifkan tombol close yang terdapat pada control box SDI form menggunakan VB6 code. Di bawah ini merupakan kode untuk menghilangkan tombol close atau button X yang terdapat pada SDI form.

Option Explicit 
 
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long 
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long 
 
Private Const MF_BYPOSITION = &H400& 
 
Public Sub RemoveButtonX(frm As Form) 
    Dim hSysMenu As Long 
    hSysMenu = GetSystemMenu(frm.hWnd, 0)
    Call RemoveMenu(hSysMenu, 6, MF_BYPOSITION) 
    Call RemoveMenu(hSysMenu, 5, MF_BYPOSITION) 
End Sub 

Contoh penggunaan kode di atas.

Option Explicit 
 
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) 
    Cancel = -1 'untuk mendisable Alt + F4 </i> 
End Sub 
 
Private Sub Form_Load() 
    RemoveButtonX Me 
End Sub 

READ MORE - VB6 Code - Form SDI, Cara Menonaktifkan Tombol Close

VB6 Code - Disable Button X atau Tombol Close Pada MDI

Kode untuk mendisable button x atau tombol close pada MDI form - Di bawah ini merupakan cara menghilangkan button 'x' atau tombol close pada MDI Form.

'simpan kode di bawah pada module 
Option Explicit  

Private Declare Function DeleteMenu Lib "user32" ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long  
Private Declare Function GetSystemMenu Lib "user32" ByVal hwnd As Long, ByVal bRevert As Long) As Long  

Private Const MF_BYPOSITION = &H400&  
 
Dim hMenu As Long  

Public Sub RemoveMenus(frm As Form, Optional brestore As Boolean, Optional bmove As Boolean, Optional bsize As Boolean, Optional bminimize As Boolean, Optional bmaximize As Boolean, Optional bseperator As Boolean, Optional bclose As Boolean)  
    hMenu = GetSystemMenu(frm.hwnd, False)  
    If bclose Then DeleteMenu hMenu, 6, MF_BYPOSITION  
    If bseperator Then DeleteMenu hMenu, 5, MF_BYPOSITION  
    If bmaximize Then DeleteMenu hMenu, 4, MF_BYPOSITION  
    If bminimize Then DeleteMenu hMenu, 3, MF_BYPOSITION  
    If bsize Then DeleteMenu hMenu, 2, MF_BYPOSITION  
    If bmove Then DeleteMenu hMenu, 1, MF_BYPOSITION  
    If brestore Then DeleteMenu hMenu, 0, MF_BYPOSITION  
End Sub  

Contoh penggunaan kode di atas:

'simpan kode di bawah pada MDI Form.  
Option Explicit  

Private Sub MDIForm_Load()  
   'nilai true untuk remove, sesuaikan kodenya! 
   RemoveMenus Me, , , , , , True, True 
End Sub  

READ MORE - VB6 Code - Disable Button X atau Tombol Close Pada MDI

VB6 Code - Cara Menampilkan ToolTipText Pada ListBox

Mengenai cara menampilkan ToolTipText pada saat pointer mouse bergerak di atas ListItem ListBox menggunakan VB6 Code. Adapun cara menampilkan ToolTipText pada ListBox adalah sebagai berikut:

Option Explicit 
 
Private Type POINTAPI 
    x As Long 
    Y As Long
End Type 
 
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long 
Private Declare Function LBItemFromPt Lib "COMCTL32.DLL" (ByVal hLB As Long, ByVal ptX As Long, ByVal ptY As Long, ByVal bAutoScroll As Long) As Long 
Private Declare Function SendMessageByNum Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
 
Private WithEvents lst As ListBox 
Private Const LB_SETHORIZONTALEXTENT = &H194 
 
Public Property Let List(New_List As ListBox) 
    Set lst = New_List 
End Property 
     
Private Sub lst_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single) 
    '    lst.ListIndex = ItemUnderMouse(lst.hwnd, X, Y) 
    Dim l As Long 
    Dim a As Long
    a = lst.Parent.TextWidth(lst.List(ItemUnderMouse(lst.hwnd, x, Y))) / Screen.TwipsPerPixelX
    l = lst.Parent.TextWidth("AAAAAAAAAAAAAAAAAAAAAAA") / Screen.TwipsPerPixelX 
    If a > l Then 
        If lst.ToolTipText <> lst.List(ItemUnderMouse(lst.hwnd, x, Y)) Then
            lst.ToolTipText = lst.List(ItemUnderMouse(lst.hwnd, x, Y))
        End If 
    Else
        lst.ToolTipText = ""
    End If 
End Sub 
     
' Return the index of the item under the mouse. 
Public Function ItemUnderMouse(ByVal list_hWnd As Long, ByVal x As Single, ByVal Y As Single) 
    Dim pt As POINTAPI 
    pt.x = x \ Screen.TwipsPerPixelX 
    pt.Y = Y \ Screen.TwipsPerPixelY 
    ClientToScreen list_hWnd, pt 
    ItemUnderMouse = LBItemFromPt(list_hWnd, pt.x, pt.Y, False)
End Function 

READ MORE - VB6 Code - Cara Menampilkan ToolTipText Pada ListBox

VB6 Code - Mengisi ListBox Atau ComboBox Dengan File

Mengenai cara mengisi ListBox atau ComboBox dengan seluruh isi file menggunakan VB6 Code. Adapun cara mengisi ListBox atau ComboBox dengan isi seluruh file adalah sebagai berikut: 

Public Sub LoadFileToComboOrList(FileName As String, obj As Object) 
    Dim s As String 
    Dim InFile As Integer   ' Descriptor for file. 
    InFile = FreeFile 
    Open FileName For Input As InFile 
        While Not EOF(InFile) 
            Line Input #InFile, s 
            obj.AddItem s 
        Wend 
    Close InFile 
End Sub 

READ MORE - VB6 Code - Mengisi ListBox Atau ComboBox Dengan File

VB6 Code - Fungsi Untuk Baca Tulis File .INI

Mengenai fungsi untuk baca tulis file .INI menggunakan VB6 Code - Adapun prosedure VB6 untuk baca tulis file .INI adalah sebagai berikut:

Option Explicit 
 
Private Declare Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long 
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long 
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias   "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long 
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long 
 
Public Function ReadIni(ByVal strSection As String, ByVal strKey As String, ByVal strDefault As String, ByVal strFileName As String) As String 
    Dim intRes As Integer, strRet As String 
    strRet = Space$(32400) 
    intRes = GetPrivateProfileString(strSection, strKey, strDefault, strRet, Len(strRet), strFileName) 
    ReadIni = Left$(strRet, intRes) 
End Function 
 
Public Sub WriteIni(ByVal strSection As String, ByVal strKey As String, ByVal strSetting As Variant, ByVal strFileName As String) 
    WritePrivateProfileString strSection,   strKey, CStr(strSetting), strFileName 
End Sub 
 
Public Function ReadWinIni(strSection As String, strKey As String) As String 
    Dim Result As String * 128 
    Dim Temp As Integer 
    Temp = GetProfileString(strSection, strKey, "", Result, Len(Result)) 
    ReadWinIni = Left$(Result, Temp) 
End Function 
 
Public Sub WriteWinIni(strSection As String, strKey As String, strSetting As String) 
    WriteProfileString strSection, strKey,   strSetting 
End Sub 

Contoh penggunaan kode di atas:

Private Sub Command1_Click() 
    If Combo1.ListIndex < 0 Then 
        MsgBox "You must select the combo first!" 
        Exit Sub 
    End If 
    WriteIni "EXE", "EXE", Combo1.ListIndex, App.Path & "\windows.ini" 
    MsgBox "Run Again and look the change!" 
    Unload Me 
End Sub 
 
Private Sub Form_Load() 
    Me.WindowState = ReadIni("EXE", "EXE", 0, App.Path & "\windows.ini") 
    With Combo1 
        .AddItem "Normal" 
        .AddItem "Minimized" 
        .AddItem "Maximized" 
    End With 
End Sub 

READ MORE - VB6 Code - Fungsi Untuk Baca Tulis File .INI

VB6.0 - Code Generator: Add OCX Add DLL Programmatically

Yang dimaksud kode generator disini adalah sebuah aplikasi yang digunakan untuk membuat sebuah project. Adapun tujuan utamanya ialah untuk menghemat waktu, tenaga, dan biaya sedangkan tujuan lainnya yang tidak kalah penting adalah kecepatan. Kode generator sangat baik sekali digunakan untuk pembuatan aplikasi-aplikasi database, karena aplikasi database hampir memliki kode-kode yang sama (insert-update-delete-dsb) hanya objeknya saja yang berbeda. Maka jika kita ingin membuat belasan aplikasi database dengan objek yang berbeda, pembuatan kode generator dengan rancangan yang baik sungguh sangat layak untuk dipertimbangkan. Sebagai contoh Anda dapat mendownload kode generator yang kurang baik atau tepatnya tidak baik disini. Walaupun kurang baik, tapi coba perhatikan apakah keistimewaanya.

Membuat aplikasi kode generator yang baik, tentunya harus memiliki kemampuan menambahkan sembarang OCX dan referensi DLL yang support VB6.0. Bagaimanakah caranya? Di bawah ini merupakan potongan dari kode generator tersebut, gunanya untuk menambahkan referensi DLL dan OCX.

'------------------------------------------------------------------------------- 
'        http://khoiriyyah.blogspot.com 
'        Administrator 
'------------------------------------------------------------------------------- 
 
Public VBInstance As VBIDE.VBE 
Public Connect As Connect 
 
Option Explicit 
 
Public Function InsertOCX(ProgID As String) As Boolean 
On Error GoTo ErrHandler 
    'Add OCX 
      VBInstance.ActiveVBProject.AddToolboxProgID ProgID 
    InsertOCX = True 
    Exit Function 
ErrHandler: 
    InsertOCX = False 
End Function 
 
Public Function InsertReferences(GUID As String, Mayor As Long, Minor As Long) As Boolean 
On Error GoTo ErrHandler 
    'Add dll references 
    VBInstance.ActiveVBProject.References.AddFromGuid GUID, Mayor, Minor 
    InsertReferences = True 
ErrHandler: 
    InsertReferences = False 
End Function 
 
Private Sub Command1_Click() 
    'Add ListView to VB6 project 
    InsertOCX "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}" 
    'Add TreeView 
    InsertOCX "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}" 
    'Add MSFlexGrid 
    InsertOCX "{0ECD9B60-23AA-11D0-B351-00A0C9055D8E}" 
End Sub 
 
Private Sub Command2_Click() 
    'Add scrun.dll Microsoft Scripting Runtime) 
    InsertReferences "{420B2830-E718-11CF-893D-00A0C9054228}", 1#, 0 
    'Add msado15.dll Microsoft ActiveX Data Objects 2.8 Library)   
    InsertReferences "{2A75196C-D9EB-4129-B803-931327F72D5C}", 2, 8 
End Sub 

Adapun cara menggunakan kode di atas telah saya bahas disini dan disini. Semoga bermanfaat.

READ MORE - VB6.0 - Code Generator: Add OCX Add DLL Programmatically

Fungsi Personal Editor HTML Ordering List [OL]

Ini merupakan fungsi yang digunakan untuk membuat personal editor. Tag yang akan kita modifikasi adalah tag OL (Ordering List).

Option Explicit 
 
Function OL(strText As String) As String 
    Dim sText As String 
    Dim aText() As String 
    Dim i As Integer 
    sText = strText 
    aText = Split(sText, vbCrLf) 
    For i = LBound(aText) To UBound(aText) 
        Select Case i 
        Case LBound(aText) 
            sText = "<ol>" &   "<li>" & aText(i) & "</li>" & vbCrLf 
        Case UBound(aText) 
            sText = sText & "<li>" & aText(i) & "</li>" & "</ol>" 
        Case Else 
            sText = sText & "<li>" & aText(i) & "</li>" & vbCrLf 
        End Select 
    Next 
    OL = sText 
End Function 

Cara penggunaan Fungsi Personal Editor HTML Ordering List <OL>

Private Sub Command1_Click() 
    Text1.SelText =   OL(Text1.SelText) 
End Sub 

READ MORE - Fungsi Personal Editor HTML Ordering List [OL]

Fungsi Personal Editor HTML Unordering List [UL]

Ini merupakan fungsi yang digunakan untuk membuat personal editor. Tag yang akan kita modifikasi adalah tag UL (Unordering List).

Option Explicit 
 
Function UL(strText As String) As String 
    Dim sText As String 
    Dim aText() As String 
    Dim i As Integer 
    sText = strText 
    aText = Split(sText, vbCrLf) 
    For i = LBound(aText) To UBound(aText) 
        Select Case i 
        Case LBound(aText) 
            sText = "<ul>" &   "<li>" & aText(i) & "</li>" & vbCrLf 
        Case UBound(aText) 
            sText = sText & "<li>" & aText(i) & "</li>" & "</ul>" 
        Case Else 
            sText = sText & "<li>" & aText(i) & "</li>" & vbCrLf 
        End Select 
    Next 
    UL = sText 
End Function 

Cara penggunaan Fungsi Personal Editor HTML Unordering List <UL>

Private Sub Command1_Click() 
    Text1.SelText =   UL(Text1.SelText) 
End Sub 
 

READ MORE - Fungsi Personal Editor HTML Unordering List [UL]

Menghapus Spasi Yang Tidak Diperlukan (Spasi Rangkap)

Option Explicit 
 
Private Function DelJunkSpace(str As String) As String 
    Do While (InStr(str, "  ") > 0) 
        str = Replace(str, "  ", " ") 
    Loop 
    DelJunkSpace = str 
End Function 

Private Sub Form_Load() 
    Dim str As String 
    str = "Asep         Hibban        http://4basic-vb.blogspot.com" 
    'return = "Asep Hibban http://4basic-vb.blogspot.com" 
    Text1.Text = str 
End Sub 

READ MORE - Menghapus Spasi Yang Tidak Diperlukan (Spasi Rangkap)

VB6 Code - Meng-copy Array Secara Cepat

Private Declare Sub CopyMemory Lib "kernel32" _ 
Alias "RtlMoveMemory" (Dest As Any, _ 
Source As Any, ByVal Length As Long) 
 
Private Sub CopyArray() 
    Dim lngbytes As Long 
    Dim lngSrc(1 To 600000) As Long 
    Dim lngDest(1 To 600000) As Long 
    ' 
    ' Number of bytes equals number of array 
    ' elements times the element length. 
    ' 
    lngbytes = (UBound(lngSrc) - LBound(lngSrc) + 1) * Len(lngSrc(1)) 
    ' 
    ' Copy the array passing the address of the start to 
    ' the destination and source arrays and the length 
    ' of the arrays. 
    ' 
    Call CopyMemory(lngDest(LBound(lngDest)), lngSrc(LBound(lngSrc)), lngbytes) 
End Sub 

READ MORE - VB6 Code - Meng-copy Array Secara Cepat