Showing posts with label File-And-Folder. Show all posts

Sunday, June 17, 2012

Membaca File Binary Dengan Visual Basic 6.0

Option Explicit

Private Sub Command1_Click()
    Open "C:\Documents and Settings\Admin\My Documents\Blogger VB6\Blogger\4basic-vb.xml" For Binary As #1
        Dim strBuff As String
        strBuff = Space(LOF(1))
        Get #1, , strBuff
    Close #1
    Text1.Text = strBuff
End Sub

Cara Mudah Baca File Dan Menyimpannya Dalam Array

Option Explicit

Private Sub Command1_Click()
    Dim strArray() As String
    Open "c:\autoexec.bat" For Input As #1
        strArray = Split(Input(LOF(1), 1), vbCrLf)
    Close #1
End Sub

Tutorial File - Membaca, Menghapus Baris Tertentu, dsb

'Kode ini dibuat oleh plenderj salah satu member VBForums
'http://www.vbforums.com/showthread.php?s=&threadid=132171

' Clear the contents of a file
Private Sub clearFile(ByVal strPath As String)
    If Not Len(Dir(strPath)) = 0 Then
        Open strPath For Output As #1
        Close #1
    End If
End Sub

' Is a given string contained within a given file ?
Private Function isStringInFile(ByVal strString As String, ByVal strFile As String) As Boolean
    isStringInFile = InStr(returnContents(strFile), strString) <> 0
End Function

' Delete a specific line from a file (note: first line = line number 0)
Private Sub deleteLine(ByVal strFile As String, ByVal lineNumber As Long)
    Dim strArrBuff() As String, i As Long
    Open strFile For Input As #1
        strArrBuff() = Split(Input(LOF(1), 1), vbCrLf)
    Close #1
    Open strFile For Output As #1
        For i = 0 To UBound(strArrBuff)
            If Not i = lineNumber Then Print #1, strArrBuff(i)
        Next
    Close #1
End Sub

' Return a specific line number from a file (note: first line = line number 0)
Private Function getLine(ByVal strFile As String, ByVal lineNumber As Long) As String
    Open strFile For Input As #1
        getLine = Split(Input(LOF(1), 1), vbCrLf)(lineNumber)
    Close #1
End Function

' Append a line to the end of a file
Private Sub appendLine(ByVal strFile As String, ByVal strLineOfText As String)
    Open strFile For Append As #1
        Print #1, strLineOfText
    Close #1
End Sub

' Insert a line of text in a file
Private Sub insertLine(ByVal strFile As String, ByVal lineNumber As Long, ByVal strLineOfText As String)
    Dim strBuff() As String: strBuff = Split(returnContents(strFile), vbCrLf)
    Dim i As Long
    Open strFile For Output As #1
        For i = 0 To UBound(strBuff)
            If i = lineNumber Then Print #1, strLineOfText
            Print #1, strBuff(i)
        Next
    Close #1
End Sub

' Insert a string of text in a file
Private Sub insertString(ByVal strFile As String, ByVal writePosition As Long, ByVal strStringOfText As String)
    Dim strBuff As String: strBuff = returnContents(strFile)
    Open strFile For Output As #1
        Print #1, Left(strBuff, writePosition) & strStringOfText & Mid(strBuff, writePosition)
    Close #1
End Sub

' Return the contents of a file
Private Function returnContents(ByVal strFile As String) As String
    Open strFile For Input As #1
        returnContents = Input(LOF(1), 1)
    Close #1
End Function

