Showing posts with label API-VB6. Show all posts

Monday, May 28, 2012

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

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

Menampilkan Kotak Dialog ShutDown Menggunakan Fungsi API

Di bawah ini merupakan fungsi API untuk menampilkan kotak dialog shutdown. Fungsi yang digunakan adalah SHShutDownDialog yang terdapat pada Shell32.dll.

Option Explicit 
 
Private Declare Function SHShutDownDialog Lib "shell32" Alias "#60" (ByVal sParam As Long) As Long

Contoh penggunaan fungsi API di atas:

Private Sub Command1_Click() 
    SHShutDownDialog 0 
End Sub

Menampilkan Kotak Dialog ShutDown Menggunakan Fungsi API

Di bawah ini merupakan fungsi API untuk menampilkan kotak dialog shutdown. Fungsi yang digunakan adalah SHShutDownDialog yang terdapat pada Shell32.dll.

Option Explicit 
 
Private Declare Function SHShutDownDialog Lib "shell32" Alias "#60" (ByVal sParam As Long) As Long

Contoh penggunaan fungsi API di atas:

Private Sub Command1_Click() 
    SHShutDownDialog 0 
End Sub

Fungsi Untuk Memeriksa Resolusi Screen

Di bawah ini merupakan fungsi untuk mengetahui resolusi screen. Bagaimana implementasinya dalam Visual Basic 6.0? bisa kita simak kodenya di bawah ini:

Option Explicit 
Public Function ScreenResolution(iWidth, iHeight) As String 
    iWidth = Screen.Width � Screen.TwipsPerPixelX 
iHeight = Screen.Height � Screen.TwipsPerPixelY 
ScreenResolution = "Screen Resolution:" + vbCrLf + vbCrLf + Str$(iWidth) + " x" + Str$(iHeight) 
End Function

Contoh penggunaan fungsi di atas:

Private Sub Command1_Click() 
    Dim intWidth As Integer 
    Dim intHeight As Integer 
    MsgBox ScreenResolution(intWidth, intHeight) 
MsgBox intWidth 
MsgBox intHeight 
End Sub

Fungsi Mengubah Object LeftToRigth Menjadi RightToLeft

Di bawah ini merupakan fungsi untuk mengubah objek yang tidak memiliki properties LeftToRight agar seolah-olah memiliki properties tersebut. Melalui akal-akalan fungsi API, hal tersebut mungkin untuk dilakukan.

Option Explicit 
 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 'TreeView1 RightToLeft True 
 
Private Const WS_EX_LAYOUTRTL = 4194304 
Private Const GWL_EXSTYLE = -20 
 
Public Sub ctlRightToLeft(ctl As   Control) 
    SetWindowLong ctl.hWnd, GWL_EXSTYLE, WS_EX_LAYOUTRTL 
End Sub

Contoh penggunaan fungsi di atas:

Private Sub Command1_Click() 
    ctlRightToLeft TreeView1 
    TreeView1.Appearance = cc3D 
    TreeView1.BorderStyle = ccFixedSingle 
    TreeView1.Refresh 
End Sub

Coba Anda ganti objeknya misalnya menggunakan Progress Bar, kemudian lihat apa yang terjadi?

Mencari Aplikasi Asosiasi Sebuah File

Di bawah ini merupakan fungsi untuk mencari aplikasi yang diasosiasikan terhadap sebuah file. Bingung? misalnya kita double klik file berektensi .ini maka aplikasinya notepad.exe, double klik file berektensi .doc maka aplikasinya Microsoft Word, dst.

Option Explicit 
 
Private Declare Function FindExecutableA Lib "shell32.dll" (ByVal lpFile As String, ByVal lpdirectory As String, ByVal lpResult As String) As Long 
Private Const MAX_FILENAME_LEN = 256 
 
