VB6 Code: Membuat DWord dari HiWord + LoWord

Posting ini diambil dari Microsoft KB mengenai cara membuat fungsi return DWord dengan menggabungkan HiWord dan LoWord. Adapun fungsi yang dimaksud adalah sebagai berikut:

Function MakeDWord(LoWord As Integer, HiWord As Integer) As Long 
    MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&) 
End Function 

Sedangkan untuk memecah DWord (32 bits) menjadi LoWord (16 bits) dan HiWord (16 bits) adalah sebagai berikut:

Function LoWord(DWord As Long) As Integer 
    If DWord And &H8000& Then ' &H8000& = &H00008000 
        LoWord = DWord Or &HFFFF0000 
    Else 
        LoWord = DWord And &HFFFF& 
    End If 
End Function 
 
Function HiWord(DWord As Long) As Integer 
    HiWord = (DWord And &HFFFF0000) \ &H10000 
End Function 

Sedangkan contoh dari fungsi MakeDword (menggabungkan LoWord dan HiWord) adalah sebagai berikut:

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 MK_LBUTTON = &H1 
Private Const WM_LBUTTONDOWN = &H201 
 
Function MakeDWord(LoWord As Integer, HiWord As Integer) As Long 
    MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&) 
End Function 
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    Form1.Cls 
    Form1.Print "Button Click Event Fired" 
    Form1.Print "Position X:" & Str$(X / Screen.TwipsPerPixelX) 
    Form1.Print "Position Y:" & Str$(Y / Screen.TwipsPerPixelY) 
End Sub 
 
Private Sub Command1_Click() 
    Dim nMousePosition As Long 
    ' nMousePosition stores the x (hiword) and y (loword) values 
    ' of the mouse cursor as measured in pixels. 
 
    Let nMousePosition = MakeDWord(16, 18) 
    Call SendMessage(Me.hwnd, WM_LBUTTONDOWN, MK_LBUTTON, nMousePosition) 
End Sub 
 

Semoga bermanfaat.

READ MORE - VB6 Code: Membuat DWord dari HiWord + LoWord

VB6 API - Menghilangkan Border TextBox, ListBox, etc.

Mengenai cara menghilangkan border object TextBox, ListBox, dan lain sebagainya.

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 Const WS_EX_CLIENTEDGE = &H200 
Private Const GWL_EXSTYLE = (-20) 
 
Private Sub RemoveBorder(ctl As Control) 
    Dim lStyle As Long 
    ctl.Appearance = 1 
    lStyle = GetWindowLong(ctl.hwnd, GWL_EXSTYLE) 
    lStyle = lStyle And Not WS_EX_CLIENTEDGE 
    SetWindowLong ctl.hwnd, GWL_EXSTYLE, lStyle 
    ctl.Appearance = 0 
End Sub 

Contoh penggunaan:

Private Sub Command1_Click() 
    Call RemoveBorder(Text1) 
End Sub 

READ MORE - VB6 API - Menghilangkan Border TextBox, ListBox, etc.

VB6 ListBox - Mengetahui Item Height Object ListBox

Untuk tujuan tertentu, terkadang kita memerlukan sebuah fungsi untuk mengukur Item Heigh sebuah object ListBox dan di bawah ini merupakan salah satu contohnya dengan menggunakan fungsi API.

Option Explicit   
   
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long   
Private Const LB_GETITEMRECT As Long = &H198   
   
Private Type RECT   
    Left As Long   
    Top As Long   
    Right As Long   
    Bottom As Long   
End Type   
   
Private Function ListBoxItemHeight(lst As ListBox) As Integer   
    Dim rc As RECT, i As Long, dy As Long   
    If lst.ListCount = 0 Then Exit Function   
    SendMessage lst.hwnd, LB_GETITEMRECT, ByVal 0&, rc   
    dy = rc.Bottom - rc.Top   
    ListBoxItemHeight = (dy * Screen.TwipsPerPixelY)   
