Tuesday, May 29, 2012

Fungsi Format RTF Untuk Pembuatan Kamus Bahasa Inggris

Di bawah ini merupakan contoh format RTF untuk keperluan pembuatan kamus Bahasa Inggris. Fungsi di bawah ini dapat bekerja dengan sangat cepat? mengapa? karena ia tidak memformat tulisan pada objeknya secara langsung akan tetapi, memformat string yang terdapat dalam memori kemudian mem-feed-nya kembali ke dalam objek RichTextBox.

Bukankah:

Private Sub Command1_Click() 
    Dim i As Integer 
    For i = 1 To 1000 
        Text1.Text = Text1.Text & "contoh tulisan" & vbCrLf 
    Next 
End Sub

Berbeda dengan kode di bawah ini:

Private Sub Command1_Click() 
    Dim i As Integer 
    Dim sText   As String 
    sText = Text1.Text 
    For i = 1 To 1000 
        sText = sText & "contoh tulisan" & vbCrLf 
    Next 
    Text1.Text = sText 
End Sub

Sepintas dua kode di atas akan memberikan hasil yang sama akan tetapi berbeda jauh dalam segi kecepatan.

Di bawah ini merupakan fungsi format RTF untuk pembuatan kamus bahasa inggris:

Option Explicit 
 
Public Function FormatSentence(sSentence As String) As String 
    Dim sFormat As String 
    Dim sKosakata   As String 
    Dim sText As String 
    Dim i As Integer 
    sFormat = "{\rtf1\fbidis\ansi\ansicpg1256\deff0\deflang1025{\fonttbl{\f0\fswiss\fcharset0 Arial;}}" & vbCrLf & _ 
    "{\colortbl ;\red128\green0\blue0;\red0\green0\blue255;\red0\green128\blue128;\red0\green0\blue128;\red255\green0\blue0;\red128\green0\blue128;}" & vbCrLf & _ 
    "{\*\generator Msftedit 5.41.15.1512;}\viewkind4\uc1\pard\ltrpar\lang1033\f0\fs17" 
    sKosakata = sSentence 
    sText = " " & Text1.Text 
    sText = Replace(sText, vbCrLf, " \Par"   & vbCrLf) 
    sText = Replace(sText, " kb. ", " \cf2\b kb. \cf0\b0 ") 
    sText = Replace(sText, " -kki. ", " \cf5\b kki. \cf0\b0 ") 
    sText = Replace(sText, " kk. ", " \cf1\b kk. \cf0\b0 ") 
    sText = Replace(sText, " ks. ", " \cf3\b ks. \cf0\b0 ") 
    sText = Replace(sText, " -ks. ", " \cf3\b -ks. \cf0\b0 ") 
    sText = Replace(sText, " -kkt. ", " \cf5\b -kkt. \cf0\b0 ") 
    sText =   Replace(sText, "(", "\cf5(\cf0 ") 
    sText = Replace(sText, ")", "\cf5)\cf0 ") 
    For i = 1 To 100 
        If InStr(1, sText, i) Then 
            sText = Replace(sText, " " & i & " ", " \b " & i & " \cf0\b0 ") 
        End If 
    Next 
    sText = Replace(sText, " -kkt. ", " \cf5\b -kkt. \cf0\b0 ") 
    sText = Replace(sText, " ks. ", " \cf3\b ks. \cf0\b0 ") 
    sText = sFormat & "\b " & sKosakata & "\b0 " & sText & "\par" & vbCrLf & "}" 
    FormatSentence = sText 
End Function 
 
Private Sub Form_Load() 
    RTF.BackColor = RGB(241, 243, 241) 
End Sub

Contoh penggunaan fungsi di atas:

Private Sub Command1_Click() 
    RTF.TextRTF = FormatSentence(Text2.Text) 
End Sub

Maka hasilnya seperti gambar di bawah ini:

Catatan:
Fungsi di atas hanyalah sekadar contoh, Anda dapat memodifikasinya untuk disesuaikan dengan kebutuhan.

Download: Source code fungsi format RTF untuk Kamus Bahasa Inggris

Menggunakan Fonts Tanpa Menginstalnya

Di bawah ini merupakan kode untuk menggunakan fonts tanpa harus menginstalnya.

Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" ByVal lpFileName As String) As Long 
Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" ByVal lpFileName As String) As Long 
 
Public Function AddFontToResource(Filename As String) 
    Dim lFont As Long 
    lFont = RemoveFontResource(Filename) 
End Function 
 
Public Function RemoveFontFromResource(Filename As String) 
    Dim lFont As Long 
    lFont = AddFontResource(Filename) 
End Function

Contoh penggunaan fungsi di atas:

Private Sub Form_Load() 
    AddFontResource App.Path & "\Fonts\Trado.ttf" 
    Text1.FontName = "Traditional Arabic" 
End Sub

Mendapatkan Special Folder Menggunakan Visual Basic 6.0

Public Enum SpecialFolderIDs 
    sfidDESKTOP = &H0 
    sfidPROGRAMS = &H2 
    sfidPERSONAL = &H5 
    sfidFAVORITES = &H6 
    sfidSTARTUP = &H7 
    sfidRECENT = &H8 
    sfidSENDTO = &H9 
    sfidSTARTMENU = &HB 
    sfidDESKTOPDIRECTORY = &H10 
      sfidNETHOOD = &H13 
    sfidFONTS = &H14 
    sfidTEMPLATES = &H15 
    sfidCOMMON_STARTMENU = &H16 
    sfidCOMMON_PROGRAMS = &H17 
    sfidCOMMON_STARTUP = &H18 
    sfidCOMMON_DESKTOPDIRECTORY = &H19 
    sfidAPPDATA = &H1A 
    sfidPRINTHOOD = &H1B 
    sfidProgramFiles = &H10000 
    sfidCommonFiles = &H10001 
End Enum 
 
Public Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As SpecialFolderIDs, ByRef pIdl As Long) As Long 
Public Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pIdl As Long, ByVal pszPath As String) As Long 
 
Public Const NOERROR = 0 
    Dim sPath   As String 
    Dim IDL     As Long 
    Dim strPath As String 
    Dim lngPos As Long 
 
    ' Fill the item id list with the pointer of each folder item, rtns 0 on success 
    If SHGetSpecialFolderLocation(0, sfidPROGRAMS, IDL) = NOERROR Then 
        sPath = String$(255, 0) 
        SHGetPathFromIDListA IDL, sPath 
 
        lngPos = InStr(sPath, Chr&(0)) 
        If lngPos > 0 Then 
            strPath = Left$(sPath, lngPos - 1) 
        End If 
 
    End If

Menguji Kecepatan Sebuah Form Ketika Diload