Public Function FindExecutable(FileName As String) As String 
   Dim iReturn As Integer 
   Dim sResults As String   
 
   sResults = String(MAX_FILENAME_LEN, 32) & Chr$(0) 
 
   iReturn = FindExecutableA(FileName & Chr$(0), vbNullString, sResults) 
 
   If iReturn > 32 Then 
      FindExecutable = Left$(sResults, InStr(sResults, Chr$(0)) - 1) 
   Else 
      FindExecutable = "" 
   End If 
End Function

Contoh penggunaan fungsi untuk mencari assosiasi sebuah file

Private Sub Form_Load() 
    MsgBox FindExecutable("c:\boot.ini") 
End Sub

Memindahkan File Ke Recycle Bin

Di bawah ini merupakan procedure untuk memindahkan/menghapus file ke dalam recycle bin. Bagaimana kodenya dalam Visual Basic 6.0? bisa kita simak di bawah ini:

Option Explicit 
 
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long 
 
Private Type SHFILEOPSTRUCT 
    hwnd As Long 
    wFunc As Long 
    pFrom As String 
    pTo As String 
    fFlags As Integer 
    fAnyOperationsAborted As Long 
    hNameMappings As Long 
      lpszProgressTitle As Long 
End Type 
 
Private Const FO_DELETE = &H3 
Private Const FOF_ALLOWUNDO = &H40 
Private Const FOF_NOCONFIRMATION = &H10 
Private Const FOF_SILENT = &H4 
 
Public Sub SendFileToRecycleBin(FileName As String, Optional Confirm As Boolean = True, Optional Silent As Boolean = False) 
    Dim FileOp As SHFILEOPSTRUCT 
 
    With FileOp 
        .wFunc = FO_DELETE 
        .pFrom = FileName 
        .fFlags = FOF_ALLOWUNDO 
        If Not Confirm Then .fFlags = .fFlags + FOF_NOCONFIRMATION 
        If Silent Then .fFlags = .fFlags + FOF_SILENT 
    End With 
    SHFileOperation FileOp 
End Sub

Contoh penggunaan procedure di atas

Private Sub Command1_Click() 
    SendFileToRecycleBin "c:\42.tmp", True, False   
End Sub

Menghapus Seluruh File Yang Ada Dalam Recycle Bin

Di bawah ini merupakan fungsi untuk menghapus seluruh file yang terdapat pada recycle bin. Bagaimana implementasinya dalam Visual Basic 6.0? bisa Anda simak kodenya di bawah ini

Option Explicit 
 
Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" (ByVal hWnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long 
Const SHERB_NOCONFIRMATION = &H1 
Const SHERB_NOPROGRESSUI = &H2 
Const SHERB_NOSOUND = &H4 
 
Public Sub EmptyRecycleBin(frm As Form) 
    Dim RetVal 
    RetVal = SHEmptyRecycleBin(frm.hWnd, "", SHERB_NOPROGRESSUI + SHERB_NOCONFIRMATION) 
End Sub

Contoh pengunaan procedure di atas

Private Sub Command1_Click() 
    EmptyRecycleBin Me 
End Sub

Menghapus Seluruh File Recent Document

Di bawah ini merupakan procedure untuk menghapus seluruh yang terdapat pada recent document. Untuk keperluan ini digunakan satu fungsi API yakni SHAddToRecentDocs yang terdapat pada shell32.dll.

Option Explicit 
 
Private Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long, ByVal pv As Any) 
 
Sub EmptyRecentDocument() 
   SHAddToRecentDocs 0, CLng(0) 
End Sub

Contoh penggunaan procedure di atas

Private Sub Command1_Click() 
    EmptyRecentDocument 
End Sub

Fungsi Untuk Memeriksa Apakah Recycle Bin Kosong?

Di bawah ini merupakan fungsi untuk memeriksa apakah recycle bin kosong? Bagaimana implementasinya dalam Visual Basic 6.0? bisa Anda simak kodenya dibawah ini:

Option Explicit 
 