End Function 

Contoh penggunaan:

Private Sub Command1_Click() 
    List1.AddItem "A" 
    MsgBox ListBoxItemHeight(List1) 
End Sub 

READ MORE - VB6 ListBox - Mengetahui Item Height Object ListBox

VB6 Code: Memperoleh Serial Hardisk dan Sebagainya

Mengenai cara memperoleh serial hardisk dan sebagainya. Adapun kodenya seperti terlihat di bawah ini:

Option Explicit 
  
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long 
 
Public Function GetSerialNumber(ByVal sDrive As String) As Long 
    Call GetVolumeInformation(sDrive, vbNullString, 0, GetSerialNumber, ByVal 0&, ByVal 0&, vbNullString, 0) 
End Function 
 
Private Sub Command1_Click() 
    MsgBox Hex$(GetSerialNumber("C:\")) 
End Sub 

READ MORE - VB6 Code: Memperoleh Serial Hardisk dan Sebagainya

VB6 Code - Membuat Cue Banner atau Placeholder Text

Apa yang dimaksud dengan cue banner atau placeholder text atau sebagian menyebutnya dengan watermark text itu? untuk memahaminya perhatikan gambar di bawah ini:

VB6 Cue Banner Placeholder Text Watermark Text

Terlihat pada gambar di atas beberapa objek (ComboBox dan beberapa TextBox) yang memiliki tulisan kurang jelas dengan warna keabu-abuan. Nah, tulisan yang kurang jelas itulah yang dinamakan dengan cue banner/placeholder text/watermark text. Tulisan itu hanya akan muncul apabila objek-objek tersebut memiliki property Text = "" serta dalam keadaan lost focus.

Berikut beberapa bagian kode darinya:

Option Explicit
 
Private Declare Function GetComboBoxInfo Lib "user32" (ByVal hwndCombo As Long, CBInfo As COMBOBOXINFO) 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 Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type COMBOBOXINFO
    cbSize As Long
    rcItem As RECT
    rcButton As RECT
    stateButton  As Long
    hwndCombo  As Long
    hwndEdit  As Long
    hwndList As Long
End Type
 
Private Const ECM_FIRST As Long = &H1500
Private Const EM_SETCUEBANNER As Long = (ECM_FIRST + 1)
 
Public Sub SetCueBanner(obj As Object, str As String)
    Dim s As String
    Dim c As COMBOBOXINFO
    If TypeOf obj Is ComboBox Then
        c.cbSize = Len(c)
        Call GetComboBoxInfo(obj.hwnd, c)
        s = StrConv(str, vbUnicode)
        Call SendMessage(c.hwndEdit, EM_SETCUEBANNER, 0&, ByVal s)
    Else 'TextBox
        s = StrConv(str, vbUnicode)
        Call SendMessage(obj.hwnd, EM_SETCUEBANNER, 0&, ByVal s)
    End If
End Sub

Catatan sangat penting:

1. Cue banner tidak bisa berjalan pada WinXP yang terinstall left to rigth language seperti arabic dsb. Hal tersebut merupakan bug dari Microsoft sendiri, dan telah diperbaiki pada OS selanjutnya.
2. Cue banner hanya akan berjalan setelah dicompile serta diberi manifest (XP Style)

Lebih lengkap mengenai pembuatan cue banner/placeholder text/watermark text bisa Anda download pada tautan di bawah ini:

Download: VB6_CueBanner

READ MORE - VB6 Code - Membuat Cue Banner atau Placeholder Text

Memperoleh Icon Asosiasi File Menggunakan SHFileInfo

Option Explicit

Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_EXETYPE = &H2000
Private Const SHGFI_SYSICONINDEX = &H4000
Private Const SHGFI_LARGEICON = &H0
Private Const SHGFI_SMALLICON = &H1
Private Const ILD_TRANSPARENT = &H1
Private Const SHGFI_SHELLICONSIZE = &H4
Private Const SHGFI_TYPENAME = &H400
Private Const BASIC_SHGFI_FLAGS = SHGFI_TYPENAME Or SHGFI_SHELLICONSIZE Or SHGFI_SYSICONINDEX Or SHGFI_DISPLAYNAME Or SHGFI_EXETYPE

Private Const MAX_PATH = 260

Private Type SHFILEINFO
    hIcon          As Long
    iIcon          As Long
    dwAttributes   As Long
    szDisplayName  As String * MAX_PATH
    szTypeName     As String * 80
End Type

Private Declare Function ImageList_Draw Lib "comctl32.dll" (ByVal himl As Long, ByVal i As Long, ByVal hDCDest As Long, ByVal x As Long, ByVal y As Long, ByVal flags As Long) As Long
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long

Private Sub Form_Load()
    With picDummyPictureBox
        .AutoRedraw = True
        .AutoSize = True
        .Height = 495
        .Width = 495
        .Appearance = 0
        .Visible = False
    End With

    With picInvisiblePictureBox
        .AutoRedraw = True
        .AutoSize = True
        .Height = 495
        .Width = 495
        .Appearance = 0
        .Visible = False
    End With

    rtBox.OLEDropMode = rtfOLEDropManual

    picDummyPictureBox.Picture = LoadPicture("C:\Program Files\Microsoft Visual Studio\Common\Graphics\Icons\Flags\flgusa01.ico")

    Set lvFileList.SmallIcons = Nothing
    ilImages.ListImages.Clear
    ilImages.ListImages.Add , "dummy", picDummyPictureBox.Picture
    Set lvFileList.Icons = ilImages
End Sub

Private Sub rtBox_OLEDragDrop(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)

    Dim nCounter As Integer
    Dim lBoundary As Long

    For nCounter = 1 To Data.Files.Count
        StickIconOntoListView Data.Files(nCounter)
    Next nCounter
End Sub

Private Sub StickIconOntoListView(strFile As String)

    Dim hImgLarge As Long
    Dim hFile As Long
    Dim strFileType As String
    Dim strListImageKey As String
    Dim imgX As ListImage
    Dim hEXEType As Long
    Dim tEXEType As Long
    Dim lRet As Long
    Dim itmX As ListItem
    Dim shinfo As SHFILEINFO

    hImgLarge = SHGetFileInfo(strFile, 0&, shinfo, Len(shinfo), BASIC_SHGFI_FLAGS Or SHGFI_LARGEICON)

    strFileType = LCase(StripNulls(shinfo.szTypeName))

    If hImgLarge > 0 Then
        lRet = vbAddFileItemIcon(hImgLarge, shinfo)

        Set imgX = ilImages.ListImages.Add(, strFile, picInvisiblePictureBox.Picture)
        strListImageKey = strFile
    Else
    End If

    Set itmX = lvFileList.ListItems.Add(, , LCase(strFile))
    itmX.Icon = ilImages.ListImages(strListImageKey).Key

    Set itmX = Nothing
End Sub

Private Function vbAddFileItemIcon(hImage As Long, sInfo As SHFILEINFO) As Long

    Dim lRet As Long

    picInvisiblePictureBox.Picture = LoadPicture()
    lRet = ImageList_Draw(hImage, sInfo.iIcon, picInvisiblePictureBox.hdc, 0, 0, ILD_TRANSPARENT)

    picInvisiblePictureBox.Picture = picInvisiblePictureBox.Image
    picInvisiblePictureBox.Height = 495
    picInvisiblePictureBox.Width = 495

    vbAddFileItemIcon = lRet
End Function

Private Function StripNulls(strItem As String) As String

    Dim nPos As Integer

    nPos = InStr(strItem, Chr$(0))
    If nPos Then
        strItem = Left$(strItem, nPos - 1)
    End If
    StripNulls = strItem
End Function

READ MORE - Memperoleh Icon Asosiasi File Menggunakan SHFileInfo

Contoh Penggunaan Fungsi API SetCapture and WindowFromPoint

Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINT
    X As Long
    Y As Long
End Type

Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Sub ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINT)
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex&) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Boolean
Private Declare Function WindowFromPoint Lib "user32" (ByVal ptY As Long, ByVal ptX As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex&) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle&, ByVal nWidth&, ByVal crColor&) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject&) As Long
Private Declare Function SetROP2 Lib "gdi32" (ByVal hdc As Long, ByVal nDrawMode As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc&, ByVal X1&, ByVal Y1&, ByVal X2&, ByVal Y2&) As Long
Private Declare Sub InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any, ByVal bErase As Long)
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance&, ByVal lpCursor&) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Private Const IDC_UPARROW = 32516&