Di bawah ini merupakan fungsi untuk menguji kecepatan load sebuah form. Berbicara mengenai uji menguji kecepatan, maka fungsi API yang digunakan umumnya GetTickCount yang terdapat dalam core dll windows yakni Kernel32.dll. Selain untuk menguji kecepatan form, kode di bawah ini bisa Anda modifikasi untuk keperluan lain, misalnya menguji kecepatan sebuah fungsi/kode dan lain-lain. Ide pembuatan fungsi ini kami dapatkan dari o-om.com, terima kasih.

Option Explicit 
 
Private Declare Function GetTickCount Lib "kernel32" () As Long 
 
Public Function FormTestSpeed(frm As Form) As Long 
    Dim lSpeedTime As Long 
    Dim SInfoSpeed As String 
    lSpeedTime = GetTickCount   
    Unload frm 
    Load frm 
    frm.Show 
    lSpeedTime = GetTickCount - lSpeedTime 
    ' this is only simulation 
    If lSpeedTime <= 50 Then 
        SInfoSpeed = "[Very Fast]" 
    ElseIf lSpeedTime >= 50 And lSpeedTime <= 100 Then 
        SInfoSpeed = "[Normal]" 
    ElseIf lSpeedTime >= 100 And lSpeedTime <= 200 Then   
        SInfoSpeed = "[Slow]" 
    ElseIf lSpeedTime >= 200 Then 
        SInfoSpeed = "[Very Slow]" 
    End If 
    frm.Caption = "Time Speed Form: " & lSpeedTime & " Milliseconds - " & SInfoSpeed 
End Function

Contoh penggunaan fungsi di atas:

Private Sub Command1_Click() 
    FormTestSpeed Form2 
End Sub

Monday, May 28, 2012

Fungsi Untuk Memeriksa Apakah Terhubung Ke Internet

Di bawah ini fungsi untuk memeriksa, apakah komputer terhubung ke internet atau tidak?

Option Explicit 
 
Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long 
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long 
' 
Const RAS95_MaxEntryName = 256 
Const RAS95_MaxDeviceType = 16 
Const RAS95_MaxDeviceName = 32 
' 
Private Type RASCONN95 
    dwSize As Long 
    hRasCon As Long 
    szEntryName(RAS95_MaxEntryName) As Byte 
    szDeviceType(RAS95_MaxDeviceType) As Byte 
    szDeviceName(RAS95_MaxDeviceName) As Byte 
End Type 
' 
Private Type RASCONNSTATUS95 
    dwSize As Long 
    RasConnState As Long 
    dwError As Long 
      szDeviceType(RAS95_MaxDeviceType) As Byte 
    szDeviceName(RAS95_MaxDeviceName) As Byte 
End Type 
 
Private Function IsConnected() As Boolean 
' 
    Dim TRasCon(255) As RASCONN95 
    Dim lg As Long 
    Dim lpcon As Long 
    Dim RetVal As Long 
    Dim Tstatus As RASCONNSTATUS95 
    ' 
    TRasCon(0).dwSize = 412 
    lg = 256 * TRasCon(0).dwSize 
    ' 
    RetVal = RasEnumConnections(TRasCon(0), lg, lpcon) 
    If RetVal <> 0 Then 
        MsgBox "ERROR" 
        Exit Function 
    End If 
    ' 
        Tstatus.dwSize = 160 
        RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus) 
    If Tstatus.RasConnState = &H2000 Then 
        IsConnected = True 
    Else   
        IsConnected = False 
    End If 
End Function

Private Sub Command1_Click() 
    MsgBox IsConnected 
End Sub

Fungsi Untuk Mendownload URL

Di bawah ini merupakan fungsi untuk mendownload sebuah URL.

Option Explicit 
 
Private Function DownloadFile(ByVal sFileSource As String, ByVal sDestFile As String) As Boolean 
    Dim bytes() As Byte 
    Dim fnum As Integer 
    bytes() = Inet1.OpenUrl(sFileSource, icByteArray) 
    fnum = FreeFile 
     
    Open sDestFile For Binary Access Write As #fnum 
        Put #fnum, , bytes() 
    Close #fnum 
     
    DownloadFile = True 
End Function

Contoh penggunaan fungsi di atas:

Private Sub Command1_Click() 
    Call DownloadFile("http://4basic-vb.blogspot.com", "C:\download.html") 
End Sub

Fungsi Untuk Menjadikan Blank Layar Komputer

Di bawah ini merupakan fungsi untuk mematikan layar monitor.

Option Explicit 
 
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 
 
Private Const MONITOR_ON = -1& 
Private Const MONITOR_LOWPOWER = 1& 
Private Const MONITOR_OFF = 2& 
Private Const SC_MONITORPOWER = &HF170& 
Private Const WM_SYSCOMMAND =   &H112 
 
Public Function TurnOnMonitor(hwnd As Long, bFlag As Boolean) As Boolean 
    If bFlag Then 
        Call SendMessage(hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal MONITOR_ON) 
    Else 
        Call SendMessage(hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal MONITOR_OFF) 
    End If 
End Function

Contoh penggunaan kode di atas:

Option Explicit 
 
Private Sub Command1_Click() 
    TurnOnMonitor Me.hwnd, False 
End Sub

Fungsi Untuk Mengetahui Default Printer

Di bawah ini merupakan fungsi untuk mengetahui default printer yang sedang digunakan.

Option Explicit 
 
Function DefPrintName() As String 
    DefPrintName = Printer.DeviceName 
End Function

Private Sub Command1_Click() 
    MsgBox DefPrintName, vbInformation, "Default Printer" 
End Sub

Memperoleh Informasi Mengenai Printer Yang Terinstall

Di bawah ini merupakan cara memperoleh/mengetahui informasi mengenai printer yang terinstall.

Option Explicit 
 
Public Function ListAllPrinters(lst As Control) 
    Dim oPrint As Object 
    For Each oPrint In Printers 
      List1.AddItem oPrint.DeviceName 
    Next 
End Function

Contoh penggunaan mengenai printer yang terinstall

Private Sub Form_Load() 
    ListAllPrinters List1 
End Sub

Memeriksa Keberadaan Sound Card Pada Komputer

Di bawah ini merupakan fungsi untuk mengetahui apakah komputer memiliki souncard atau tidak.

Option Explicit 
 
Private Declare Function waveOutGetNumDevs Lib &quot;winmm.dll&quot; ) As Long 
 
Public Function IsExistSoundCard() As Boolean 
    Dim I As Integer 
    I = waveOutGetNumDevs() 
    IsExistSoundCard = I > 0) 
End Function

Contoh penggunaan fungsi memeriksa keberadaan sound card pada komputer

Private Sub Command1_Click() 
    MsgBox IsExistSoundCard 
End Sub

Fungsi Untuk Membuat Kata Secara Acak

Di bawah ini merupakan fungsi untuk membuat sebuah kata secara acak.

Option Explicit 
 
