Showing posts with label API-VB6. Show all posts
Showing posts with label API-VB6. Show all posts

Friday, July 19, 2013

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

Wednesday, July 10, 2013

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.

Tuesday, July 9, 2013

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

Monday, July 1, 2013

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

Wednesday, April 17, 2013

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

Sunday, June 17, 2012

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

Tuesday, June 12, 2012

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

Friday, June 8, 2012

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

Tuesday, May 29, 2012

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

Monday, May 28, 2012

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 &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
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