Public mlngHwndCaptured As Long

Private Sub Form_MouseDown(Button%, Shift%, X As Single, Y As Single)
    If SetCapture(hwnd) Then MousePointer = vbUpArrow
End Sub

Private Sub Form_MouseMove(Button%, Shift%, X As Single, Y As Single)
    Dim pt As POINT
    Static hWndLast As Long

    If GetCapture() Then

        pt.X = CLng(X)
        pt.Y = CLng(Y)
        ClientToScreen Me.hwnd, pt

        mlngHwndCaptured = WindowFromPoint(pt.X, pt.Y)

        If hWndLast <> mlngHwndCaptured Then
            If hWndLast Then InvertTracker hWndLast
            InvertTracker mlngHwndCaptured
            hWndLast = mlngHwndCaptured
        End If
    End If
End Sub

Private Sub Form_MouseUp(Button%, Shift%, X As Single, Y As Single)
    Dim strCaption$

    If mlngHwndCaptured Then

        strCaption = Space(1000)
        Caption = Left(strCaption, GetWindowText(mlngHwndCaptured, strCaption, Len(strCaption)))

        InvalidateRect 0, 0, True

        mlngHwndCaptured = False
        MousePointer = vbNormal
    End If
End Sub

Private Sub InvertTracker(hwndDest As Long)
    Dim hdcDest&, hPen&, hOldPen&, hOldBrush&
    Dim cxBorder&, cxFrame&, cyFrame&, cxScreen&, cyScreen&
    Dim rc As RECT, cr As Long
    Const NULL_BRUSH = 5
    Const R2_NOT = 6
    Const PS_INSIDEFRAME = 6

    cxScreen = GetSystemMetrics(0)
    cyScreen = GetSystemMetrics(1)
    cxBorder = GetSystemMetrics(5)
    cxFrame = GetSystemMetrics(32)
    cyFrame = GetSystemMetrics(33)

    GetWindowRect hwndDest, rc

    hdcDest = GetWindowDC(hwndDest)

    SetROP2 hdcDest, R2_NOT
    cr = RGB(0, 0, 0)
    hPen = CreatePen(PS_INSIDEFRAME, 3 * cxBorder, cr)

    hOldPen = SelectObject(hdcDest, hPen)
    hOldBrush = SelectObject(hdcDest, GetStockObject(NULL_BRUSH))
    Rectangle hdcDest, 0, 0, rc.Right - rc.Left, rc.Bottom - rc.Top
    SelectObject hdcDest, hOldBrush
    SelectObject hdcDest, hOldPen

    ReleaseDC hwndDest, hdcDest
    DeleteObject hPen