Public Function RandomString(Optional Max As Integer = 5) As String 
 
    Dim sAlpha As String 
    Dim iLoop As Integer 
    Dim iRandNum As Integer 
    Dim sMatch As String 
    Dim str As String 
    sAlpha = &quot;abcdefghijklmnopqrstuvwxyz&quot; 
 
    Randomize 
 
    For iLoop = 1 To Max 
        iRandNum = Int((26   - 1 + 1) * Rnd + 1) 
        sMatch = Mid(sAlpha, iRandNum, 1) 
        str = str &amp; sMatch 
    Next iLoop 
 
    RandomString = str 
 
End Function

Contoh penggunaan fungsi menampilkan kata secara acak

Private Sub Command1_Click() 
    MsgBox RandomString 10 
End Sub

Fungsi Encrypt Dan Decrypt Sederhana

Option Explicit 
 
Public Function Encrypt(sText As String) As String 
    Dim i As Integer 
    Dim msg As String 
    For i = 1 To Len(sText) 
        msg = msg & Chr(Asc(Mid(sText, i, 1)) + 9) 
    Next 
    Encrypt = msg 
End Function 
 
Public Function Decrypt(sText As String) As String 
    Dim i As Integer 
    Dim msg As String 
    For i = 1 To Len(sText) 
        msg = msg & Chr(Asc(Mid(sText, i, 1)) - 9) 
    Next 
    Decrypt = msg 
End Function

Contoh penggunaan fungsi encrypt dan decrypt sederhana

Private Sub Command1_Click() 
    Text2.Text = Encrypt(Text1.Text) 
End Sub 
 
Private Sub Command2_Click() 
    Text3.Text = Decrypt(Text2.Text) 
End Sub

Fungsi Untuk Mengetahui Apakah Ganjil Atau Genap

Di bawah ini merupakan fungsi yang sangat sederhana untuk mengetahui sebuah bilangan, apakah ia genap atau ganjil?

Option Explicit 
 
Public Function IsEven(Number As Double) As Boolean 
    IsEven = IIf(Number Mod 2 = 0, True, False) 
End Function

Sample usage

Private Sub Command1_Click() 
    MsgBox IsEven(20) 'return true 
End Sub 
 
Private Sub Command1_Click() 
    MsgBox IsEven(21) 'return false 
End Sub

Memilih Item ListBox Secara Otomatis

Bagaimana cara memilih item yang terdapat pada ListBox secara otomatis pada saat mouse berada di atasnya.

Option Explicit 
 
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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long 
 
Private Const LB_SETCURSEL = &H186 
Private Const LB_GETCURSEL = &H188 
 
Private Type POINTAPI 
    X As Long 
    Y As Long 
End Type 
 
Private Sub HightLightListBox(ByVal hwndLB As Long, ByVal X As Single, ByVal Y As Single) 
 
    Dim IndexItem As Long 
    Dim Point As POINTAPI 
 
    Point.X = X \ Screen.TwipsPerPixelX   
    Point.Y = Y \ Screen.TwipsPerPixelY 
 
    Call ClientToScreen(hwndLB, Point) 
 
    IndexItem = LBItemFromPt(hwndLB, Point.X, Point.Y, False) 
 
    If IndexItem <> SendMessage(hwndLB, LB_GETCURSEL, 0, 0) Then 
        Call SendMessage(hwndLB, LB_SETCURSEL, IndexItem, 0) 
    End If 
 
End Sub

Contoh penggunaan kode di atas:

Private Sub Form_Load() 
    Dim i As Long 
    For i = 0 To 100 
        List1.AddItem 1234567 + i 
      Next 
End Sub 
 
Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    HightLightListBox List1.hwnd, X, Y 
End Sub

Membuat Label Yang Berkedip-Kedip

Bagaimana cara membuat label yang berkedip-kedip, simak kodenya di bawah ini:

Private Sub Form_Load() 
    Label1.Caption = "http://4basic-vb.blogspot.com" 
    Timer1.Interval = 300 
End Sub 
 
Private Sub Timer1_Timer() 
    Label1.Visible = Not Label1.Visible 
End Sub

Membuat Efek Fade-In Fade-Out Pada Form - VB6 Code

Di bawah ini merupakan fungsi untuk membuat efek fade pada sebuah form.

Option Explicit 
 
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 
 
Public 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 Command1_Click() 
    Unload Me 
End Sub

Private Sub Form_Load() 
 
    Timer1.Enabled = False 
    Timer2.Enabled = False 
    Timer1.Interval = 1 
    Timer2.Interval = 1 
    Me.Visible = False   
    Timer1.Enabled = True 
 
End Sub 
 
Private Sub Form_Unload(Cancel As Integer) 
    Cancel = 1 
    Timer1.Enabled = False 
    Timer2.Enabled = True 
End Sub 
 
Private Sub Timer1_Timer() 
    On Error Resume Next 
    iTransparant = iTransparant + 5 
    If iTransparant > 255 Then 
        iTransparant = 255 
        Timer1.Enabled = False 
    End If 
      MakeTransparan Me.hWnd, iTransparant 
    Me.Show 
End Sub 
 
Private Sub Timer2_Timer() 
    On Error Resume Next 
    iTransparant = iTransparant - 5 
    If iTransparant < 0 Then 
        iTransparant = 0 
        Timer2.Enabled = False 
        End 
    End If 
    MakeTransparan Me.hWnd, iTransparant 
End Sub

Menjadikan Form Berada Paling Depan

Fungsi di bawah ini merupakana cara menampilkan form agar berada paling depan (Form On Top/Top Most)

Option Explicit 
 
Public Declare Function SetWindowPos Lib "user32" ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long 
 
Public Const HWND_TOPMOST = -1 
Public Const HWND_NOTOPMOST = -2 
Public Const SWP_NOMOVE = &H2 
Public Const SWP_NOSIZE = &H1 
Public Const SWP_NOACTIVATE = &H10 
Public Const SWP_SHOWWINDOW = &H40 
Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE 
 
Public Function TopMost(frm As Form, bTopMost As Boolean) 
    If bTopMost Then 
        Call SetWindowPos(frm.hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS) 
    Else 
        Call SetWindowPos(frm.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS) 
    End If 
End Function 
Contoh penggunaan menjadikan form berada paling depan 
Private Sub Form_Load() 
    TopMost Me, True 
End Sub

Menjadikan Form Semi Transparan

Bagaimana cara membuat form semi transparan menggunakan Visual Basic 6.0. Simaklah kodenya di bawah ini:

Option Explicit 
 
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 
 
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

Contoh penggunaan membuat form semi transparan

Option Explicit 
 
Private Sub Form_Load() 
    On Error Resume Next 
    MakeTransparan Me.hWnd, 75 
End Sub

Generate nomor Secara Unik

Di bawah ini merupakan fungsi yang berlakuk sebagai sebuah generator agar menampilkan nomor secara unik (tidak ada yang sama satu dengan yang lainnya).