' Return the path of a given full path to a file
Private Function returnPathOfFile(ByVal strFile As String) As String
    returnPathOfFile = Left(strFile, InStrRev(strFile, "\"))
End Function

' Return the filename of a given full path to a file
Private Function returnNameOfFile(ByVal strFile As String) As String
    returnNameOfFile = Mid(strFile, InStrRev(strFile, "\") + 1)
End Function

' Split a file up into n byte chunks
Private Sub splitUpFile(ByVal strFile As String, ByVal nByteSize As Long)
    Dim strBuff As String: strBuff = returnContents(strFile)
    Dim currPos As Long, endPos As Long: currPos = 1: endPos = Len(strBuff)
    Dim fileNumber As Long
    While currPos <= endPos
        Open Left(strFile, InStrRev(strFile, ".") - 1) & "(" & fileNumber & ")" & Mid(strFile, InStrRev(strFile, ".")) For Output As #1
            If (currPos + nByteSize) > endPos Then
                Print #1, Mid(strBuff, currPos)
            Else
                Print #1, Mid(strBuff, currPos, nByteSize)
            End If
        Close #1
        fileNumber = fileNumber + 1
        currPos = currPos + nByteSize
    Wend
End Sub

' Merge a number of source files into a destination file
Private Sub mergeFiles(ByVal strDestinationFile As String, ParamArray strSourceFiles())
    Dim i As Long, strBuff As String
    Open strDestinationFile For Output As #1
        For i = 0 To UBound(strSourceFiles)
            Print #1, ""
            Print #1, "***"
            Print #1, "*** " & strSourceFiles(i)
            Print #1, "***"
            Print #1, returnContents(strSourceFiles(i))
        Next
    Close #1
End Sub

Membaca File Dan Memasukannya Ke Dalam Array

Option Explicit

Private Sub Command1_Click()
    
    Dim L As Long
    Dim MyArray() As String
    
    ' Load file into string array
    FileToArray "C:\TEST.txt", MyArray
    
    ' Reverse array contents
    ReverseStrArray MyArray
    
    ' show result in immediate window
    For L = 0 To UBound(MyArray)
        Debug.Print MyArray(L)
    Next L
    
End Sub

Private Sub FileToArray(ByVal sPath As String, ByRef sArray() As String)
    Dim ff As Integer
    ff = FreeFile
    On Error GoTo Fini
    Open sPath For Input As #ff
    sArray = Split(Input(LOF(ff), ff), vbCrLf)
Fini:
    Close #ff
End Sub

Private Sub ReverseStrArray(ByRef sArray() As String)
    Dim ubnd As Long, lbnd As Long, x As Long
    Dim sTmp As String
    ubnd = UBound(sArray)
    lbnd = LBound(sArray)
    For x = lbnd To ((ubnd - lbnd - 1) \ 2)
      sTmp = sArray(lbnd + x)
      sArray(lbnd + x) = sArray(ubnd - x)
      sArray(ubnd - x) = sTmp
    Next x
End Sub

Membaca File Binary atau Text Dengan Cepat

'Kode ini dibuat oleh plenderj salah satu member VBForums
'http://www.vbforums.com/showthread.php?s=&threadid=132171

' Return a specific line number from a file (note: first line = line number 0)
Private Function getLine(ByVal strFile As String, ByVal lineNumber As Long) As String
    Dim strBuff As String
    Open strFile For Binary As #1
        strBuff = Space(LOF(1))
        Get #1, , strBuff
        getLine = Split(strBuff, vbCrLf)(lineNumber)
    Close #1
End Function

' Return a specific line number from a file (note: first line = line number 0) - a neater version.
Private Function getLine(ByVal strFile As String, ByVal lineNumber As Long) As String
    getLine = Split(returnContents(strFile), vbCrLf)(lineNumber)
End Function

' Delete a specific line from a file (note: first line = line number 0)
Private Sub deleteLine(ByVal strFile As String, ByVal lineNumber As Long)
    Dim strArrBuff() As String, i As Long, strFileContent As String
    strArrBuff() = Split(returnContents(strFile), vbCrLf)
    strArrBuff(lineNumber) = vbNullString
    Open strFile For Output As #1
        Print #1, Join(strArrBuff, vbCrLf);
    Close #1
End Sub

' Return the contents of a file
Private Function returnContents(ByVal strFile As String) As String
    Dim strBuff As String
    Open strFile For Binary As #1
        strBuff = Space(LOF(1))
        Get #1, , strBuff
        returnContents = strBuff
    Close #1
End Function

Custom File Untuk Keperluan Import Database

''Gunakan editor terbaik dari Microsoft yakni Notepad
''Tulis seperti di bawah ini
'1, Description 1 ,1,100.00,3/1/1998
'2, Description 2 ,2,200.00,3/2/1998
'Simpan dengan nama c:\test.txt.

Private Sub Command1_Click()
    Dim F As Long, sLine As String, A(0 To 4) As String
    Dim db As Database, rs As Recordset
    F = FreeFile
    Open "c:\test.txt" For Input As F
    Set db = CurrentDb
    Set db = DBEngine(0).OpenDatabase("biblio.mdb")
    On Error Resume Next
    db.Execute "DROP TABLE TestImport"
    On Error GoTo 0
    db.Execute "CREATE TABLE TestImport (ID LONG, [Desc] TEXT (50), " & "Qty LONG, Cost CURRENCY, OrdDate DATETIME)"
    Set rs = db.OpenRecordset("TestImport", dbOpenTable)
    Do While Not EOF(F)
        Line Input #F, sLine
        ParseToArray sLine, A()
        rs.AddNew
        rs(0) = Val(A(0))
        rs(1) = A(1)
        rs(2) = Val(A(2))
        rs(3) = Val(A(3))
        rs(4) = CDate(A(4))
        rs.Update
    Loop
    rs.Close
    db.Close
    Close #F
End Sub

Sub ParseToArray(sLine As String, A() As String)
    Dim P As Long, LastPos As Long, I As Long
    P = InStr(sLine, ",")
    Do While P
        A(I) = Mid$(sLine, LastPos + 1, P - LastPos - 1)
        LastPos = P
        I = I + 1
        P = InStr(LastPos + 1, sLine, ",", vbBinaryCompare)
    Loop
    A(I) = Mid$(sLine, LastPos + 1)
End Sub

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

Menampillkan File Pada Directory Yang Ditentukan

'Judul      : Memunculkan file atau sub direktori pada direktori yang ditentukan
'Coder      : Tongam Tampubolon (Tomero)
'Penjelasan : Buat 1 Listbox, 1 CommandButton, Masukkan kode tsb dalam Form1

Private Sub Command1_Click()
    Call ProsesLokasi(List1, "E:\", "mp3", True)
    MsgBox "Selesai"
End Sub

'Prosedur memunculkan lokasi file/folder pada kontrol listbox
'ListTampil => Kontrol ListBox Target
'Lokasi => Alamat Drive/Direktori awal permulaan pencarian
'SaringExtension => Penentuan file yg ditmunculkan dalam ListBox
'Rekursif => Penentuan pemrosesan subdirektori

Private Sub ProsesLokasi(ListTampil As ListBox, Lokasi As String, SaringExtension As String, Rekursif As Boolean)

    Dim NamaFile As String
    Dim IndexFolder As Long
    Dim TotalFolder As Long
    Dim Folder() As String

    'Karena dipastikan sebuah drive atau directory
    'maka ditambahkan slash "\" dibelakang
    Lokasi = TambahSlash(Lokasi)
    'Ambil Nama File Pertama
    NamaFile = Dir$(Lokasi & "*.*", vbNormal + vbHidden + vbDirectory + vbSystem + vbReadOnly + vbArchive + vbSystem)

    'Ulangi Sampai Tidak Ditemui File/Folder
    While NamaFile = ""
        'Periksa Apakah Objek yg didapat berupa folder atau file
        If NamaFile = "." And NamaFile = ".." Then
            If JenisFolder(Lokasi & NamaFile) = False Then 'File
                'Seleksi Berdasarkan extensi file yg ingin di proses
                If SaringExtension = "" Then
                    If Right(LCase(NamaFile), Len(SaringExtension) + 1) = "." & LCase(SaringExtension) Then
                        ListTampil.AddItem Lokasi & NamaFile
                    End If
                End If
            Else 'Folder
                ReDim Preserve Folder(IndexFolder)
                Folder(IndexFolder) = Lokasi & TambahSlash(NamaFile)
                ListTampil.AddItem Lokasi & TambahSlash(NamaFile)
                IndexFolder = IndexFolder + 1
            End If
        End If

        DoEvents

        'Ambil Nama File/Folder Berikutnya
        NamaFile = Dir$()
    Wend

    'Jika rekursif, ambil isi sub direktori
    If Rekursif = True And IndexFolder > 0 Then
        TotalFolder = IndexFolder - 1
        For IndexFolder = 0 To TotalFolder
            Call ProsesLokasi(ListTampil, Folder(IndexFolder), SaringExtension, Rekursif)
        Next
    End If

End Sub

'Fungsi untuk menentukan jenis suatu objek
Private Function JenisFolder(Lokasi As String) As Boolean
    Dim CC As Long
    'On Error GoTo NA:
    CC = FileLen(Lokasi)
    If CC > 0 Then
        JenisFolder = False
    Else
        JenisFolder = True
    End If
    Exit Function

NA:

    JenisFolder = True

End Function

'Fungsi menambahkan slash "\" pada lokasi direktori
Private Function TambahSlash(Data As String) As String
    TambahSlash = IIf(Right$(Data, 1) = "\", Data, Data & "\")
End Function

Membuat Assosiasi Untuk Sebuah File

Option Explicit

'==========================================================================

' Parameters
' Required    Extension       (Str) ie ".exe"
' Required    FileType        (Str) ie "VB.Form"
' Required    FileTYpeName    (Str) ie. "Visual Basic Form"
' Required    Action          (Str) ie. "Open" or "Edit"
' Required    AppPath         (Str) ie. "C:\Myapp"
' Optional    Switch          (Str) ie. "/u"                  Default = ""
' Optional    SetIcon         (Bol)                           Default = False
' Optional    DefaultIcon     (Str) ie. "C:\Myapp,0"
' Optional    PromptOnError   (Bol)                           Default = False

' HOW IT WORKS
' Extension(Str)   Default = FileType(Str)
' FileType(Str)    Default = FileTypeName(Str)
' "DefaultIcon"     Default = DefaultIcon(Str)
' "shell"
' Action(Str)
' "command"   Default = AppPath(Str) & switch(Str) & " %1"

'================================================================
' Private Sub cmdCreateAsso_Click()
'    CreateFileAss ".wrs", "Warisan File", "Warisan File", "open", "c:\Warisan.exe", , True, "C:\Warisan.exe", True
' End Sub
'================================================================


' Private Konstanta dalam local
Private Const REG_SZ As Long = 1
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const ERROR_SUCCESS = 0
Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0
Private PromptOnErr As Boolean

' Global API deklarasi yang berhubungan dengan registry
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Public Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long

Public Function CreateFileAss(Extension As String, FileType As String, FileTypeName As String, Action As String, AppPath As String, Optional Switch As String = "", Optional SetIcon As Boolean = False, Optional DefaultIcon As String, Optional PromptOnError As Boolean = False) As Boolean
On Error GoTo ErrorHandler:

    PromptOnErr = PromptOnError

    ' Cek keberadaan AppPath
    If Dir(AppPath, vbNormal) = "" Then
        If PromptOnError Then MsgBox "The application path '" & _
            AppPath & "' cannot be found.", _
            vbCritical + vbOKOnly, "DLL/OCX Register"

        CreateFileAss = False
        Exit Function
    End If

    Dim ERROR_CHARS As String: ERROR_CHARS = "\/:*?<>|" & Chr(34)
    Dim I As Integer

    If Asc(Extension) <> 46 Then Extension = "." & Extension
    ' Cek bahwa extension mempunyai "." di depannya
    
    ' Cek apabila ada karakter yang invalid dalam ekstension
    For I = 1 To Len(Extension)
        If InStr(1, ERROR_CHARS, Mid(Extension, I, 1), vbTextCompare) Then
            If PromptOnError Then MsgBox "The file extension '" & Extension & "' contains an illegal char (\/:*?<>|" & Chr(34) & ").", vbCritical + vbOKOnly, "DLL/OCX Register"
            CreateFileAss = False
            Exit Function
        End If
    Next

    If Switch <> "" Then Switch = " " & Trim(Switch)
   Action = FileType & "\shell\" & Action & "\command"

    Call CreateSubKey(HKEY_CLASSES_ROOT, Extension)        ' membuat ekstension .xxx key
    Call CreateSubKey(HKEY_CLASSES_ROOT, Action)           ' Membuat action key

    If SetIcon Then
        Call CreateSubKey(HKEY_CLASSES_ROOT, (FileType & "\DefaultIcon"))                ' Membuat ikon default key
        If DefaultIcon = "" Then
            ' Set default ikon Euy..
            Call SetKeyDefault(HKEY_CLASSES_ROOT, FileType & "\DefaultIcon", Trim(AppPath & ",0"))
        Else
            Call SetKeyDefault(HKEY_CLASSES_ROOT, FileType & "\DefaultIcon", Trim(DefaultIcon))
        End If
   End If
   
   Call SetKeyDefault(HKEY_CLASSES_ROOT, Extension, FileType)                                ' Set .xxx key default
   Call SetKeyDefault(HKEY_CLASSES_ROOT, FileType, FileTypeName)                              ' Set file type default
   Call SetKeyDefault(HKEY_CLASSES_ROOT, Action, AppPath & Switch & " %1")                     ' Set Command line
   CreateFileAss = True
   Exit Function

ErrorHandler:

    If PromptOnError Then MsgBox "An error occured while           attempting to create the file extension '" & Extension & "'.", vbCritical + vbOKOnly, "DLL/OCX Register"
    CreateFileAss = False
End Function

'================================================
'       FUNGSI UNTUK MEMBUAT SUBKEY BARU
'================================================

Private Function CreateSubKey(RootKey As Long, NewKey As String) As Boolean
    Dim hKey As Long, regReply As Long
    regReply = RegCreateKeyEx(RootKey, NewKey, _
         0&, "", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, 0&)

    If regReply <> ERROR_SUCCESS Then
        If PromptOnErr Then MsgBox "An error occured          while attempting to to create a registery key.", vbCritical + vbOKOnly, "DLL/OCX Register"
        CreateSubKey = False
    Else
        CreateSubKey = True
    End If

    Call RegCloseKey(hKey)
End Function

'===================================================
'       FUNGSI UNTUK MENSET NILAI DEFAULT
'===================================================

Private Function SetKeyDefault(RootKey As Long, Address As String, Value As String) As Boolean
    Dim regReply As Long, hKey As Long
    regReply = RegOpenKeyEx(RootKey, Address, 0, KEY_ALL_ACCESS, hKey)

    If regReply <> ERROR_SUCCESS Then
        If PromptOnErr Then MsgBox "An error occured while attempting           to access the registery.", vbCritical + vbOKOnly, "DLL/OCX Register"
            SetKeyDefault = False
        Exit Function
    End If

    Value = Value & Chr(0)

    regReply = RegSetValueExString(hKey, "", 0&, REG_SZ, Value, Len(Value))

    If regReply <> ERROR_SUCCESS Then
        If PromptOnErr Then MsgBox "An error occured while            attempting to set key default value.", vbCritical + vbOKOnly, "DLL/OCX Register"
        SetKeyDefault = False
    Else
        SetKeyDefault = True
    End If

    Call RegCloseKey(hKey)
End Function

VB6 Source Code - Membuat Virtual Drive Menggunakan VB6

Mengenai cara membuat Virtual Drive menggunakan Visual Basic 6 - Bagaimanakah cara membuat virtual drive menggunakan VB6 dengan bantuan Command DOS Subst.exe, berikut adalah contohnya:

Private Function MountVirtualDrive(vd As String, path As String)
    'Perintah di bawah untuk melakukan mounting/membuat virtual drive
    'subst.exe x: c:/windows/system32 'melakukan mounting path terhadap virtual drive x
    Shell "Subst.exe " & vd & path
End Function

Private Function UnMountVirtualDrive(vd As String)
    'Perintah di bawah untuk unmounting/release virtual drive
    'subst.exe x: /d 'melakukan unmounting virtual drive x:
    Shell "Subst.exe " & vd & " /d"
End Function

Demikian cara sederhana mengenai pembuatan virtual drive menggunakan VB6 dengan bantuan DOS Command Subst.exe, semoga bermanfaat.

Thursday, June 14, 2012

App.Path Dalam VB6 Bisa Diganti Dengan Dot Slash

Mengenai App.path dalam VB6 yang bisa kita ganti dengan "./" (dot slash) - Misalnya kita membuat kode seperti ini:
Shell App.Path & "\Launcher.exe" bisa kita ganti menjadi Shell "./Launcher.exe" atau Shell "Launcher.exe" tanpa App.path dan "./" (dot slash".

Tuesday, June 12, 2012

Membaca File Text Baris Per Baris - Visual Basic 6

Dibawah ini merupakan contoh kode untuk membaca file text baris per baris menggunakan VB6 - Adapun kode untuk membaca file text line by line adalah sebagai berikut:

Option Explicit 
 
Private Function OpenTextFile() As String 
    Dim nFileNum As Integer, sText As String 
    Dim sNextLine As String, lLineCount As Long 
    nFileNum = FreeFile 
    Open "C:\daftar_driver.txt" For Input As nFileNum 
        lLineCount = 1 
        Do While Not EOF(nFileNum) 
            Line Input #nFileNum, sNextLine 
            MsgBox sNextLine 'ini akan membaca file text baris per baris 
            sNextLine = sNextLine & vbCrLf 
            sText = sText & sNextLine 
        Loop 
        OpenTextFile = sText 
    Close nFileNum 
End Function

Friday, June 8, 2012

Mengubah Format DOS 8.3 menjadi Long Filename

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

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

Contoh penggunaan kode di atas:

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

GetShortPathName - Mengubah Filename Menjadi DOS 8.3 Format

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

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

Contoh penggunaan kode di atas:

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

Cara Membuat Direktori lebih dari 1 level - (Pengelolaan Fil

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

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

Tuesday, May 29, 2012

PathCompactPathEx - Untuk Menyingkat Nama Path - VB6

Dalam membuat sebuah program, terkadang kita membutuhkan nama path yang disingkat, adapun tujuannya, agar nama yang berada paling akhir dapat kita baca. Lagipula jika path tidak disingkat, mungkin kita akan menemukan MRU (Most Recently Used) seperti pada gambar di bawah ini: (sebenarnya tidak se-ekstrim itu, hanya saja saya membuatnya menjadi panjang)

Untuk menyingkat nama path, kita membuhtuhkan fungsi API PathCompactPathEx. Berikut merupakan contoh kode untuk menyingkat nama path:

Option Explicit 
 
Private Declare Function PathCompactPathEx Lib "shlwapi.dll" Alias "PathCompactPathExA" ByVal pszOut As String, ByVal pszSrc As String, ByVal cchMax As Long, ByVal dwFlags As Long) As Long 
 
'simpan dalam modul 
Public Function ShortFilePath(FilePath As String, Optional MaxLen As Long = 40) As String 
    Dim ShortPath As String 
    On Error Resume Next 
    ShortPath = String(255, 0) 
    PathCompactPathEx ShortPath, FilePath, MaxLen, 0 
    ShortFilePath = ShortPath 
End Function

Contoh penggunaan prosedur di atas:

Private Sub Form_Load() 
    Text1.Text = ShortFilePath("F:\Project\Outlook Bar control + Photoshop Color Picker v1.3.2\3. Samples\Images") 
    'akan menghasilkan "F:\Project\Outlook Bar   con...\Images" 
End Sub

Memilih Lebih dari Satu File Pada Dialog Open - VB6 Code

Option Explicit 

Public Function GetFiles(Optional ByVal sTitle As String = "Open files...") As String 
Dim sFilenames As String 
Dim cdlOpen As Object 
On Error GoTo ProcError 
    ' Get the desired name using the common dialog 
    Set cdlOpen = CreateObject("MSComDlg.CommonDialog") 
    ' set up the file open dialog file types 
    With cdlOpen 
        ' setting CancelError means the control will 
        ' raise an error if   the user clicks Cancel 
        .CancelError = True 
.Filter = "VB Files *.frm;*.bas;*.cls;*.res;*.ctl;*.dob;*.pag;*.dsr)|*.frm;*.bas;*.cls;*.res;*.ctl;*.dob;*.pag;*.dsr|Form Files *.frm)|*.*.frm|Basic Files *.bas)|*.bas|All Files *.*)|*.*" 
        .FilterIndex = 1 
        .DialogTitle = sTitle 
        .MaxFileSize = &H7FFF ' 32KB filename buffer 
        ' same as .Flags = cdlOFNHideReadOnly Or  cdlOFNPathMustExist Or cdlOFNLongNames Or cdlOFNAllowMultiselect or cdlOFNExplorer 
        .Flags = &H4 Or &H800 Or &H40000 Or &H200 Or &H80000 
        .ShowOpen 
        sFilenames = .Filename 
    End With 
ProcExit: 
    GetFiles = sFilenames 
    Set cdlOpen = Nothing 
    Exit Function 
ProcError: 
    If Err.Number = &H7FF3 Then Resume Next 'Cancel selected - Ignore 
    MsgBox Err.Description & "(" & Err.Number & ")", vbExclamation, "Open error" 
      sFilenames = "" 
 Resume ProcExit 
End Function 

'contoh penggunaan fungsi di atas 
Private Sub Command1_Click() 
   Dim Filename As Variant 
Filename = Split(GetFiles, Chr(0)) 
       For i = 1 To UBound(Filename) 
           List1.AddItem Filename(0) & "\" & Filename(i) 
       Next 
End Sub

Menyimpan File Ke Dalam Format MHTML

Menyimpan file dalam format MHTML tentunya memiliki banyak keuntungan, salah satu dari banyak keuntungan tersebut ialah terintegrasinya seluruh gambar dan file dengan baik, sehingga kita bisa mendownload halaman situs/blog yang kita kunjungi utuh dengan seluruh gambarnya.

Apabila Anda gabungkan dengan prosedur untuk mengekstrak link dari sebuah blog, maka ia akan memiliki kemampuan yang lebih baik lagi, dengan kata lain Anda dapat mem-back-up satu blog milik Anda sendiri ataupun milik orang lain utuh dengan seluruh gambarnya.

Option Explicit  

Public Function SaveWebPageToMHTFile(url As String, filepath As String)  
      
On Error GoTo ErrHandler  

    Dim msg As New CDO.Message  
    Dim stm As New   ADODB.Stream  
      
    msg.MimeFormatted = True  
    msg.CreateMHTMLBody url, CDO.CdoMHTMLFlags.cdoSuppressNone, "", ""  
    '//Pilih charset yang sesuai 
    stm.Charset = "utf-8"  
    Set stm = msg.GetStream()  
    stm.SaveToFile filepath, ADODB.SaveOptionsEnum.adSaveCreateOverWrite  
    Set msg = Nothing  
    stm.Close  
      
    Exit Function  

ErrHandler:  

    MsgBox Err.Description  
      
End Function

Contoh pemanggilan prosedur fungsi di atas:

Private Sub Command1_Click()  
    '//Coba menyimpan file dalam bentuk MHTML </i> 
    SaveWebPageToMHTFile "http://www.planet-source-code.com/vb/default.asp?lngWId=1", "c:\psc.MHTML"  
End Sub

Catatan: Sebelum Anda menggunakan fungsi di atas, tambahkan referensi Microsoft ActiveX Data Objects 2.8 Liblari dan Microsoft CDO for Windows 2000 Liblary

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

Sunday, May 27, 2012

Memindahkan Seluruh File Dalam Satu Directory

Di bawah ini merupakan fungsi untuk memindahkan seluruh file dari satu directory tertentu. Untuk keperluan ini Anda harus mereferensi pada objek Microsoft Scripting Runtime atau scrun.dll.

Option Explicit 
 
Public Function MoveAllFiles() 
    Dim fso As New FileSystemObject 
    Call fso.MoveFolder(Source, Destination) 
    Set fso = Nothing 
End Function

Contoh penggunaan fungsi di atas:

Private Sub Command1_Click() 
    Call MoveAllFiles("C:\djview", "D:\djview") 
End Sub

Subscribe to: Posts ( Atom )

Khoiriyyah - Syair Arab Visual Basic 6.0 Blogging