End Sub

Private Sub Form_Load()

    Move 0, 0, 250 * Screen.TwipsPerPixelX, 75 * Screen.TwipsPerPixelY
    Caption = "Click & drag the arrow!"

    ScaleMode = vbPixels
    AutoRedraw = True

    DrawIcon hdc, (ScaleWidth / 2), 9, LoadCursor(0, IDC_UPARROW)
End Sub

READ MORE - Contoh Penggunaan Fungsi API SetCapture and WindowFromPoint

PrintWindow - Capture Form Beserta Seluruh Objeknya

Option Explicit

Private Declare Function PrintWindow Lib "user32" (ByVal hwnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long

Private Sub Command2_Click()
    Picture1.AutoRedraw = True
    Set Picture1.Picture = Nothing
    PrintWindow Me.hwnd, Picture1.hDC, 0
    Picture1.Refresh
End Sub

READ MORE - PrintWindow - Capture Form Beserta Seluruh Objeknya

Membuat Aplikasi Console Sederhana Menggunakan VB6

Option Explicit
'
'Reference to Microsoft Scripting Runtime.
'

Public SIn As Scripting.TextStream
Public SOut As Scripting.TextStream

'--- Only required for testing in IDE or Windows Subsystem ===
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function GetConsoleTitle Lib "kernel32" _
    Alias "GetConsoleTitleA" ( _
    ByVal lpConsoleTitle As String, _
    ByVal nSize As Long) As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long

Private Allocated As Boolean

Private Sub Setup()
    Dim Title As String

    Title = Space$(260)
    If GetConsoleTitle(Title, 260) = 0 Then
        AllocConsole
        Allocated = True
    End If
End Sub

Private Sub TearDown()
    If Allocated Then
        SOut.Write "Press enter to continue..."
        SIn.ReadLine
        FreeConsole
    End If
End Sub
'--- End testing ---------------------------------------------

Private Sub Main()
    Setup 'Omit for Console Subsystem.

    With New Scripting.FileSystemObject
        Set SIn = .GetStandardStream(StdIn)
        Set SOut = .GetStandardStream(StdOut)
    End With

    SOut.WriteLine "Any output you want"
    SOut.WriteLine "Goes here"

    TearDown 'Omit for Console Subsystem.
End Sub

READ MORE - Membuat Aplikasi Console Sederhana Menggunakan VB6

Contoh Fungsi API GetTickCount Dalam VB6

Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Sub Command1_Click()

    Dim StartTime As Long
    Dim EndTime As Long
    Dim M As Long
    Dim K As Long
    Dim X As Double


    For M = 1 To 10

        StartTime = GetTickCount

        For K = 1 To 10000000
            X = X * 1.01
            X = X / 1.01
        Next K

        EndTime = GetTickCount

        List1.AddItem EndTime - StartTime
        DoEvents

    Next M

End Sub

READ MORE - Contoh Fungsi API GetTickCount Dalam VB6

Memberi Batas Minimal - Maksimal Sebuah Aplikasi - VB6

Merancang sebuah interface yang baik, terkadang tidak semudah yang dibayangkan (download codejock dan selesai). Beberapa hal yang sering diutamakan diantaranya, tampilan yang menarik, kemudahan akses (dapat digunakan secara sempurna tanpa menggunakan mouse), navigasi antar form yang mudah dan tidak membingungkan, pemilihan ActiveX Third Party yang memiliki kualitas kode yang baik (tidak mengandung bug atau mudah crash), dsb (banyak). Nah, diantara sekian yang banyak itu salah satunya adalah memberi batas minimal ukuran sebuah aplikasi. Di bawah ini merupakan modul untuk memberi batas minimal sebuah aplikasi, sumber kodenya dari Microsoft.

Option Explicit 
 
Private Const GWL_WNDPROC = -4 
Private Const WM_GETMINMAXINFO = &H24 
 
Private Type POINTAPI 
    X As Long 
    Y As Long 
End Type 
 
Private Type MINMAXINFO 
    ptReserved As POINTAPI 
    ptMaxSize As POINTAPI 
    ptMaxPosition As POINTAPI 
    ptMinTrackSize As POINTAPI 
    ptMaxTrackSize As POINTAPI 
End Type 
 
Global lpPrevWndProc As Long 
Global gHW As Long 
 
Private Declare Function DefWindowProc Lib "user32" Alias _ 
   "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, _ 
    ByVal wParam As Long, ByVal lParam As Long) As Long 