Option Explicit 
 
Private Function GenRanUnix(MIN As Integer, MAX As Integer) As Collection 
 
    Dim iMax As Integer 
    Dim iRan As Integer 
    Dim g As Integer 
    Dim y As Integer 
    Dim c As New Collection 
    Dim k As New Collection 
    Dim f As Integer 
    Dim x As Integer 
 
    For f = MIN To MAX 
        c.Add f 
    Next 
 
    y = c.Count 
    Randomize 
 
    For x = 1 To y 
        g = Int(y * Rnd + 1) 
        k.Add c.Item(g) 
        c.Remove g 
        y = c.Count 
    Next 
 
    Set GenRanUnix = k 
 
End Function

Contoh penggunaan generate nomor secara unik

Private Sub Command1_Click() 
    Dim b As New Collection 
    Dim i As Integer 
    Dim msg As String 
    List1.Clear 
    Set b = GenRanUnix(0, 100) 
    For i = 1 To   b.Count 
        List1.AddItem b.Item(i) 
    Next 
End Sub

Fungsi Konfirmasi Sebelum Keluar Dari Aplikasi

Di bawah ini merupakan fungsi konfirmasi sebelum keluar dari aplikasi. Mengapa dibuat menjadi fungsi? agar reusability (memiliki sifat mudah digunakan kembali) karena hampir tiap software yang dibuat, memerlukan fungsi di bawah ini:

Option Explicit 
 
Public Function ConfirmExit(Optional Title As String = "Konfirmasi") As Boolean 
    If MsgBox("Are you sure want to exit?", vbQuestion + vbYesNo, Title) = vbYes Then 
        ConfirmExit = ConfirmExit 
    Else 
        ConfirmExit = True 
    End If 
End Function

Contoh penggunaan fungsi di atas:

Private Sub Form_QueryUnload(Cancel As   Integer, UnloadMode As Integer) 
    Cancel = ConfirmExit 
End Sub

Penggunaan fungsi di atas dapat kita tempatkan pada event Unload ataupun QueryUnload.

Mengetahui Keyboard Yang Sedang Digunakan

Di bawah ini merupakan procedure untuk mengetahui keyboard yang sedang digunakan.

Option Explicit 
 
Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long 
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long 
 
Public Sub KeyBoardLanguage() 
 
    Dim TheardId As Long 
    Dim TheardLang As Long 
    Dim processid As Long 
 
    TheardId = GetWindowThreadProcessId(hwnd, processid) 
      TheardLang = GetKeyboardLayout(ByVal TheardId) 
    TheardLang = TheardLang Mod 10000 
 
    Select Case TheardLang 
        Case "9721" 
            MsgBox "English" 
        Case "5425" 
            MsgBox "Arabic" 
        Case Else 
            MsgBox "I don't know atuh, cari weh ku anjeun sorangan", vbInformation, "Don't Know" 
    End Select 
 
End Sub

Contoh penggunaan procedure di atas:

Private Sub Command1_Click()   
    KeyBoardLanguage 
End Sub

Procedure Auto Drop Down Pada ComboBox

Di bawah ini merupakan procedure auto drop down pada objek ComboBox standar. Maksudnya, drop down otomatis apabila mouse berada di atasnya tanpa harus mengkliknya terlebih dahulu.

Option Explicit 
 
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 
Const CB_SHOWDROPDOWN = &H14F 
 
Public Sub AutoDropDown(cmb As ComboBox) 
    Call SendMessage(cmb.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0&) 
    If cmb.ListIndex = -1   Then cmb.ListIndex = 0 
End Sub

Contoh penggunaan proceder auto drop down pada combobox

Private Sub Combo1_GotFocus() 
    AutoDropDown Combo1 
End Sub 
 
Private Sub Form_Load() 
    With Combo1 
        .AddItem "asep hibban" 
        .AddItem "fahmi nurul anwar" 
        .AddItem "mohammad galbi" 
        .AddItem "karim wafi" 
    End With 
End Sub

Menambah Horizontal ScrollBar Pada RichTextBox

Di bawah ini merupakan kode mengenai cara menambah horizontal scrollbar pada objek richtextbox.

Option Explicit 
 
Private Sub Form_Load() 
    With RichTextBox1 
        .Text = "Visual Basic :: Horizontal Scroll Position In A Richtextbox, you must set the scrollbar properties to 1 or 3" 
        .RightMargin = RichTextBox1.Width + 600 
    End With 
End Sub

Menambah Horizontal ScrollBar pada ListBox

Di bawah ini merupakan procedure untuk menambah ScrollBar pada objek ListBox. Seperti yang kita ketahui, ListBox tidak memiliki properties horizontal scroll bar akan tetapi dengan memanggil beberapa fungsi API hal tersebut mungkin untuk dilakukan.

Option Explicit 
 
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 Const LB_SETHORIZONTALEXTENT = &H194 
 
Public Sub AddHSBToListBox(sText As String, lst As ListBox) 
    Static x As Long   
    lst.AddItem sText 
    If x < TextWidth(sText & "  ") Then 
        x = TextWidth(sText & "  ") 
    End If 
    If ScaleMode = vbTwips Then 
        x = x / Screen.TwipsPerPixelX 
        SendMessageByNum lst.hwnd, LB_SETHORIZONTALEXTENT, x, 0 
    End If 
End Sub

Contoh penggunaan menambah horizontal scrollbar pada listbox

Private Sub Command1_Click() 
    Dim sText As String 
    sText = ("This is a sample of long text, if the text longer than   listbox, it will be create horizontal scrollbar automatically") 
    AddHSBToListBox sText, List1 
End Sub

Menampilkan Browse For Folder Menggunakan Fungsi API

Pada postingan terdahulu telah kami ketengahkan mengenai cara menampilkan browse for folder dengan mudah menggunakan kode yang pendek dengan memanfaatkan ActiveX. Sekarang, kita akan menampilkan browse for folder dengan memanfaatkan fungsi API, tentu saja kodenya lebih panjang dari artikel yang terdahulu.

Option Explicit 
 
Private Const BIF_RETURNONLYFSDIRS = 1 
Private Const BIF_DONTGOBELOWDOMAIN = 2 
Private Const MAX_PATH = 260 
 
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long 
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long 
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long 
 
Public Type BrowseInfo 
    hWndOwner As Long 
    pIDLRoot As Long 
    pszDisplayName As Long 
    lpszTitle As Long 
    ulFlags As Long 
    lpfnCallback As Long 
    lParam As Long 
    iImage As Long 
End Type 
 