Private Type SHQUERYRBINFO 
    cbSize As Long 
    i64SizeLo As Long 
    i64SizeHi As Long 
    i64NumItemsLo As Long 
    i64NumItemsHi As Long 
End Type 
 
Private Declare Function SHQueryRecycleBin Lib "shell32" Alias "SHQueryRecycleBinA" (ByVal pszRootPath As String, pSHQueryRBInfo As SHQUERYRBINFO) As Long 
 
Function IsEmptyRecycle() As Boolean 
    Dim RB As SHQUERYRBINFO 
    RB.cbSize = Len(RB) 
    Call SHQueryRecycleBin("C:\", RB) 
    IsEmptyRecycle = (RB.i64NumItemsLo = 0) 
End Function

Contoh penggunaan fungsi di atas

Private Sub Command1_Click() 
    MsgBox IsEmptyRecycle 
End Sub

Membuat Efek Bayangan Pada Objek

Di bawah ini merupakan fungsi untuk membuat efek bayangan pada sebuah objek. Bagaimana implementasi dalam Visual Basic 6.0? bisa Anda simak kodenya di bawah ini:

Option Explicit 
 
Public Function Shadow(frm As Form, ctl As Control, Optional shWidth = 3, Optional Color = vbGrayed) 
    Dim oldWidth As Integer 
    Dim oldScale As Integer 
 
    With frm 
        oldWidth = .DrawWidth 
        oldScale = .ScaleMode 
        .ScaleMode = 3 
          .DrawWidth = 1 
        frm.Line (ctl.Left + shWidth, ctl.Top + shWidth)-Step(ctl.Width - 1, ctl.Height - 1), Color, BF 
        .DrawWidth = oldWidth 
        .ScaleMode = oldScale 
    End With 
 
End Function

Contoh penggunaan fungsi membuat efek bayangan pada objek

Private Sub Command1_Click() 
    Shadow Me, Command1, 2, vbBlack 
End Sub

Anda dapat menggunakannya pada objek secara bulk dengan menggunakan for...each.

Procedure Untuk Menambahkan File Ke Recent Document

Di bawah ini merupakan procedure untuk menambahkan file ke recent document. Untuk keperluan ini digunakan satu fungsi API yakni SHAddToRecentDocs yang terdapat pada shell32.dll.

Option Explicit 
 
Private Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long, ByVal pv As String) 
 
Public Function AddToRecentDocument(FileName As String) 
  Call SHAddToRecentDocs(3, FileName) 
End Function

Cara menggunakan Fungsi Menambahkan Nama File Ke Recent Documents

Private Sub Command1_Click() 
    AddToRecentDocument "C:\boot.ini" 
End Sub

Mencegah Aplikasi Dijalankan Dua Kali

Di bawah ini merupakan fungsi kedua masih mengenai cara mencegah aplikasi dijalankan dua kali. Bagaimana implementasinya dalam Visual Basic 6.0? bisa Anda simak kodenya di bawah ini:

Option Explicit 
 
Declare Function OpenIcon Lib "user32" (ByVal hWnd As Long) As Long 
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 
Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long 
Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long 
 
Public Const GW_HWNDPREV = 3 
 
Sub ActivatePrevInstance() 
 
    Dim AppTitle As String 
    Dim PrevHndl As Long 
    Dim result As Long 
 
    AppTitle = App.Title 
    App.Title = "unwanted instance" 
 
    If PrevHndl = 0 Then 
        PrevHndl = FindWindow("ThunderRT6Main", AppTitle) 
        If PrevHndl <> 0 Then 
            PrevHndl = GetWindow(PrevHndl, GW_HWNDPREV) 
            result = OpenIcon(PrevHndl) 
            result = SetForegroundWindow(PrevHndl) 
            End 
        End If 
    End If 
 
End Sub

Contoh penggunaan:

Private Sub Form_Load() 
    If App.PrevInstance Then ActivatePrevInstance 
End Sub

Class CRC32 Sebuah File - VB6 Code