Private Declare Function CallWindowProc Lib "user32" Alias _ 
   "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _ 
    ByVal hwnd As Long, ByVal Msg As Long, _ 
    ByVal wParam As Long, ByVal lParam As Long) As Long 
Private Declare Function SetWindowLong Lib "user32" Alias _ 
   "SetWindowLongA" (ByVal hwnd As Long, _ 
    ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 
Private Declare Sub CopyMemoryToMinMaxInfo Lib "kernel32" Alias _ 
   "RtlMoveMemory" (hpvDest As MINMAXINFO, ByVal hpvSource As Long, _ 
    ByVal cbCopy As Long) 
Private Declare Sub CopyMemoryFromMinMaxInfo Lib "kernel32" Alias _ 
   "RtlMoveMemory" (ByVal hpvDest As Long, hpvSource As MINMAXINFO, _ 
    ByVal cbCopy As Long) 
 
Public Sub Hook() 
    'Start subclassing. 
    lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, _ 
       AddressOf WindowProc) 
End Sub 
 
Public Sub Unhook() 
    Dim temp As Long 
 
    'Cease subclassing. 
    temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc) 
End Sub 
 
Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, _ 
   ByVal wParam As Long, ByVal lParam As Long) As Long 
    Dim MinMax As MINMAXINFO 
 
    'Check for request for min/max window sizes. 
    If uMsg = WM_GETMINMAXINFO Then 
        'Retrieve default MinMax settings 
        CopyMemoryToMinMaxInfo MinMax, lParam, Len(MinMax) 
 
        'Specify new minimum size for window. 
        MinMax.ptMinTrackSize.X = 750 'untuk ukuran minimal aplikasi 
        MinMax.ptMinTrackSize.Y = 550 
 
        'Specify new maximum size for window. 