Public Function BrowseForFolder(hwnd As Long, Optional Title As String = "Browse For Folder") As String 
    Dim lpIDList As Long 
    Dim sBuffer As String 
    Dim szTitle As String 
    Dim tBrowseInfo As BrowseInfo 
    szTitle = "This Is My Title" 
    With tBrowseInfo 
        .hWndOwner = Me.hwnd 
        .lpszTitle = lstrcat(szTitle, "") 
        .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN 
    End With 
    lpIDList = SHBrowseForFolder(tBrowseInfo) 
    If (lpIDList) Then 
        sBuffer = Space(MAX_PATH) 
        SHGetPathFromIDList lpIDList, sBuffer 
        sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1) 
        BrowseForFolder = sBuffer 
    End If 
End Function

Private Sub Command1_Click() 
    Text1.Text = BrowseForFolder(Me.hwnd) 
End Sub

Menampilkan Dialog Properties Sebuah File

Di bawah ini merupakan fungsi untuk menampilkan kotak dialog properties sebuah file.

Option Explicit 
 
Type SHELLEXECUTEINFO 
    cbSize As Long 
    fMask As Long 
    hwnd As Long 
    lpVerb As String 
    lpFile As String 
    lpParameters As String 
    lpDirectory As String 
    nShow As Long 
    hInstApp As Long 
    lpIDList As Long 
    lpClass As String 
    hkeyClass As Long 
    dwHotKey As Long 
    hIcon As Long 
    hProcess As Long 
End Type 
 
Public Const SEE_MASK_INVOKEIDLIST = &HC 
Public Const SEE_MASK_NOCLOSEPROCESS = &H40 
Public Const SEE_MASK_FLAG_NO_UI = &H400 
 
Declare Function ShellExecuteEX Lib "shell32.dll" Alias "ShellExecuteEx" (SEI As SHELLEXECUTEINFO) As Long 
 
Public Sub ShowProps(FileName As String, OwnerhWnd As Long) 
 
  Dim SEI As SHELLEXECUTEINFO   
    Dim lngReturn As Long 
 
  With SEI 
        .cbSize = Len(SEI) 
        .fMask = SEE_MASK_NOCLOSEPROCESS Or _ 
            SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI 
        .hwnd = OwnerhWnd 
        .lpVerb = "properties" 
        .lpFile = FileName 
        .lpParameters = vbNullChar 
        .lpDirectory =   vbNullChar 
        .nShow = 0 
        .hInstApp = 0 
        .lpIDList = 0 
    End With 
 
  lngReturn = ShellExecuteEX(SEI) 
 
End Sub

Contoh menggunakan dialog properties sebuah file

Option Explicit 
 
Private Sub Command1_Click() 
    Call ShowProps("C:\boot.ini", Me.hwnd) 
End Sub

Membuat Form Yang Berbentuk Elips

Bagaimanakah cara membuat form yang berbentuk elips? tentu saja untuk keperluan ini kita harus memanggil beberapa fungsi API. Bagaimana kodenya? simaklah di bawah ini:

Option Explicit 
 
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long 
Private Declare Function SetWindowRgn Lib "USER32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Contoh penggunaan fungsi API agar form berbentuk Elips

Private Sub Form_Click() 
      Unload Me 
End Sub 
 
Private Sub Form_Load() 
    SetWindowRgn hWnd, CreateEllipticRgn(0, 0, 299, 200), True 
End Sub

Menyimpan Form Di Tengah Layar (Screen)

Di bawah ini merupkan procedure untuk menyimpan/memindahkan form tepat di tengah layar.

Option Explicit 
 
Private Sub CenterForm(frmIn As Object) 
 
    Dim iTop As Integer, ileft As Integer 
 
    If frmIn.WindowState <> 0 Then 
        'prevent if form maximized or minimized 
          'the form must in normal condition 
          Exit Sub 
    End If 
 
    ileft = (Screen.Width - frmIn.Width) \ 2 
    iTop   = (Screen.Height - frmIn.Height) \ 2 
    frmIn.Move ileft, iTop 
 
End Sub

Cara penggunaan kode di atas:

Private Sub Form_Load() 
    Form_Resize 
End Sub 
 
Private Sub Form_Resize() 
    CenterForm Me 
End Sub

Membuat Form Yang Berbentuk Lingkaran

Bagaimanakah cara membuat form yang berbentuk lingkaran? simaklah kodenya di bawah ini:

Option Explicit 
 
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long 
Private Declare Function SetWindowRgn Lib "User32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long 
 
Function CutCirCle(frm As Form, Left, Top, Fat, Tall) 
    With frm 
        .Width = (Fat + 10) * 15 
        .Height = (Tall + 10) * 15 
    End With 
    SetWindowRgn frm.hWnd, CreateEllipticRgn(Left, Top, Fat, Tall), True 
End Function

Contoh penggunaan kode di atas:

Private Sub Command1_Click() 
    Call CutCirCle(Me, 0, 0, 600, 600) 
End Sub 
 
Private Sub Form_Resize() 
    Command1.Left = ((610 * 15) / 2) - (Command1.Width / 2)   
End Sub

Menutup Seluruh Form Menggunakan For...Each

Di bawah ini merupakan procedure untuk menutup seluruh form dengan menggunakan for...each.

Option Explicit 
 
Public Sub CloseAllForm() 
    Dim frm As Form 
    For Each frm In Forms 
        Unload frm 
    Next 
End Sub

Contoh penggunaan procedure di atas:

Private Sub Form_Unload(Cancel As Integer) 
    CloseAllForm 
End Sub

Cara Mudah Menjalankan Aplikasi Pada Start Up

Di bawah ini merupakan cara yang mudah untuk menjalankan aplikasi pada saat startup. Pada dasarnya fungsi startup, hanyalah fungsi baca dan tulis ke dalam registy. Kodenya pendek, karena ia meminjam ActiveX Windows Script Host Object Model atau yang lebih dikenal dengan nama WSHOM.OCX.

Option Explicit 
 
Dim oWSHShell As New WshShell 
 
Private Function RegWrite(sKey As String, sFilepath As String) 
    oWSHShell.RegWrite sKey, sFilepath 
End Function 
 
Private Function RegDelete(sKey As String) 
    oWSHShell.RegDelete sKey 
End Function

Contoh penggunaan fungsi di atas yang digunakan untuk menulis ke dalam registry

Private Sub Command1_Click() 
    RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\" & _ 
    App.EXEName, App.Path & "\" & App.EXEName & ".exe" 
End Sub

Contoh penggunaan fungsi di atas yang digunakan untuk menghapus entry yang terdapat dalam registry

Private Sub Command2_Click() 
    RegDelete "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName 
End Sub

Animasi Ketikan Tanpa Flicker

Fungsi di bawah ini digunakan untuk animasi yang menyerupai text yang sedang di ketik. Animasinya sangat halus nyaris tanpa kedipan.

Option Explicit 
 
Dim sAnimation As String 
 
Private Sub Form_Load() 
    sAnimation = "Test : http://4basic-vb.blogspot.com" 