Di bawah ini merupakan class untuk mengetahui CRC32 dari sebuah file. Untuk keperluan ini copy dan pastekan kode di bawah ini ke dalam class, kemudian ganti nama kelasnya menjadi clsCRC.

Option Explicit 
 
Private crcTable(0 To 255) As Long 'crc32 
 
Private Function CRC32(ByRef bArrayIn() As Byte, ByVal lLen As Long, Optional ByVal lcrc As Long = 0) As Long 
 
    Dim lCurPos As Long 
    Dim lTemp As Long 
 
    If lLen = 0 Then Exit Function 'In case of empty file 
    lTemp = lcrc Xor &HFFFFFFFF 'lcrc is for current value from partial check on the partial array 
 
    For lCurPos = 0 To lLen 
        lTemp = (((lTemp And &HFFFFFF00) \ &H100) And &HFFFFFF) Xor (crcTable((lTemp And 255) Xor bArrayIn(lCurPos))) 
    Next lCurPos 
 
    CRC32 = lTemp Xor &HFFFFFFFF 
 
End Function 
 
Private Function BuildTable() As Boolean 
 
    Dim I As Long, x As Long, crc As Long 
    Const Limit = &HEDB88320 'usally its shown backward, cant remember what it was. 
 
    For I = 0 To 255 
        crc = I 
        For x = 0 To 7 
            If crc And 1 Then 
                crc = (((crc And &HFFFFFFFE) \ 2) And &H7FFFFFFF) Xor Limit 
            Else 
                crc = ((crc And &HFFFFFFFE) \ 2) And &H7FFFFFFF 
            End If 
        Next x 
        crcTable(I) = crc 
    Next I 
 
End Function 
 
Private Sub Class_Initialize() 
    BuildTable 
End Sub 
 
Public Function CekCRC32(FileName As String) As String 
 
    Dim lngCrc As Long 
    Dim sCrc As Long 
 
    On Error GoTo ErrHandler 
 
    Open FileName For Binary Access Read As #1 
    ReDim tmp(LOF(1)) As Byte 
    Get #1, , tmp() 
    Close #1 
 
    lngCrc = UBound(tmp) 
    lngCrc = CRC32(tmp, lngCrc) 
    CekCRC32 = Hex(lngCrc) 
 
    Exit Function 
 
    ErrHandler: 
 
    MsgBox Err.Description, vbCritical, "Error" 
 
End Function

Contoh penggunaan Class CRC32

Option Explicit 
 
Private Sub Form_Load() 
    Dim crc As New clsCRC 
    MsgBox crc.CekCRC32("C:\boot.ini") 
End Sub

Menggerakan Pointer Mouse Pada Koordinat Tertentu

Di bawah ini merupakan fungsi untuk menggerakan pointer mouse pada koordinat tertentu.

Private Declare Function SetCursorPos Lib "User32" ByVal X As Long, ByVal Y As Long) As Long 
'Contoh penggunaan code untuk menggerakan pointer mouse pada koordinat tertentu 
Private Sub Command1_Click() 
    Call SetCursorPos(100, 200) 
End Sub

Menutup Seluruh Aplikasi Yang Sedang Berjalan

Di bawah ini merupakan fungsi untuk menutup seluruh aplikasi yang sedang berjalan. Mengapa seluruh aplikasi yang sedang berjalan tersebut harus ditutup? contoh kecilnya dalam pembuatan billing warnet. Misalnya A (user) log-out, kemudian datang B (user baru) log-in, B tidak akan melihat aplikasi-aplikasi yang masih terbuka (kemungkinan lupa ditutup oleh A), karena seluruh aplikasi yang sedang berjalan telah ditutup secara otomatis dengan fungsi di bawah ini.
Mungkin ada pertanyaan, Apakah ditutup dengan software billing warnetnya juga? ya, boleh jika kita mau, bahkan sekalian di shutdown pula.

Option Explicit 
 