'              MinMax.ptMaxTrackSize.x = 900 'untuk ukuran maksimal aplikasi 
'              MinMax.ptMaxTrackSize.y = 600 
 
        'Copy local structure back. 
        CopyMemoryFromMinMaxInfo lParam, MinMax, Len(MinMax) 
 
        WindowProc = DefWindowProc(hw, uMsg, wParam, lParam) 
    Else 
        WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, _ 
           wParam, lParam) 
    End If 
End Function 

Contoh penggunaan pada MDI form:

Private Sub MDIForm_Load() 
    gHW = Me.hwnd 'Save handle to the form. 
    Hook 'Begin subclassing. 
End Sub 
 
Private Sub MDIForm_Unload(Cancel As Integer) 
    Unhook 'Stop subclassing. 
End Sub 

Catatan penting: karena menggunakan teknik subclassing, tempatkan kode di atas setelah aplikasi selesai dibuat (final), pastikan seluruh kode berjalan dengan baik, pastikan pula seluruh error terhandle dengan baik. Mengapa? CRASH! dan kita akan kesulitan mentrace dan mendebug aplikasi yang sedang kita buat.

READ MORE - Memberi Batas Minimal - Maksimal Sebuah Aplikasi - 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

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

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 

READ MORE - Mendapatkan Special Folder Menggunakan Visual Basic 6.0

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 

READ MORE - Fungsi Untuk Menjadikan Blank Layar Komputer

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 "winmm.dll" ) 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 

READ MORE - Memeriksa Keberadaan Sound Card Pada Komputer

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 

READ MORE - Menampilkan Browse For Folder Menggunakan Fungsi API

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 

READ MORE - Menampilkan Dialog Properties Sebuah File

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 

READ MORE - Menjalankan Screen Saver Melalui Pemrograman

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 

READ MORE - Fungsi Untuk Memeriksa Apakah Screen Saver Enable