End Sub 
 
Private Sub Timer1_Timer() 
    Dim sToAnimate As String 
    Static iAnimation As Integer 
    Dim c As Integer 
    iAnimation = iAnimation + 1 
 
    sToAnimate = Mid(sAnimation, 1,   iAnimation) 
    With Picture1 
        .Cls 
        .CurrentX = 25 
        .CurrentY = 100 
        Picture1.Print sToAnimate 
    End With 
    If iAnimation >= Len(sAnimation) Then 
      iAnimation = 0 
    End If 
End Sub

Memperoleh Waktu Double Klik Pada Mouse

Source di bawah ini berguna untuk memperoleh waktu double klik pada mouse dengan menggunakan fungsi API GetDoubleClick.

Option Explicit 
 
Private Declare Function GetDoubleClickTime Lib "user32" () As Long 
 
Private Sub Command1_Click() 
    Dim ret As Long 
    ret = GetDoubleClickTime 
    Text1.Text = ret & " milliseconds" 
End Sub

Menjalankan Screen Saver Melalui Pemrograman

Di bawah ini merupakan fungsi untuk menjalankan screen saver melalui pemrograman.

Option Explicit 
 
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
 
Private Const WM_SYSCOMMAND = &H112& 
Private Const SC_SCREENSAVER = &HF140& 
 
Public Sub RunScreenSaver() 
    Call SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVER, 0&) 
End Sub

Contoh penggunaan menjalankan screen saver

Private Sub Command1_Click() 
    RunScreenSaver 
End Sub

Mencari Dengan Cepat Pada ListBox Menggunakan Fungsi API

Di bawah ini merupakan fungsi yang digunakan untuk mencari sebuah item yang terdapat dalam objek ListBox dengan cepat.

Option Explicit 
 
Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long 
Private Const LB_FINDSTRING = &H18F 
 
Public Function SearchInList(sText As String, lst As ListBox) 
    On Error Resume Next 
    lst.ListIndex = SendMessage(lst.hWnd, LB_FINDSTRING, -1, ByVal sText) 
    lst.TopIndex = List1.ListIndex - 1 
End Function

Contoh penggunaan mencari dengan cepat menggunakan fungsi API

Private Sub Form_Load() 
    With List1 
        .AddItem "Bandung" 
        .AddItem "Jakarta" 
        .AddItem "Garut" 
        .AddItem "Surabaya" 
        .AddItem "New York" 
        .AddItem "Khoiriyyah" 
    End With 
End Sub 
 
Private Sub Text1_Change() 
      SearchInList Text1.Text, List1 
End Sub

Fungsi Untuk Memeriksa Apakah Screen Saver Enable

Di bawah ini merupakan fungsi untuk memeriksa apakah screen saver enable atau disable? enable return true dan jika disable, apalagi jika bukan return false.

Option Explicit 
 
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long 
Private Const SPI_GETSCREENSAVEACTIVE = 16 
 
Private Function IsScreenSaverEnable() As Boolean 
  Dim bReturn As Boolean 
  Dim bActive As Boolean 
  Call   SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, vbNull, bReturn, 0) 
    IsScreenSaverEnable = bReturn 
End Function

Contoh penggunaan fungsi untuk memeriksa apakah screen saver enable

Private Sub Command1_Click() 
    MsgBox IsScreenSaverEnable 
End Sub

Fungsi Untuk Memperoleh Nilai Rata-Rata Dari Sebuah Array

Di bawah ini merupakan fungsi untuk memperoleh nilai rata-rata dari sebuah array.

Option Explicit 
 
Function AVERAGE(ByRef Number() As Double) As Double 
    Dim iMaxNum As Double, i As Integer 
    For i = LBound(Number) To UBound(Number) 
        iMaxNum = iMaxNum + Number(i) 
    Next i 
    AVERAGE = iMaxNum / (UBound(Number) + 1) 
End Function

Contoh penggunaan fungsi untuk memperoleh nilai rata-rata dari sebuah array

Private Sub   Command1_Click() 
    Dim iArray(3) As Double 
    iArray(0) = 588 
    iArray(1) = 67 
    iArray(2) = 66 
    iArray(3) = 4 
    MsgBox "The Average is: " & AVERAGE(iArray) 
End Sub

Fungsi Untuk Memperoleh Nilai Maksimal Dari Sebuah Array

Di bawah ini merupakan fungsi untuk memperoleh nilai maksimal dari sebuah array.

Option Explicit 
 
Public Function MAX(ByRef Number() As Double) As Double 
    Dim iMaxNum As Double 
    Dim i As Integer 
    iMaxNum = Number(LBound(Number)) 
        For i = LBound(Number) To UBound(Number) 
            If Number(i) > iMaxNum Then 
                iMaxNum = Number(i) 
            Else 
                iMaxNum = iMaxNum 
            End If 
        Next i 
      MAX = iMaxNum 
End Function

Contoh penggunaan fungsi untuk memperoleh nilai maksimal dari sebuah array

Private Sub Command1_Click() 
    Dim iArray(3) As Double 
    iArray(0) = 588 
    iArray(1) = 67 
    iArray(2) = 66 
    iArray(3) = 4 
    MsgBox "The max number is: " & MAX(iArray) 
End Sub

Memperoleh Jumlah Baris TextBox Menggunakan Fungsi API

<pre class=code>Option Explicit 
 
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 Const EM_GETLINECOUNT = &HBA 
 
Public Function GetLineCount(Txt As TextBox) 
    Dim lngLineCount As Long 
    On Error Resume Next 
    lngLineCount = SendMessageLong(Txt.hwnd, EM_GETLINECOUNT, 0&, 0&) 
    GetLineCount =   Format$(lngLineCount, "##,###") 
End Function</pre>

Private Sub Command1_Click() 
    MsgBox GetLineCount(Text1) 
End Sub

Menjadikan Input TextBox Kapital

Option Explicit 
 
'This one line code makes the contents of text box in capital. As you keep in typing it. Just copy this code keypress  
Private Sub Text1_KeyPress(KeyAscii As Integer) 
    KeyAscii = Asc(UCase(Chr(KeyAscii))) 
End Sub

Menjalankan File .MP3 Menggunakan Microsoft Multimedia Control

Option Explicit 
 
Private Sub Command1_Click() 
    MMC.FileName = OpenFile 
    Me.Caption = MMC.FileName 
    MMC.Command = "open" 
    MMC.Command = "play" 
End Sub 
 
Private Function OpenFile() As String 
  With CommonDialog1 
        .FileName = "" 
        .DialogTitle = "Open Files" 
        .InitDir =   "C:\My Documents" 
        .Filter = "MP3 File (*.MP3)|*.MP3" 
        .ShowOpen 
        If .FileName = "" Then Exit Function 
        MMC.Command = "stop" 
        OpenFile = .FileName 
    End With 
End Function 
 