Public Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, _ 
ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long 
Public Declare Function IsWindowVisible& Lib "user32" (ByVal hwnd As Long) 
Public Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long 
Public Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long 
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As   String, ByVal lpsz2 As String) As Long 
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long 
Public Declare Function TerminateProcess& Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) 
Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long 
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long 
   
Public Const SMTO_BLOCK = &H1 
Public Const SMTO_ABORTIFHUNG = &H2 
Public Const SC_CLOSE = &HF060& 
Public Const WM_SYSCOMMAND = &H112 
Public Const WM_NULL = &H0 
Public Const PROCESS_ALL_ACCESS = &H1F0FFF 
 
Public HWND_Taskbar As Long 
Public HWND_Desktop As Long 
Public HWND_ExplorerW As Long 
 
Public Function EnumWindowsProc(ByVal hwnd As Long, ByVal lParam As Long) As Long 
 
    Dim lThreadID As Long 
    Dim lPid As Long 
    Dim lHp As Long 
 
    If hwnd <> HWND_Taskbar And hwnd <> HWND_Desktop And hwnd <> HWND_ExplorerW Then 
    lThreadID = GetWindowThreadProcessId(hwnd, lPid) 
        If lThreadID <> App.ThreadID Then 
            If IsWindowVisible(hwnd) Then 
                SendMessageTimeout hwnd, WM_SYSCOMMAND, SC_CLOSE, 0, 0, 500, 0 
                If IsWindow(hwnd) Then 
                      lHp = OpenProcess(PROCESS_ALL_ACCESS, 0&, lPid) 
                    TerminateProcess lHp&, 0& 
                    CloseHandle lHp 
                End If 
            End If 
        End If 
    End If 
 
    EnumWindowsProc = 1 
 
End Function 
 
Public Sub CloseAllRuning() 
    HWND_Desktop = FindWindowEx(0&, 0&, "Progman", vbNullString) 
    HWND_Taskbar = FindWindowEx(0&, 0&, "Shell_TrayWnd", vbNullString) 
    EnumWindows AddressOf EnumWindowsProc, 0&   
End Sub

Contoh Penggunaan fungsi untuk menutup seluruh aplikasi

Sub Main() 
      Call CloseAllRuning 
End Sub

Subscribe to: Posts ( Atom )

Khoiriyyah - Syair Arab Visual Basic 6.0 Blogging

Monday, May 28, 2012

Berapa Lama Windows Telah Dijalankan

Fungsi Shutdown, Restart, Log-Off Dan Sebagainya

Fungsi VB6 - Untuk Memperoleh Time Out Screen Saver

VB6 Code - Fungsi Untuk Merubah Desktop Wallpaper

Sunday, May 27, 2012

Menyembunyikan Dan Menampilkan Windows Taskbar

Menampilkan Kotak Dialog ShutDown Menggunakan Fungsi API

Menampilkan Kotak Dialog ShutDown Menggunakan Fungsi API

Fungsi Untuk Memeriksa Resolusi Screen

Fungsi Mengubah Object LeftToRigth Menjadi RightToLeft

Mencari Aplikasi Asosiasi Sebuah File

Memindahkan File Ke Recycle Bin

Menghapus Seluruh File Yang Ada Dalam Recycle Bin

Menghapus Seluruh File Recent Document

Fungsi Untuk Memeriksa Apakah Recycle Bin Kosong?

Membuat Efek Bayangan Pada Objek

Procedure Untuk Menambahkan File Ke Recent Document

Mencegah Aplikasi Dijalankan Dua Kali

Class CRC32 Sebuah File - VB6 Code

Menggerakan Pointer Mouse Pada Koordinat Tertentu

Menutup Seluruh Aplikasi Yang Sedang Berjalan

Perhatian

Page Rank

Online

Statistik Pengunjung

embrio9 - Auto Reply

Blog Archive

Visual Basic 6.0

Arabic

Blogging

Miscellaneous