Private Sub Command2_Click() 
    MMC.Command = "stop" 
End Sub

Berapa Lama Windows Telah Dijalankan

Option Explicit 
 
Private Declare Function GetTickCount Lib "Kernel32" () As Long 
 
Private Sub Timer1_Timer() 
    Text1.Text = Format(GetTickCount, "0") & " milisceconds" 
    Text2.Text = Format(GetTickCount / 60000, "0") & " minutes" 
End Sub

Fungsi Shutdown, Restart, Log-Off Dan Sebagainya

Option Explicit 
 
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long 
Private Const ENDSESSION_LOGOFF As Long = &H80000000 
 
Public Enum EShutDownTypes 
    [_First] = 0 
    EWX_LOGOFF = 0 
    EWX_SHUTDOWN = 1& 
    EWX_REBOOT = 2& 
    EWX_FORCELOGOFF = 4& 
    EWX_FORCESHUTDOWN   = 5& 
    EWX_FORCEREBOOT = 6& 
    EWX_POWEROFF = 8& 
    EWX_FORCEIFHUNG = 10& ' NT5 only 
    [_Last] = &H20& - 1 
End Enum 
 
Public Enum EShutDownErrorBaseConstant 
    eeSSDErrorBase = vbObjectError Or (1048 + &H210) 
End Enum 
 
Private Type OSVERSIONINFO 
    dwOSVersionInfoSize As Long   
    dwMajorVersion As Long 
    dwMinorVersion As Long 
    dwBuildNumber As Long 
    dwPlatformId As Long 
    szCSDVersion As String * 128 
End Type 
 
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long 
 
Private Const VER_PLATFORM_WIN32_NT = 2 
Private Const VER_PLATFORM_WIN32_WINDOWS = 1 
Private Const VER_PLATFORM_WIN32s = 0 
 
Private Const   FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100 
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000 
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800 
Private Const FORMAT_MESSAGE_FROM_STRING = &H400 
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000 
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200 
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF 
 
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, _ 
ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long 
 
Private Type LARGE_INTEGER 
    LowPart As Long 
    HighPart As Long 
End Type 
 
Private Type LUID 
    LowPart As Long 
    HighPart As Long 
End Type 
 
Private Type LUID_AND_ATTRIBUTES 
    pLuid As LUID 
    Attributes As Long 
End Type 
 
Private Type TOKEN_PRIVILEGES 
    PrivilegeCount As Long 
    Privileges(0 To 0) As LUID_AND_ATTRIBUTES 
End Type 
 
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long 
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long 
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long   
Private Declare Function GetTokenInformation Lib "advapi32.dll" (ByVal TokenHandle As Long, TokenInformationClass As Integer, TokenInformation As Any, ByVal TokenInformationLength As Long, ReturnLength As Long) As Long 
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long 
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias   "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long 
 
Private Const SE_SHUTDOWN_NAME = "SeShutdownPrivilege" 
Private Const SE_PRIVILEGE_ENABLED = &H2 
 
Private Const READ_CONTROL = &H20000 
Private Const STANDARD_RIGHTS_ALL = &H1F0000 
Private Const STANDARD_RIGHTS_EXECUTE = (READ_CONTROL) 
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL) 
Private Const   STANDARD_RIGHTS_REQUIRED = &HF0000 
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL) 
 
Private Const TOKEN_ASSIGN_PRIMARY = &H1 
Private Const TOKEN_DUPLICATE = (&H2) 
Private Const TOKEN_IMPERSONATE = (&H4) 
Private Const TOKEN_QUERY = (&H8) 
Private Const TOKEN_QUERY_SOURCE = (&H10) 
Private Const TOKEN_ADJUST_PRIVILEGES = (&H20) 
Private Const TOKEN_ADJUST_GROUPS =   (&H40) 
Private Const TOKEN_ADJUST_DEFAULT = (&H80) 
Private Const TOKEN_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or TOKEN_ASSIGN_PRIMARY Or _ 
TOKEN_DUPLICATE Or TOKEN_IMPERSONATE Or TOKEN_QUERY Or TOKEN_QUERY_SOURCE Or TOKEN_ADJUST_PRIVILEGES Or TOKEN_ADJUST_GROUPS Or TOKEN_ADJUST_DEFAULT) 
Private Const TOKEN_READ = (STANDARD_RIGHTS_READ Or TOKEN_QUERY) 
Private Const TOKEN_WRITE = (STANDARD_RIGHTS_WRITE Or   TOKEN_ADJUST_PRIVILEGES Or TOKEN_ADJUST_GROUPS Or TOKEN_ADJUST_DEFAULT) 
Private Const TOKEN_EXECUTE = (STANDARD_RIGHTS_EXECUTE) 
Private Const TokenImpersonationLevel = 9 
Private Const TokenOwner = 4 
Private Const TokenUser = 1 
Private Const TokenPrimaryGroup = 5 
Private Const TokenStatistics = 10 
Private Const TokenType = 8 
Private Const TokenPrivileges = 3 
Private Const TokenSource = 7 
Private Const TokenDefaultDacl = 6 
Private Const TokenGroups = 2 
 
Public Function WinError(ByVal lLastDLLError As Long) As String 
 
    Dim sBuff As String 
    Dim lCount As Long 
 
    sBuff = Space(255) 
    lCount = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, lLastDLLError, 0&, sBuff, Len(sBuff), ByVal 0) 
 
    If lCount Then 
       WinError = Left(sBuff, lCount) 
    End If 
 
End Function 
 
Public Function IsNT() As Boolean 
 
   Static bOnce As Boolean 
   Static bValue As Boolean 
 
   If Not (bOnce) Then 
       Dim tVI As OSVERSIONINFO 
 
       tVI.dwOSVersionInfoSize = Len(tVI) 
 
       If (GetVersionEx(tVI) <> 0) Then 
           bValue = (tVI.dwPlatformId = VER_PLATFORM_WIN32_NT) 
              bOnce = True 
       End If 
   End If 
 
   IsNT = bValue 
 
End Function 
 
Private Function NTEnableShutDown(ByRef sMsg As String) As Boolean 
 
    Dim tLUID As LUID 
    Dim hProcess As Long 
    Dim hToken As Long 
    Dim tTP As TOKEN_PRIVILEGES 
    Dim tTPOld As TOKEN_PRIVILEGES 
    Dim lTpOld As Long 
    Dim lR As Long 
 
   lR =   LookupPrivilegeValue(vbNullString, SE_SHUTDOWN_NAME, tLUID) 
 
   If (lR <> 0) Then 
 
       hProcess = GetCurrentProcess() 
        If (hProcess <> 0) Then 
           lR = OpenProcessToken(hProcess, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hToken) 
            If (lR <> 0) Then 
 
               With tTP 
                    .PrivilegeCount = 1 
                    With .Privileges(0) 
                        .Attributes =   SE_PRIVILEGE_ENABLED 
                        .pLuid.HighPart = tLUID.HighPart 
                        .pLuid.LowPart = tLUID.LowPart 
                    End With 
               End With 
 
               lR = AdjustTokenPrivileges(hToken, 0, tTP, Len(tTP), tTPOld, lTpOld) 
 
                If (lR <> 0) Then 
                   NTEnableShutDown = True 
                Else 
                   Err.Raise eeSSDErrorBase + 6, App.EXEName & ".mShutDown", "Can't enable shutdown: You do not have the privileges to " & "shutdown this system. ["   & WinError(Err.LastDllError) & "]" 
                End If 
 
               CloseHandle hToken 
            Else 
               Err.Raise eeSSDErrorBase + 6, App.EXEName & ".mShutDown", "Can't enable shutdown: You do not have the privileges to " & "shutdown this system. [" & WinError(Err.LastDllError) & "]" 
            End If 
       Else 
           Err.Raise eeSSDErrorBase + 5, App.EXEName & ".mShutDown", "Can't enable shutdown: Can't determine the current process. [" & WinError(Err.LastDllError) & "]" 
        End If 
   Else 
       Err.Raise eeSSDErrorBase +   4, App.EXEName & ".mShutDown", _ 
            "Can't enable shutdown: Can't find the SE_SHUTDOWN_NAME privilege value. [" & _ 
            WinError(Err.LastDllError) & "]" 
    End If 
 
End Function 
 
Public Function ShutdownSystem(Optional ByVal eType As EShutDownTypes = EWX_SHUTDOWN) As Boolean 
 
   Dim yesno As Integer 
 
   Dim lR As Long 
   Dim sMsg As String 
 
   If (eType < EShutDownTypes.[_First] And eType > EShutDownTypes.[_Last]) Then 
        Err.Raise   eeSSDErrorBase + 7, App.EXEName & ".mShutDown", "Invalid parameter to ShutdownSystem: " & eType, vbInformation 
        Exit Function 
   End If 
 
   If (IsNT) Then 
       If Not (NTEnableShutDown(sMsg)) Then 
           Exit Function 
       End If 
   End If 
 
   lR = ExitWindowsEx(eType, &HFFFFFFFF) 
 
    If (lR = 0) Then 
       Err.Raise eeSSDErrorBase + 3, App.EXEName & ".mShutDown", "ShutdownSystem failed: " & WinError(Err.LastDllError) 
    Else 
       ShutdownSystem = True 
    End If 
 
End Function

Private Sub Command1_Click() 
    ShutdownSystem EWX_FORCESHUTDOWN 
End Sub 
 
Private Sub Command2_Click() 
    ShutdownSystem EWX_FORCEREBOOT 
End Sub 
 
Private Sub Command3_Click() 
    ShutdownSystem EWX_FORCELOGOFF 
End Sub

Menghapus Isi TextBox Dengan Cepat Menggunakan For...Each

Option Explicit 
 
Public Sub ClearAllTextBoxes(frmClearMe As Form) 
    Dim txt As Control 
    For Each txt In frmClearMe 
        If TypeOf txt Is TextBox Then txt.Text = "" 
    Next 
End Sub

Private Sub Command1_Click() 
    ClearAllTextBoxes Me 
End Sub

Fungsi VB6 - Untuk Memperoleh Time Out Screen Saver

Mengenai fungsi VB6 untuk memperoleh timeout screen saver - Bagaimanakah kita dapat memperoleh time out dari screen saver melalui kode VB6, berikut adalah jawabanya:

Option Explicit 
 
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long 
Private Const SPI_GETSCREENSAVETIMEOUT = 14 
 
Function ScrTimeOut() As Integer 
    Dim intValue As Integer 
    Call SystemParametersInfo(SPI_GETSCREENSAVETIMEOUT, vbNull, intValue, 0) 
    ScrTimeOut = intValue 
End Function

Cara menggunakan fungsi VB6 diatas:

Private Sub Command1_Click() 
    MsgBox ("Screen saver time-out value: " & ScrTimeOut & " seconds.") 
End Sub

VB6 Code - Fungsi Untuk Merubah Desktop Wallpaper

Mengenai procedure VB6 untuk mengganti atau merubah gambar desktop (desktop wallpaper) - Ini merupakan procedure VB6 yang digunakan untuk mengganti gambar yang terdapat pada desktop (desktop wallpaper). Dengan menggunakan 1 buah fungsi API SystemParametersInfoA dan beberapa konstanta (SPIF_SENDWININICHANGE, SPIF_UPDATEINIFILE, SPIF_SETDESKWALLPAPER)

Option Explicit 
 
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long 
 
Private Const SPIF_SENDWININICHANGE = &H2 
Private Const SPIF_UPDATEINIFILE = &H1 
Private Const SPIF_SETDESKWALLPAPER = 20 
 
Public Function ChangeWallPaper(imgFile As String) 
    Call SystemParametersInfo(SPIF_SETDESKWALLPAPER, 0&, imgFile, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE) 
End Function

Adapun cara menggunakan procedure VB6 diatas adalah sebagai berikut:

Private Sub Command1_Click() 
    Call ChangeWallPaper("C:\Windows\Blue.bmp") 
End Sub

Demikian procedure VB6 untuk mengganti atau merubah desktop wallpaper.

Sunday, May 27, 2012

Menyembunyikan Dan Menampilkan Windows Taskbar

Di bawah ini merupakan contoh standar untuk menyembunyikan dan menampilkan windows taskbar.

Option Explicit 
 
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 
 
Const SWP_HIDEWINDOW = &H80 
Const SWP_SHOWWINDOW = &H40 
 
Public Sub HideTaskBar() 
    Dim hWnd1 As Long 
    hWnd1 = FindWindow("Shell_traywnd", "") 
    Call SetWindowPos(hWnd1, 0, 0, 0, 0, 0, SWP_HIDEWINDOW) 
End Sub 
 
Public Sub ShowTaskBar() 
    Dim hWnd1 As Long 
    hWnd1 = FindWindow("Shell_traywnd", "") 
    Call SetWindowPos(hWnd1, 0, 0, 0, 0, 0, SWP_SHOWWINDOW) 
End Sub

Contoh penggunaan untuk menyembunyikan windows taskbar

Private Sub Command1_Click() 
    HideTaskBar 
End Sub

Contoh penggunaan untuk menampilkan windows taskbar

Private Sub Command2_Click() 
    ShowTaskBar 
End Sub

Subscribe to: Posts ( Atom )

Tuesday, May 29, 2012

Monday, May 28, 2012

Sunday, May 27, 2012

Perhatian

Page Rank

Online

Statistik Pengunjung

embrio9 - Auto Reply

Blog Archive

Visual Basic 6.0

Arabic

Blogging

Miscellaneous