Wednesday, June 20, 2012

Cara Yang Cerdik Untuk Mentrap On Error Resume Next - VB6

Mengenai cara men-trap (menjebak) objek error yang berada di bawah bari On Error Resume Next - Bagaimana kita dapat melakukan sebuah pengecualian dalam baris yang berada di bawah On Error Resume Next, di bawah adalah contoh kode VB6 beserta penjelasannya:

Option Explicit

Private Sub Command1_Click()
    'Baris pertama kita memasang On Error Resume Next, maksudnya
    'kita memberitahukan pada compiler VB6 untuk melangkahi baris error
    'dan mengeksekusi baris berikutnya tanpa harus menampilkan pesan error
    On Error Resume Next
    
    'Selanjutnya kita mamasang satu variable i (catatan: variable satu huruf
    'seperti i, b, j dan selanjutnya, hanya bisa digunakan pada sebuah jangkah (scope)
    'yang sempit, dan jangan pernah menggunakannya pada scope yang luas seperti
    'Public i as Integer dan variable i berada pada module, Global l as long, dst
    Dim i As Integer
    
    'Dengan adanya On Error Resume Next di atas, maka kode di bawah ini akan
    'diabaikan/dilangkahi oleh compiler VB6. Selanjutnya pesan error tidak akan
    'ditampilkan
    i = "Hai, ini pasti error"
    
    'Walaupun kita telah memasang baris On Error Resume Next, bukan berarti
    'Bukan berarti Error Object tidak, Error Object tetap bekerja sebagaimana
    'biasanya
    If Err Then 'Apabila Error = True a.k.a Err.Number > 0 maka ...
        'Kode trap ...
        MsgBox Err.Description
        'Kode trap ...
    End If
    
    'Baris di bawah akan meng-Clear error
    On Error GoTo 0
    
    'Sekarang lihat hasilnya
    MsgBox Err.Description
End Sub

Kode utuh tanpa keterangan (comment) adalah sebagai berikut:

Option Explicit

Private Sub Command1_Click()
    On Error Resume Next
    Dim i As Integer
    i = "Hai, ini pasti error"
    If Err Then
        MsgBox Err.Description
    End If
    On Error GoTo 0
    MsgBox Err.Description
End Sub

Sunday, June 17, 2012

Contoh Menambahkan Attribut Pada Tag HTML - VB Code

Private Function AddPreWithClassName()
     Dim d As New MSHTML.HTMLDocument
     Dim l As HTMLMetaElement
     Dim x As HTMLHtmlElement
     
     d.body.innerHTML = txtPost.Text
    
     For Each l In d.All
         If l.tagName = "PRE" Then
             l.className = "code" '
         End If
     Next
     txtPost.Text = d.body.innerHTML
End Function

URL Encode - Decode UTF8 Menggunakan Script Control

Mungkin bisa disebut sebagai cara termudah untuk melakukan Encoding dan Decoding URL UTF8 dalam VB6, dengan memanfaatkan OCX Microsoft Script Control. Adapun kode untuk Encode dan Decode URL UTF8 menggunakan Visual Basic 6.0 adalah sebagai berikut:

'=================================================================
'UrlEncodeUtf8 menggunakan Script Control
'=================================================================
Public Function UrlEncodeUtf8(ByRef strSource As String) As String
    Dim sc As Object
    Set sc = CreateObject("ScriptControl")
    sc.Language = "Jscript"
    UrlEncodeUtf8 = sc.CodeObject.encodeURIComponent(strSource)
    Set sc = Nothing
End Function

'=================================================================
'UrlDecodeUtf8 menggunakan Script Control
'=================================================================
Public Function URLDecodeUTF8(strSource As String) As String
    Dim sc As Object
    Set sc = CreateObject("ScriptControl")
    sc.Language = "Jscript"
    URLDecodeUTF8 = sc.CodeObject.decodeURIComponent(strSource)
    Set sc = Nothing
End Function

VB6 Code - Mencari seluruh Printer Port

Lebih tepatnya mencari port printer tertentu dari seluruh printer port yang ada menggunakan kode VB6. Adapun kode VB6 untuk mencari port tertentu dari seluruh printer port yang ada adalah sebagai berikut:

Public Function FindPrinterPort(Port As String) As Boolean

    Dim P As Printer, Found As Boolean
    For Each P In Printers
        If Printer.Port = Port & ":" Then
            Found = True
            Exit For
        End If
    Next

    FindPrinterPort = Found

End Function

Demikian VB6 kode untuk mencari port tertentu dari seluruh printer port yang ada.

VB6 Code - Menampilkan Dialog Page Setup

Option Explicit

Private Sub Command1_Click()
    With CommonDialog1
        .Flags = CommonDialog1.Flags Or PrinterConstants.cdlPDPrintSetup
        .CancelError = True
        On Error Resume Next
        Call .ShowPrinter
        If Err.Number <> ErrorConstants.cdlCancel Then
            Call MsgBox("here, please implement the process after the end of the printer settings")
        End If
    End With
End Sub

VB6 Code - Memperoleh Control Yang Sedang Aktif - Focus

Option Explicit

Private Sub Timer1_Timer()
    Dim cControl As Control
    Set cControl = Me.ActiveControl

    If Not cControl Is Nothing Then
        Caption = cControl.Name
    End If
End Sub

Contoh Menggunakan CommonDialog Open Save As

'Contoh untuk CommonDialog Open
Private Sub Command1_Click()

    On Error GoTo ErrHandler

    Dim strPath As String

    With CommonDialog1
        .CancelError = True
        .Flags = cdlOFNHideReadOnly
        .Filter = "All Files (*.*)|*.*|Text Files (*.txt)|*.txt|Batch Files (*.bat)|*.bat"
        .FilterIndex = 2
        .DialogTitle = "Open File"
        .ShowOpen
        strPath = .FileName
    End With
    'Code selanjutnya
    Exit Sub

ErrHandler:

    Exit Sub

End Sub

    'Contoh untuk CommonDialog Save As
Private Sub Command2_Click()

    On Error GoTo ErrHandler

    Dim strPath As String

    With CommonDialog1
        .CancelError = True
        .Flags = cdlOFNHideReadOnly
        .Filter = "All Files (*.*)|*.*|Text Files (*.txt)|*.txt|Batch Files (*.bat)|*.bat"
        .FilterIndex = 2
        .DialogTitle = "Save As"
        .ShowSave
        strPath = .FileName
    End With
    'Code selanjutnya
    Exit Sub

ErrHandler:

    Exit Sub
End Sub

    'Contoh untuk CommonDialog Save
Private Sub Command3_Click()

    On Error GoTo ErrHandler

    Dim strPath As String

    With CommonDialog1
        .CancelError = True
        .Flags = cdlOFNHideReadOnly
        .Filter = "All Files (*.*)|*.*|Text Files (*.txt)|*.txt|Batch Files (*.bat)|*.bat"
        .FilterIndex = 2
        .DialogTitle = "Save"
        .ShowSave
        strPath = .FileName
    End With
    'Code selanjutnya
    Exit Sub

ErrHandler:

    Exit Sub
End Sub

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

XML Pretty Print - Merapikan Format File XML

Private Sub PrettyPrint(Parent As IXMLDOMNode, Optional Level As Integer)
    Dim Node As IXMLDOMNode
    Dim Indent As IXMLDOMText

    If Not Parent.ParentNode Is Nothing And Parent.ChildNodes.Length > 0 Then
        For Each Node In Parent.ChildNodes
            Set Indent = Node.OwnerDocument.createTextNode(vbNewLine & String(Level, vbTab))

            If Node.NodeType = NODE_TEXT Then
                If Trim(Node.Text) = "" Then
                    Parent.RemoveChild Node
                End If
            ElseIf Node.PreviousSibling Is Nothing Then
                Parent.InsertBefore Indent, Node
            ElseIf Node.PreviousSibling.NodeType <> NODE_TEXT Then
                Parent.InsertBefore Indent, Node
            End If
        Next Node
    End If

    If Parent.ChildNodes.Length > 0 Then
        For Each Node In Parent.ChildNodes
            If Node.NodeType <> NODE_TEXT Then PrettyPrint Node, Level + 1
        Next Node
    End If
End Sub

XML Tidy - Untuk Merapikan File XML

Public Function PrettyPrintXML(XML As String) As String

    Dim Reader As New SAXXMLReader60
    Dim Writer As New MXXMLWriter60

    Writer.Indent = True
    Writer.standalone = False
    Writer.omitXMLDeclaration = False
    Writer.encoding = "utf-8"

    Set Reader.contentHandler = Writer
    Set Reader.dtdHandler = Writer
    Set Reader.errorHandler = Writer

    Call Reader.putProperty("http://xml.org/sax/properties/declaration-handler", _
    Writer)
    Call Reader.putProperty("http://xml.org/sax/properties/lexical-handler", _
    Writer)

    Call Reader.parse(XML)

    PrettyPrintXML = Writer.output

End Function

Public Function PrettyPrintDocument(Doc As DOMDocument60) As String
    PrettyPrintDocument = PrettyPrintXML(Doc.XML)
End Function

Memperoleh Informasi Time Zone Dari Local Time

Option Explicit

Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Private Type TIME_ZONE_INFORMATION
    Bias As Long
    StandardName(32) As Integer
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(32) As Integer
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type

Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long

Function GetTimeZone() As String
    Dim tzInfo As TIME_ZONE_INFORMATION
    Dim s As String
    GetTimeZoneInformation tzInfo
    s = IIf(tzInfo.Bias < 0, "+", "-")
    GetTimeZone = s & Format((Abs(tzInfo.Bias) \ 60) & ":" & (Abs(tzInfo.Bias) Mod 60), "hh:mm")
End Function

Private Sub Command1_Click()
    MsgBox GetTimeZone
End Sub

Encode Decode Base64 Menggunakan MSXML

Public Function Base64Enc(ByRef vxbData() As Byte) As String
    With CreateObject("MSXML.DOMDocument").CreateElement(" Base64 ")
        .DataType = "bin.base64"
        .NodeTypedValue = vxbData
        Base64Enc = .Text
    End With
End Function

Public Function Base64Dec(ByRef vsData As String) As Byte()
    With CreateObject("MSXML.DOMDocument").CreateElement("Base64")
        .DataType = "bin.base64"
        .Text = vsData
        Base64Dec = .NodeTypedValue
    End With
End Function

Mengkopi Gambar Ke Clipboard Melalui VB6

Private Sub CopyFromPictureBox(pic As PictureBox)
    With Clipboard
        .Clear
        .SetData pic.Picture
    End With
End Sub

Private Sub CopyFromFile(Path As String)
    With Clipboard
        .Clear
        .SetData LoadPicture(Path)
    End With
End Sub

Progress Bar dari PictureBox Seperti Pada VB Classic

Option Explicit

Dim tenth As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Sub UpdateStatus(FileBytes As Long)
    Static progress As Long
    Dim r As Long
    Const SRCCOPY = &HCC0020
    Dim Txt$
    progress = progress + FileBytes
    If progress > Picture1.ScaleWidth Then
        progress = Picture1.ScaleWidth
    End If
    Txt$ = Format$(CLng((progress / Picture1.ScaleWidth) * 100)) + "%"
    Picture1.Cls
    Picture1.CurrentX = (Picture1.ScaleWidth - Picture1.TextWidth(Txt$)) \ 2
    Picture1.CurrentY = (Picture1.ScaleHeight - Picture1.TextHeight(Txt$)) \ 2
    Picture1.Print Txt$
    Picture1.Line (0, 0)-(progress, Picture1.ScaleHeight), Picture1.ForeColor, BF
    r = BitBlt(Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, Picture1.hdc, 0, 0, SRCCOPY)
End Sub

Private Sub Command1_Click()
    Dim i As Integer, x As Long
    Picture1.ScaleWidth = 109
    tenth = 10
    For i = 1 To 11
        Call UpdateStatus(tenth)
        x = Timer
        While Timer < x + 0.75
            DoEvents
        Wend
    Next
End Sub

Private Sub Form_Load()
    Picture1.FontBold = True
    Picture1.AutoRedraw = True
    Picture1.BackColor = vbWhite
    Picture1.DrawMode = 10
    Picture1.FillStyle = 0
    Picture1.ForeColor = vbBlue
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

Mengakses Element WebBrowser Dari Visual Basic 6.0

Option Explicit

Private Sub cmdBack_Click()
    On Error Resume Next
    WebBrowser1.GoBack
End Sub

Private Sub cmdForward_Click()
    On Error Resume Next
    WebBrowser1.GoForward
End Sub

Private Sub cmdGo_Click()
    WebBrowser1.Navigate txtAddress
End Sub

Private Sub Form_Load()
    WebBrowser1.Navigate "http://www.microsoft.com"
End Sub

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)

    On Error Resume Next
    If (pDisp Is WebBrowser1.object) Then

        txtAddress = WebBrowser1.LocationURL
        Me.Caption = WebBrowser1.LocationName
        txtText = ""
        tvTreeView.Nodes.Clear
        RecurseFrames WebBrowser1.Document, Nothing
    End If
End Sub

Private Sub RecurseFrames(ByVal iDoc As HTMLDocument, ByVal iNode As node)
    Dim I As Integer
    Dim Range As IHTMLTxtRange
    Dim Title As String
    Dim TextInfo As String
    Dim tvNode As node

    On Error Resume Next

    Title = iDoc.Title
    If Title = "" Then
        Title = iDoc.parentWindow.Name
        If Title = "" Then Title = iDoc.location
    End If

    If iNode Is Nothing Then
        Set tvNode = tvTreeView.Nodes.Add(, , , Title)
    Else
        Set tvNode = tvTreeView.Nodes.Add(iNode.Index, tvwChild, , Title)
    End If

    TextInfo = "Frame: " & Title & vbCrLf & "{" + vbCrLf

    If iDoc.body.tagName = "BODY" Then
        FillTree iDoc, "OBJECT", tvNode, "ActiveX Controls"
        FillTree iDoc, "A", tvNode, "Anchors"
        FillTree iDoc, "IMG", tvNode, "Images"
        FillTree iDoc, "", tvNode, "All"

        Set Range = iDoc.body.createTextRange
        TextInfo = TextInfo & Range.Text & vbCrLf
        Set Range = Nothing
    ElseIf iDoc.frames.length > 0 Then
        For I = 0 To iDoc.frames.length - 1
            TextInfo = TextInfo & "FRAME: " & iDoc.frames(I).Document.nameProp & vbCrLf
            Dim doc As New HTMLDocument
            Dim eCollection As IHTMLElementCollection
            Dim uElement As HTMLUnknownElement
            Set eCollection = iDoc.frames(I).Document.All
            For Each uElement In eCollection
                If uElement.tagName = "HTML" Then
                    doc.All(0).insertAdjacentHTML "BeforeBegin", uElement.innerHTML
                    doc.Title = "Frame: " & iDoc.frames(I).Document.nameProp
                    FillTree doc, "FRAME", tvNode, "FRAME"
                    RecurseFrames doc, tvNode
                    Set doc = Nothing
                End If
            Next uElement
        Next I
    End If

    txtText.Text = txtText.Text & TextInfo & "}" & vbCrLf

End Sub

Private Sub FillTree(iDoc As HTMLDocument, iMatchTag As String, iNode As node, iCategory As String)
    Dim Element As Object
    Dim Info As String
    Dim tvNode As node
    Dim tvCatNode As node

    On Error Resume Next

    Set tvCatNode = Nothing
    For Each Element In iDoc.All
        If iMatchTag = "" Or Element.tagName = iMatchTag Then

            Info = Element.tagName & " "

            If Element.tagName = "IMG" Then
                Info = Info & Element.href
            ElseIf Element.tagName = "A" Then
                Info = Info & Element.innerText & " (" & Element.href & ")"
            ElseIf Element.tagName = "INPUT" Then
                Info = Info & Element.Type
            ElseIf Element.tagName = "META" Then
                Info = Info & Element.nodeName
            ElseIf Element.tagName = "FRAMESET" Then
                Info = Info & Element.Name
            ElseIf Element.tagName = "FRAME" Then
                Info = Info & ": " & Element.src
            Else
                Info = Info & Element.Id
            End If

            If tvCatNode Is Nothing Then
                Set tvCatNode = tvTreeView.Nodes.Add(iNode.Index, tvwChild, , iCategory)
            End If
            Set tvNode = tvTreeView.Nodes.Add(tvCatNode.Index, tvwChild, , Info)
        End If
        If Element.tagName = "FRAME" Then
            Dim I As Long
            For I = 0 To iDoc.frames.length - 1
                If iDoc.frames(I).Document.nameProp = Element.Document.nameProp Then
                    Dim doc As New HTMLDocument
                    Dim eCollection As IHTMLElementCollection
                    Dim uElement As HTMLUnknownElement
                    Set eCollection = iDoc.frames(I).Document.All
                    For Each uElement In eCollection
                        If uElement.tagName = "HTML" Then
                            doc.All(0).insertAdjacentHTML "BeforeBegin", uElement.innerHTML
                            doc.Title = "Frame: " & iDoc.frames(I).Document.nameProp
                            RecurseFrames doc, tvNode
                            Set doc = Nothing
                        End If
                    Next uElement
                End If
            Next I
        End If
    Next
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

Membaca dan Menampilkan Karakter Unicode

Option Explicit

Private Sub Command1_Click()
    Dim a(0 To 5) As Byte
    a(0) = &HFF
    a(1) = &HFE
    a(2) = &H39
    a(3) = &H4E
    a(4) = &H44
    a(5) = &H0
    Open "unicode.txt" For Binary As #1
    Put #1, , a
    Close #1
End Sub

Private Sub Command2_Click()
    Dim txtline As String

    Open "unicode.txt" For Binary As #1
        txtline = InputB(2, #1)
        txtline = InputB(4, #1)
    Close #1

    TextBox1.Text = txtline
End Sub

TAB Karakter Pada RichTextBox Control

Private Sub RichTextBox1_GotFocus()
    ReDim arrTabStop(0 To Controls.Count - 1) As Boolean
    For I = 0 To Controls.Count - 1
        arrTabStop(I) = Controls(I).TabStop
        Controls(I).TabStop = False
    Next
End Sub

Private Sub RichTextBox1_LostFocus()
    For I = 0 To Controls.Count - 1
        Controls(I).TabStop = arrTabStop(I)
    Next
End Sub

Implementasi Pencarian Pada RichTextBox Control

Option Explicit

Private Sub Command1_Click()
    HighlightWords RichTextBox1, "text", vbRed
End Sub

Private Function HighlightWords(rtb As RichTextBox, sFindString As String, lColor As Long) As Integer

    Dim lFoundPos As Long
    Dim lFindLength As Long
    Dim lOriginalSelStart As Long
    Dim lOriginalSelLength As Long
    Dim iMatchCount As Integer

    lOriginalSelStart = rtb.SelStart
    lOriginalSelLength = rtb.SelLength

    lFindLength = Len(sFindString)

    lFoundPos = rtb.Find(sFindString, 0, , rtfNoHighlight)
    While lFoundPos > 0
        iMatchCount = iMatchCount + 1

        rtb.SelStart = lFoundPos
        rtb.SelLength = lFindLength
        rtb.SelColor = lColor

        lFoundPos = rtb.Find(sFindString, lFoundPos + lFindLength, , rtfNoHighlight)
    Wend

    rtb.SelStart = lOriginalSelStart
    rtb.SelLength = lOriginalSelLength

    HighlightWords = iMatchCount

End Function

Scroll Treeview Ketika Sedang Drag And Drop Sebuah Node

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

Dim mfX As Single
Dim mfY As Single
Dim moNode As node
Dim m_iScrollDir As Integer
Dim mbFlag As Boolean

Private Sub Form_DragOver(Source As Control, x As Single, y As Single, State As Integer)
    If Source.Name = "TreeView1" Then
        Timer1.Enabled = False
    End If
End Sub

Private Sub Form_Load()
    Dim i As Integer
    Dim n As Integer
    Timer1.Enabled = False
    Timer1.Interval = 200
    TreeView1.Style = tvwTreelinesPlusMinusPictureText
    TreeView1.ImageList = ImageList1
    For i = 1 To 50
        TreeView1.Nodes.Add Text:="Node " & i, Image:=1, SelectedImage:=2
    Next i
    For i = 1 To 50
        For n = 1 To 5
            TreeView1.Nodes.Add Relative:=i, Relationship:=tvwChild, Text:="Child Node " & n, Image:=1, SelectedImage:=2
        Next n
    Next i
End Sub

Private Sub Timer1_Timer()
    Set TreeView1.DropHighlight = TreeView1.HitTest(mfX, mfY)
    If m_iScrollDir = -1 Then
        SendMessage TreeView1.hwnd, 277&, 0&, vbNull
    Else
        SendMessage TreeView1.hwnd, 277&, 1&, vbNull
    End If
End Sub

Private Sub TreeView1_DragDrop(Source As Control, x As Single, y As Single)
    If Not TreeView1.DropHighlight Is Nothing Then
        MsgBox moNode.Text & " was dropped on " & TreeView1.DropHighlight.Text
    End If
    Set TreeView1.DropHighlight = Nothing
    Set moNode = Nothing
    Timer1.Enabled = False
End Sub

Private Sub TreeView1_DragOver(Source As Control, x As Single, y As Single, State As Integer)
    Set TreeView1.DropHighlight = TreeView1.HitTest(x, y)
    mfX = x
    mfY = y
    If y > 0 And y < 100 Then
        m_iScrollDir = -1
        Timer1.Enabled = True
    ElseIf y > (TreeView1.Height - 200) And y < TreeView1.Height Then
        m_iScrollDir = 1
        Timer1.Enabled = True
    Else
        Timer1.Enabled = False
    End If
End Sub

Private Sub TreeView1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Timer1.Enabled = False
End Sub

Private Sub TreeView1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    TreeView1.DropHighlight = TreeView1.HitTest(x, y)
    If Not TreeView1.DropHighlight Is Nothing Then
        TreeView1.SelectedItem = TreeView1.HitTest(x, y)
        Set moNode = TreeView1.SelectedItem
    End If
    Set TreeView1.DropHighlight = Nothing
End Sub

Private Sub TreeView1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then
        TreeView1.DragIcon = TreeView1.SelectedItem.CreateDragImage
        TreeView1.Drag vbBeginDrag
    End If
End Sub

Membuat Random Auto Number - DAO

Public Sub CreateRandomAutonumber()
    Dim db As DAO.Database
    Dim td As DAO.TableDef
    Dim f As DAO.field
    
    Set db = CurrentDb
    Set td = db.CreateTableDef("Table1")
    Set f = td.CreateField("MyAutoNumber")

    f.Type = dbLong
    f.Attributes = dbAutoIncrField
    td.Fields.Append f
    
    Set f = td.CreateField("MyTextField")
    f.Type = dbText
    td.Fields.Append f
    db.TableDefs.Append td
    td.Fields("MyAutoNumber").DefaultValue = "GenUniqueID()"
    Application.RefreshDatabaseWindow
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

Apakah ScrollBar Visible Pada Sebuah Control?

Option Explicit

Private Const GWL_STYLE = (-16)
Private Const WS_HSCROLL = &H100000
Private Const WS_VSCROLL = &H200000

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Sub Command1_Click()
    Dim wndStyle As Long
    wndStyle = GetWindowLong(TreeView1.hwnd, GWL_STYLE)
    If (wndStyle And WS_HSCROLL) <> 0 Then
        MsgBox "A horizontal scroll bar is visible."
    Else
        MsgBox "A horizontal scroll bar is NOT visible."
    End If

    If (wndStyle And WS_VSCROLL) <> 0 Then
        MsgBox "A vertical scroll bar is visible."
    Else
        MsgBox "A vertical scroll bar is NOT visible."
    End If
End Sub

Private Sub Command2_Click()
    TreeView1.Move 250, 900, 1000, 1000
End Sub

Private Sub Form_Load()
    Form1.ScaleMode = 1
    Form1.Move 0, 0, 5100, 5040
    Command1.Caption = "Scroll Bar Test"
    Command1.Move 120, 120, 1700, 500
    Command2.Caption = "Size Control"
    Command2.Move 2000, 120, 1700, 500
    TreeView1.Move 250, 900, 3000, 1500
    TreeView1.Nodes.Add , , , "1: Sample Text"
    TreeView1.Nodes.Add , , , "2: Sample Text"
    TreeView1.Nodes.Add , , , "3: Sample Text"
    TreeView1.Nodes.Add , , , "4: Sample Text"
End Sub

Bagaimana Cara Mem-Print RichTextBox Yang Memiliki Image

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_PAINT = &HF
Private Const WM_PRINT = &H317
Private Const PRF_CLIENT = &H4&
Private Const PRF_CHILDREN = &H10&
Private Const PRF_OWNED = &H20&

Private Sub Command1_Click()
    RichTextBox1.OLEObjects.Add , , "c:\windows\triangles.bmp"
End Sub

Private Sub Command2_Click()
    Dim rv As Long
    Picture1.SetFocus
    Picture2.AutoRedraw = True
    rv = SendMessage(Picture1.hwnd, WM_PAINT, Picture2.hdc, 0)
    rv = SendMessage(Picture1.hwnd, WM_PRINT, Picture2.hdc, PRF_CHILDREN + PRF_CLIENT + PRF_OWNED)
    Picture2.Picture = Picture2.Image
    Picture2.AutoRedraw = False
    Command1.SetFocus
End Sub

Private Sub Command3_Click()
    Printer.PaintPicture Picture2.Picture, 0, 0
    Printer.EndDoc
End Sub

Pencarian Secara Recursive Pada RichTextBox

Private Sub Form_Load()

    RichTextBox1.LoadFile "license.txt"

End Sub

Private Sub Command1_Click()

    Dim strval As String
    Dim nStrings As Long

    RichTextBox1.LoadFile "license.txt"

    strval = " " & InputBox("Enter the string to find.", "Findit", "the") & " "

    If strval <> "" Then

        nStrings = FindIt(RichTextBox1, strval)
        MsgBox (Str$(nStrings) & " instances found.")
    End If

End Sub

Private Function FindIt(Box As RichTextBox, Srch As String, Optional Start As Long)

    Dim retval As Long
    Dim Source As String

    Source = Box.Text

    If Start = 0 Then Start = 1

    retval = InStr(Start, Source, Srch)

    If retval <> 0 Then

        With Box
            .SelStart = retval - 1
            .SelLength = Len(Srch)
            .SelColor = vbRed
            .SelBold = True
            .SelLength = 0
        End With

        Start = retval + Len(Srch)

        FindIt = 1 + FindIt(Box, Srch, Start)
    End If
End Function

Bermain Dengan Horizontal Vertical Scroll TextBox

Option Explicit

Const EM_LINESCROLL = &HB6

Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As Long) As Long

Private Sub Form_Load()
    Dim intLineIndex As Integer, intWordIndex As Integer

    Text1.Font = "Courier New"
    Text1.Text = ""
    For intLineIndex = 1 To 25
        Text1.Text = Text1.Text & "Line" & Str$(intLineIndex)
        For intWordIndex = 1 To 5
            Text1.Text = Text1.Text & " Word" & Str$(intWordIndex)
        Next intWordIndex
        Text1.Text = Text1.Text & vbCrLf
    Next intLineIndex

    Command1.Caption = "Vertical"
    Command2.Caption = "Horizontal"
End Sub

Private Sub Command1_Click()
    Dim lngRet As Long
    lngRet = SendMessage(Text1.hWnd, EM_LINESCROLL, 0, 5&)
End Sub

Private Sub Command2_Click()
    Dim lngRet As Long
    lngRet = SendMessage(Text1.hWnd, EM_LINESCROLL, 5, 0&)
End Sub

Contoh CommonDialog - Print Dengan Range Tertentu

Option Explicit

Private Sub Command1_Click()
    Dim myDatabase As Database
    Dim rsMyTable As Recordset
    Dim i As Integer
    Dim j As Integer
    Dim startpage As Integer

    CommonDialog1.Max = 3
    CommonDialog1.FromPage = 1
    CommonDialog1.ToPage = 3
    CommonDialog1.flags = 0
    CommonDialog1.ShowPrinter
    startpage = CommonDialog1.FromPage

    Printer.FontSize = 18

    Set myDatabase = OpenDatabase("nwind.mdb")
    Set rsMyTable = myDatabase.OpenRecordset("Customers")

    rsMyTable.MoveFirst

    If (CommonDialog1.flags And cdlPDPageNums) <> 0 Then
        MsgBox " Printing pages " & CommonDialog1.FromPage & " to " & CommonDialog1.ToPage
        Select Case startpage
            Case 1

            Case 2
                For i = 1 To 42
                    rsMyTable.MoveNext
                Next

            Case 3
                For i = 1 To 84
                    rsMyTable.MoveNext
                Next
        End Select

        If startpage <> 0 Then
            For j = startpage To CommonDialog1.ToPage
                For i = 1 To 42
                    If rsMyTable.EOF Then Exit For
                    Text1.Text = Text1.Text & rsMyTable!CompanyName & vbCrLf
                    Printer.Print rsMyTable!CompanyName
                    rsMyTable.MoveNext
                Next
                Printer.NewPage
            Next
            Printer.EndDoc
        End If

    ElseIf (CommonDialog1.flags And cdlPDSelection) <> 0 Then

        rsMyTable.MoveLast
        rsMyTable.MoveFirst
        For i = 1 To rsMyTable.RecordCount
            Text1.Text = Text1.Text & rsMyTable!CompanyName & vbCrLf
            rsMyTable.MoveNext
        Next
        MsgBox "Select text to be printed"
    Else
        For i = 1 To rsMyTable.RecordCount
            Text1.Text = Text1.Text & rsMyTable!CompanyName & vbCrLf
            rsMyTable.MoveNext
        Next
        Printer.Print Text1.Text
        Printer.EndDoc
        MsgBox "Printing all pages"
    End If
End Sub

Private Sub Command2_Click()
    Printer.Print Text1.SelText
    Printer.EndDoc
End Sub

Private Sub Form_Load()
    Command1.Caption = "Select Printing Option"
    Command2.Caption = "Print selected text"
End Sub

Contoh MRU - Most Recently Used

Option Explicit

Private Const MaxMRU = 4
Private Const NotFound = -1
Private Const NoMRUs = -1

Private MRUCount As Long

Private Sub Form_Load()
    MRUCount = NoMRUs

    GetMRUFileList
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SaveMRUFileList
End Sub

Private Sub mnuMRU_Click(Index As Integer)
    ReorderMRUList mnuMRU(Index).Caption, CLng(Index)
End Sub

Private Sub mnuOpen_Click()
    Me.CommonDialog1.ShowOpen

    AddMRUItem Me.CommonDialog1.FileName
End Sub

Private Sub AddMRUItem(NewItem As String)
    Dim result As Long

    result = CheckForDuplicateMRU(NewItem)

    If result <> NotFound Then
        ReorderMRUList NewItem, result
    Else
        AddMenuElement NewItem
    End If
End Sub

Private Function CheckForDuplicateMRU(ByVal NewItem As String) As Long
    Dim i As Long

    NewItem = UCase$(NewItem)

    For i = 0 To MRUCount
        If UCase$(Me.mnuMRU(i).Caption) = NewItem Then
            CheckForDuplicateMRU = i

            Exit Function
        End If
    Next i

    CheckForDuplicateMRU = -1
End Function

Private Sub mnuQuit_Click()
    Unload Me
End Sub

Private Sub AddMenuElement(NewItem As String)
    Dim i As Long

    If (MRUCount < (MaxMRU - 1)) Or (MaxMRU = -1) Then
        MRUCount = MRUCount + 1

        If MRUCount <> 0 Then
            Load mnuMRU(MRUCount)
        End If

        mnuMRU(MRUCount).Visible = True
    End If

    For i = (MRUCount) To 1 Step -1
        mnuMRU(i).Caption = mnuMRU(i - 1).Caption
    Next i

    mnuMRU(0).Caption = NewItem
End Sub

Private Sub ReorderMRUList(DuplicateMRU As String, DuplicateLocation As Long)
    Dim i As Long

    For i = DuplicateLocation To 1 Step -1
        mnuMRU(i).Caption = mnuMRU(i - 1).Caption
    Next i

    mnuMRU(0).Caption = DuplicateMRU
End Sub

Private Sub GetMRUFileList()
    Dim i As Long
    Dim result As String

    Do
        result = GetSetting(App.Title, "MRUFiles", Trim$(CStr(i)), "")

        If result <> "" Then
            AddMRUItem result
        End If

        i = i + 1
    Loop Until (result = "")
End Sub

Private Sub SaveMRUFileList()
    Dim i As Long

    For i = 0 To MRUCount
        SaveSetting App.Title, "MRUFiles", Trim$(CStr(i)), mnuMRU(i).Caption
    Next i
End Sub

Contoh Mengisi ListView Dengan Database

Option Explicit

Function FillList(strDomain As String, objListView As Object) As Boolean
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim intTotCount As Integer
    Dim intCount1 As Integer
    Dim intCount2 As Integer
    Dim colNew As ColumnHeader
    Dim itmNewLine As ListItem

    On Error GoTo Err_Handler

    objListView.ListItems.Clear
    objListView.ColumnHeaders.Clear

    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(strDomain)

    For intCount1 = 0 To rst.Fields.Count - 1
        Set colNew = objListView.ColumnHeaders.Add(, , rst(intCount1).Name)
    Next intCount1

    objListView.View = 3

    rst.MoveLast
    intTotCount = rst.RecordCount
    rst.MoveFirst

    For intCount1 = 1 To intTotCount
        If IsNumeric(rst(0).Value) Then
            Set itmNewLine = objListView.ListItems.Add(, , Str(rst(0).Value))
        Else
            Set itmNewLine = objListView.ListItems.Add(, , rst(0).Value)
        End If

        For intCount2 = 1 To rst.Fields.Count - 1
            itmNewLine.SubItems(intCount2) = rst(intCount2).Value
        Next intCount2

        rst.MoveNext
    Next intCount1

    Exit Function

Err_Handler:
    If Err = 94 Then
        Resume Next
    Else
        MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
    End If
End Function

Private Sub Form_Load()
    Dim intResult As Integer
    intResult = FillList("Employees", Me!ctlListView)
End Sub

Contoh Mengisi ListView Secara Recursive

Function FirstFileMatch()

    Dim strFileName As String
    On Error Resume Next

    strFileName = Dir(InputBox("Enter a valid path and file name."))
    If strFileName = "" Then
        FirstFileMatch = FirstFileMatch()
    Else
        FirstFileMatch = strFileName
    End If

End Function

Private Sub Form_Load()
    Const strTableQueryName = "Employees"
    Dim db As DAO.Database, rst As DAO.Recordset
    Set db = CurrentDb
    Set rst = db.OpenRecordset(strTableQueryName, dbOpenDynaset, dbReadOnly)
    AddBranch rst:=rst, strPointerField:="ReportsTo", strIDField:="EmployeeID", strTextField:="LastName"
End Sub

Sub AddBranch(rst As Recordset, strPointerField As String, strIDField As String, strTextField As String, Optional varReportToID As Variant)
    On Error GoTo errAddBranch
    Dim nodCurrent As node, objTree As TreeView
    Dim strCriteria As String, strText As String, strKey As String
    Dim nodParent As node, bk As String
    Set objTree = Me!xTree.object
    If IsMissing(varReportToID) Then
        strCriteria = strPointerField & " Is Null"
    Else
        strCriteria = BuildCriteria(strPointerField, rst.Fields(strPointerField).Type, "=" & varReportToID)
        Set nodParent = objTree.Nodes("a" & varReportToID)
    End If

    rst.FindFirst strCriteria
    Do Until rst.NoMatch
        strText = rst(strTextField)
        strKey = "a" & rst(strIDField)
        If Not IsMissing(varReportToID) Then
            Set nodCurrent = objTree.Nodes.Add(nodParent, tvwChild, strKey, strText)
        Else
            Set nodCurrent = objTree.Nodes.Add(, , strKey, strText)
        End If
        bk = rst.Bookmark
        AddBranch rst, strPointerField, strIDField, strTextField, rst(strIDField)
        rst.Bookmark = bk
        rst.FindNext strCriteria
    Loop

exitAddBranch:
    Exit Sub

errAddBranch:
    MsgBox "Can"
    Resume exitAddBranch
End Sub

Rename Node TreeView Seperti Pada Explorer

Option Explicit

Dim sNodeText As String

Private Sub Form_Load()
    TreeView1.Nodes.Add , , , "test"
    TreeView1.Nodes.Add , , , "test 1"
    TreeView1.Nodes.Add , , , "test 2"
End Sub

Private Sub Timer1_Timer()
    TreeView1.StartLabelEdit
    Timer1.Enabled = False
End Sub

Private Sub TreeView1_AfterLabelEdit(Cancel As Integer, NewString As String)
    If Len(NewString) < 1 Then
        MsgBox "Error! You must enter a value"
        Timer1.Interval = 100
        Timer1.Enabled = True
    End If
End Sub

Private Sub TreeView1_BeforeLabelEdit(Cancel As Integer)
    If Len(TreeView1.SelectedItem.Text) > 0 Then
        sNodeText = TreeView1.SelectedItem.Text
    End If
End Sub

Private Sub TreeView1_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyEscape Then
        TreeView1.SelectedItem.Text = sNodeText
    End If
End Sub

Mengubat BackGround TreeView Control

Option Explicit

Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
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 GWL_STYLE = -16&
Private Const TVM_SETBKCOLOR = 4381&
Private Const TVM_GETBKCOLOR = 4383&
Private Const TVS_HASLINES = 2&

Dim frmlastForm As Form

Private Sub Form_Load()
    Dim nodX As node
    Set nodX = TreeView1.Nodes.Add(, , "R", "Root")
    Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C1", "Child 1")
    Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C2", "Child 2")
    Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C3", "Child 3")
    Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C4", "Child 4")
    nodX.EnsureVisible
    TreeView1.Style = tvwTreelinesText
    TreeView1.BorderStyle = vbFixedSingle
End Sub

Private Sub Command1_Click()
    Dim lngStyle As Long
    Call SendMessage(TreeView1.hWnd, TVM_SETBKCOLOR, 0, ByVal RGB(255, 0, 0))
    lngStyle = GetWindowLong(TreeView1.hWnd, GWL_STYLE)
    Call SetWindowLong(TreeView1.hWnd, GWL_STYLE, lngStyle - TVS_HASLINES)
    Call SetWindowLong(TreeView1.hWnd, GWL_STYLE, lngStyle)
End Sub

Cara Membuat Generic Handler Error

Option Explicit

Private Sub Form_Load()
    On Error GoTo FormLoadErr
    Err.Raise 76
    Err.Raise 70
    Exit Sub

FormLoadErr:
    Select Case Err.Number
        Case 76
            MsgBox "Form_Load Error Handler. Form Does Not Exist"
        Case Else
            AppWideErr (Err.Number)
    End Select
End Sub

Private Sub Command1_Click()
    On Error GoTo Cmd1Err
    Err.Raise 53
    Err.Raise 70
    Exit Sub

Cmd1Err:
    Select Case Err.Number
        Case 53
            MsgBox "Command 1 Error Handler"
        Case Else
            AppWideErr (Err.Number)
    End Select
    Resume Next
End Sub

Private Sub Command2_Click()
    Form2.Show
End Sub

Private Sub Command1_Click()
    On Error GoTo ThisSubErr
    Err.Raise 17
    Exit Sub
ThisSubErr:
    AppWideErr (Err.Number)
End Sub

Public Sub AppWideErr(lnErrNumber)
    Select Case lnErrNumber
        Case 70
            MsgBox "Generic Routine.  Access Denied.  See Net Administrator.", , "AppWideErr"
            Exit Sub
        Case Else
            MsgBox "Generic Routine. Unhandled Error: " + Err.Description + " # " & lnErrNumber, , "AppWideErr"
            Exit Sub
    End Select
End Sub

Membuat Aplikasi Console Dengan Visual Basic 6.0

Option Explicit

Declare Function AllocConsole Lib "kernel32" () As Long
Declare Function FreeConsole Lib "kernel32" () As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" (ByVal hConsoleOutput As Long, lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long

Public Const STD_OUTPUT_HANDLE = -11&
Dim hConsole As Long

Private Sub Command1_Click()
    Dim Result As Long, sOut As String, cWritten As Long
    sOut = "Hi There" & vbCrLf
    Result = WriteConsole(hConsole, ByVal sOut, Len(sOut), cWritten, ByVal 0&)
    Shell "C:\TEST.BAT"
End Sub

Private Sub Form_Load()
    If AllocConsole() Then
        hConsole = GetStdHandle(STD_OUTPUT_HANDLE)
        If hConsole = 0 Then MsgBox "Couldn"
    Else
        MsgBox "Couldn"
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    CloseHandle hConsole
    FreeConsole
End Sub

Contoh Membuat Picture Yang Dapat DiScroll

Option Explicit

Private Sub Form_Load()

    Picture1.Move 0, 0, ScaleWidth - VScroll1.Width, ScaleHeight - HScroll1.Height

    With Picture2
        .AutoSize = True

        .Picture = LoadPicture("splash.bmp")

        .Move 0, 0
    End With

    With HScroll1
        .Top = Picture1.Height
        .Left = 0
        .Width = Picture1.Width
    End With

    With VScroll1
        .Top = 0
        .Left = Picture1.Width
        .Height = Picture1.Height
    End With

    HScroll1.Max = Picture2.Width - Picture1.Width
    VScroll1.Max = Picture2.Height - Picture1.Height
    HScroll1.LargeChange = HScroll1.Max / 10
    VScroll1.LargeChange = VScroll1.Max / 10
    HScroll1.SmallChange = HScroll1.Max / 25
    VScroll1.SmallChange = VScroll1.Max / 25

    VScroll1.Visible = (Picture1.Height < Picture2.Height)
    HScroll1.Visible = (Picture1.Width < Picture2.Width)
End Sub

Private Sub HScroll1_Change()

    Picture2.Left = -HScroll1.Value

End Sub

Private Sub VScroll1_Change()

    Picture2.Top = -VScroll1.Value

End Sub

Private Sub Form_Resize()
    With Picture1
        .Height = Form1.Height
        .Width = Form1.Width
    End With

    Picture1.Move 0, 0, ScaleWidth - VScroll1.Width, ScaleHeight - HScroll1.Height
    Picture2.Move 0, 0

    With HScroll1
        .Top = Picture1.Height
        .Left = 0
        .Width = Picture1.Width
        .Max = Picture2.Width - Picture1.Width
    End With

    With VScroll1
        .Top = 0
        .Left = Picture1.Width
        .Height = Picture1.Height
        .Max = Picture2.Height - Picture1.Height
    End With

    VScroll1.Visible = (Picture1.Height < Picture2.Height)
    HScroll1.Visible = (Picture1.Width < Picture2.Width)
End Sub

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

Contoh Print Preeview Pada Visual Basic 6.0

Option Explicit

Private Sub Form_Load()
    CommonDialog1.CancelError = True
    Command1.Caption = "Load Picture"
    Command2.Caption = "Print Preview"
    Command3.Caption = "Print"
End Sub

Private Sub Command1_Click()
    Dim sFileFilter As String

    On Error GoTo ErrHandler

    sFileFilter = "Bitmap Files (*.bmp)|*.bmp|"
    sFileFilter = sFileFilter & "GIF Files (*.gif)|*.gif|"
    sFileFilter = sFileFilter & "Icon Files (*.ico)|*.ico|"
    sFileFilter = sFileFilter & "JPEG Files (*.jpg)|*.jpg|"
    sFileFilter = sFileFilter & "Windows MetaFiles (*.wmf)|.wmf"
    With CommonDialog1
        .Filter = sFileFilter
        .ShowOpen
        If .FileName <> " " Then
            Picture2.Picture = LoadPicture(.FileName)
        End If
    End With

ErrHandler:
    Exit Sub
End Sub

Private Sub Command2_Click()
    Dim dRatio As Double
    dRatio = ScalePicPreviewToPrinterInches(Picture1)
    PrintRoutine Picture1, dRatio
End Sub

Private Sub Command3_Click()
    Printer.ScaleMode = vbInches
    PrintRoutine Printer
    Printer.EndDoc
End Sub

Private Function ScalePicPreviewToPrinterInches _
    (picPreview As PictureBox) As Double

    Dim Ratio As Double ' Ratio between Printer and Picture
    Dim LRGap As Double, TBGap As Double
    Dim HeightRatio As Double, WidthRatio As Double
    Dim PgWidth As Double, PgHeight As Double
    Dim smtemp As Long

    ' Get the physical page size in Inches:
    PgWidth = Printer.Width / 1440
    PgHeight = Printer.Height / 1440

    ' Find the size of the non-printable area on the printer to
    ' use to offset coordinates. These formulas assume the
    ' printable area is centered on the page:
    smtemp = Printer.ScaleMode
    Printer.ScaleMode = vbInches
    LRGap = (PgWidth - Printer.ScaleWidth) / 2
    TBGap = (PgHeight - Printer.ScaleHeight) / 2
    Printer.ScaleMode = smtemp

    ' Scale PictureBox to Printer's printable area in Inches:
    picPreview.ScaleMode = vbInches

    ' Compare the height and with ratios to determine the
    ' Ratio to use and how to size the picture box:
    HeightRatio = picPreview.ScaleHeight / PgHeight
    WidthRatio = picPreview.ScaleWidth / PgWidth

    If HeightRatio < WidthRatio Then
        Ratio = HeightRatio
        smtemp = picPreview.Container.ScaleMode
        picPreview.Container.ScaleMode = vbInches
        picPreview.Width = PgWidth * Ratio
        picPreview.Container.ScaleMode = smtemp
    Else
        Ratio = WidthRatio
        smtemp = picPreview.Container.ScaleMode
        picPreview.Container.ScaleMode = vbInches
        picPreview.Height = PgHeight * Ratio
        picPreview.Container.ScaleMode = smtemp
    End If

    ' Set default properties of picture box to match printer
    ' There are many that you could add here:
    picPreview.Scale (0, 0)-(PgWidth, PgHeight)
    picPreview.Font.Name = Printer.Font.Name
    picPreview.FontSize = Printer.FontSize * Ratio
    picPreview.ForeColor = Printer.ForeColor
    picPreview.Cls

    ScalePicPreviewToPrinterInches = Ratio
End Function

Private Sub PrintRoutine(objPrint As Object, _
    Optional Ratio As Double = 1)
    ' All dimensions in inches:

    ' Print some graphics to the control object
    objPrint.Line (1, 1)-(1 + 6.5, 1 + 9), , B
    objPrint.Line (1.1, 2)-(1.1, 2)
    objPrint.PaintPicture Picture2, 1.1, 1.1, 0.8, 0.8
    objPrint.Line (2.1, 1.2)-(2.1 + 5.2, 1.2 + 0.7), _
    RGB(200, 200, 200), BF

    ' Print a title
    With objPrint
        .Font.Name = "Arial"
        .CurrentX = 2.3
        .CurrentY = 1.3
        .FontSize = 35 * Ratio
        objPrint.Print "Visual Basic Printing"
    End With

    ' Print some circles
    Dim x As Single
    For x = 3 To 5.5 Step 0.2
        objPrint.Circle (x, 3.5), 0.75
    Next

    ' Print some text
    With objPrint
        .Font.Name = "Courier New"
        .FontSize = 30 * Ratio
        .CurrentX = 1.5
        .CurrentY = 5
        objPrint.Print "It is possible to do"

        .FontSize = 24 * Ratio
        .CurrentX = 1.5
        .CurrentY = 6.5
        objPrint.Print "It is possible to do print"

        .FontSize = 18 * Ratio
        .CurrentX = 1.5
        .CurrentY = 8
        objPrint.Print "It is possible to do print preview"
    End With
End Sub

Memperoleh Array Dari Prosedur Fungsi

Option Explicit

Private aiLeftSide() As Integer
Private asLeftSide() As String
Private aiRightSide(1 To 10) As Integer
Private asRightSide(1 To 10) As String
Private obj As Object

Public Function ArrayFromClass() As String()
    Dim astr(1 To 10) As String
    Dim i As Integer
    For i = 1 To 10
        astr(i) = "Class array element " & Str(i)
    Next i
    ArrayFromClass = astr()
End Function

Private Sub Command1_Click()
    Dim i As Integer
    aiLeftSide = aiRightSide
    asLeftSide = asRightSide
    For i = 1 To UBound(aiLeftSide)
        Debug.Print aiLeftSide(i)
    Next i
    For i = 1 To UBound(asLeftSide)
        Debug.Print asLeftSide(i)
    Next i
End Sub

Private Sub Command2_Click()
    Dim i As Integer
    Dim aInt() As Integer
    Dim astr() As String
    aInt = ReturnIntArray
    astr = ReturnStringArray
    For i = 1 To UBound(aInt)
        Debug.Print aInt(i)
    Next i
    For i = 1 To UBound(astr)
        Debug.Print astr(i)
    Next i
End Sub

Private Sub Command3_Click()
    Dim astr() As String
    Dim i As Integer
    astr = obj.ArrayFromClass
    For i = 1 To UBound(astr)
        Debug.Print astr(i)
    Next i
End Sub

Private Sub Form_Load()
    Dim i As Integer
    Command1.Caption = "Assign Array"
    Command2.Caption = "Call Function that returns Array"
    Command3.Caption = "Call Object method that returns Array"
    For i = 1 To 10
        aiRightSide(i) = i
        asRightSide(i) = "This is element " & Str(i)
    Next i
    Set obj = New Class1
End Sub

Private Function ReturnStringArray() As String()
    Dim aString(1 To 10) As String
    Dim i As Integer
    For i = 1 To UBound(aString)
        aString(i) = "Element " & Str(i)
    Next i
    ReturnStringArray = aString()
End Sub

Private Function ReturnIntArray() As Integer()
    Dim aInt(1 To 10) As Integer
    Dim i As Integer
    For i = 1 To 10
        aInt(i) = i
    Next i
    ReturnIntArray = aInt()
End Sub

Mengirim dan Menerima Email Menggunakan MAPI

Option Explicit

Dim X As Long

Private Sub Command1_Click()

    If X - 1 < 0 Then
    Else
        X = X - 1
        MAPIMessages1.MsgIndex = X
        Text1.Text = MAPIMessages1.RecipDisplayName
        Text2.Text = MAPIMessages1.MsgSubject
        Text3.Text = MAPIMessages1.MsgOrigDisplayName
        Text4.Text = MAPIMessages1.MsgNoteText
    End If

End Sub

Private Sub Command2_Click()

    If X + 1 > MAPIMessages1.MsgCount Then
        X = MAPIMessages1.MsgCount
    Else
        X = X + 1
        MAPIMessages1.MsgIndex = X
        Text1.Text = MAPIMessages1.RecipDisplayName
        Text2.Text = MAPIMessages1.MsgSubject
        Text3.Text = MAPIMessages1.MsgOrigDisplayName
        Text4.Text = MAPIMessages1.MsgNoteText
    End If

End Sub

Private Sub Command3_Click()
    MAPISession1.SignOn
    MAPIMessages1.SessionID = MAPISession1.SessionID
    MAPIMessages1.Fetch
    If MAPIMessages1.MsgCount > 0 Then
        Text1.Text = MAPIMessages1.RecipDisplayName
        Text2.Text = MAPIMessages1.MsgSubject
        Text3.Text = MAPIMessages1.MsgOrigDisplayName
        Text4.Text = MAPIMessages1.MsgNoteText
        Command4.Enabled = True
    Else
        MsgBox "No messages to fetch"
        MAPISession1.SignOff
        Command4.Enabled = False
    End If

End Sub

Private Sub Command4_Click()

    MAPIMessages1.Compose
    MAPIMessages1.RecipDisplayName = Text1.Text
    MAPIMessages1.MsgSubject = Text2.Text
    MAPIMessages1.MsgNoteText = Text4.Text
    MAPIMessages1.ResolveName
    MAPIMessages1.Send

End Sub

Private Sub Command5_Click()

    MAPISession1.SignOff
    Unload Me

End Sub

Form dan Control Yang Terbebas Resolusi Layar

'Kode Pada Form
Option Explicit

Dim MyForm As FRMSIZE
Dim DesignX As Integer
Dim DesignY As Integer

Private Sub Form_Load()
    Dim ScaleFactorX As Single, ScaleFactorY As Single  ' Scaling factors
    ' Size of Form in Pixels at design resolution
    DesignX = 800
    DesignY = 600
    RePosForm = True   ' Flag for positioning Form
    DoResize = False   ' Flag for Resize Event
    ' Set up the screen values
    Xtwips = Screen.TwipsPerPixelX
    Ytwips = Screen.TwipsPerPixelY
    Ypixels = Screen.Height / Ytwips ' Y Pixel Resolution
    Xpixels = Screen.Width / Xtwips  ' X Pixel Resolution

    ' Determine scaling factors
    ScaleFactorX = (Xpixels / DesignX)
    ScaleFactorY = (Ypixels / DesignY)
    ScaleMode = 1  ' twips
    'Exit Sub  ' uncomment to see how Form1 looks without resizing
    Resize_For_Resolution ScaleFactorX, ScaleFactorY, Me
    Label1.Caption = "Current resolution is " & Str$(Xpixels) + _
    "  by " + Str$(Ypixels)
    MyForm.Height = Me.Height ' Remember the current size
    MyForm.Width = Me.Width
End Sub

Private Sub Form_Resize()
    Dim ScaleFactorX As Single, ScaleFactorY As Single

    If Not DoResize Then  ' To avoid infinite loop
        DoResize = True
        Exit Sub
    End If

    RePosForm = False
    ScaleFactorX = Me.Width / MyForm.Width   ' How much change?
    ScaleFactorY = Me.Height / MyForm.Height
    Resize_For_Resolution ScaleFactorX, ScaleFactorY, Me
    MyForm.Height = Me.Height ' Remember the current size
    MyForm.Width = Me.Width
End Sub

Private Sub Command1_Click()
    Dim ScaleFactorX As Single, ScaleFactorY As Single

    DesignX = Xpixels
    DesignY = Ypixels
    RePosForm = True
    DoResize = False
    ' Set up the screen values
    Xtwips = Screen.TwipsPerPixelX
    Ytwips = Screen.TwipsPerPixelY
    Ypixels = Screen.Height / Ytwips ' Y Pixel Resolution
    Xpixels = Screen.Width / Xtwips  ' X Pixel Resolution

    ' Determine scaling factors
    ScaleFactorX = (Xpixels / DesignX)
    ScaleFactorY = (Ypixels / DesignY)
    Resize_For_Resolution ScaleFactorX, ScaleFactorY, Me
    Label1.Caption = "Current resolution is " & Str$(Xpixels) + _
    "  by " + Str$(Ypixels)
    MyForm.Height = Me.Height ' Remember the current size
    MyForm.Width = Me.Width
End Sub

'Kode pada Module
Option Explicit

Public Xtwips As Integer, Ytwips As Integer
Public Xpixels As Integer, Ypixels As Integer

Type FRMSIZE
    Height As Long
    Width As Long
End Type

Public RePosForm As Boolean
Public DoResize As Boolean

Sub Resize_For_Resolution(ByVal SFX As Single, ByVal SFY As Single, MyForm As Form)
    Dim I As Integer
    Dim SFFont As Single

    SFFont = (SFX + SFY) / 2
    On Error Resume Next
    With MyForm
        For I = 0 To .Count - 1
            If TypeOf .Controls(I) Is ComboBox Then
                .Controls(I).Left = .Controls(I).Left * SFX
                .Controls(I).Top = .Controls(I).Top * SFY
                .Controls(I).Width = .Controls(I).Width * SFX
            Else
                .Controls(I).Move .Controls(I).Left * SFX, .Controls(I).Top * SFY, .Controls(I).Width * SFX, .Controls(I).Height * SFY
            End If
            .Controls(I).FontSize = .Controls(I).FontSize * SFFont
        Next I
        If RePosForm Then
            .Move .Left * SFX, .Top * SFY, .Width * SFX, .Height * SFY
        End If
    End With
End Sub

Contoh Menjalankan Procedure Di dalam Script Control

Option Explicit

Private Sub Command1_Click()
    ScriptControl1.Modules.Add Text1.Text
    Form_Activate
End Sub

Private Sub Command2_Click()
    ScriptControl1.Modules(List1).AddCode Text1.Text
    List1_Click
End Sub

Private Sub Command3_Click()
    Dim RetVal As Variant, m As Variant
    Set m = ScriptControl1.Modules(List1.Text)
    With m.Procedures(List2.Text)
        Select Case .NumArgs
            Case 0
                RetVal = m.Run(List2.Text)
            Case 1
                RetVal = m.Run(List2.Text, 5)
            Case 2
                RetVal = m.Run(List2.Text, 4, 23)
            Case Else
                MsgBox "Procedure has too many arguments"
        End Select
        If .HasReturnValue Then
            MsgBox List2.Text & " returned: " & RetVal
        End If
    End With
End Sub

Private Sub Form_Activate()
    Dim m As Variant
    List1.Clear
    With ScriptControl1
        .Language = "VBScript"
        .AllowUI = True
        For Each m In .Modules
            List1.AddItem m.Name
        Next m
    End With
End Sub

Private Sub Form_Load()
    Command1.Caption = "Add Module"
    Command2.Caption = "Add Code"
    Command3.Caption = "Run Procedure"
End Sub

Private Sub List1_Click()
    Dim m As String, p As Variant
    m = List1
    List2.Clear
    If m = "" Then Exit Sub
    For Each p In ScriptControl1.Modules(m).Procedures
        List2.AddItem p.Name
    Next p
End Sub

Private Sub List2_Click()
    Dim m As String, p As String, r As Boolean, a As Long
    m = List1
    p = List2
    With ScriptControl1.Modules(m).Procedures(p)
        r = .HasReturnValue
        a = .NumArgs
    End With
    MsgBox m & "." & p & " has " & IIf(r, "a", "no") & _
    " return value and " & a & " arguments"
End Sub

'Tambahkan module dan prosedur di bawah ini pada script control
Function Calc(X)
    Calc = X * 2
End Function

Function Calc(X, Y)
    Calc = X * Y
End Function

Sub Test()
    MsgBox "The Test Sub in Module Mod2"
End Sub

Cara Menggunakan Error Object Yang Ada Pada Script Control

Option Explicit

Private Sub Command1_Click()
    On Error Resume Next
    With ScriptControl1
        .Language = "VBScript"
        .AllowUI = True
        .AddCode Text1.Text
        .Run "Test"
    End With
    If Err Then
        MsgBox Err & " " & Error
        ListErrors ScriptControl1
    End If
End Sub

Private Sub ListErrors(S As ScriptControl)
    With S.Error
        Debug.Print "Number:", .Number
        Debug.Print "Source:", .Source
        Debug.Print "Desc:", .Description
        Debug.Print "Line: " & .Line, "Column: " & .Column
        Debug.Print "Text:", .Text
        Debug.Print "Help File:", .HelpFile
        Debug.Print "Help Context:", .HelpContext
        Debug.Print
    End With
End Sub

Contoh Memparsing XML Attributes

Private Sub Command1_Click()

    Dim fso As Object
    Dim sDir As String
    Dim doc As Object
    Dim oFile As Object

    Set fso = CreateObject("Scripting.FileSystemObject")
    sDir = "C:\work"
    Set doc = CreateObject("Msxml2.DOMDocument")
    doc.async = False
    For Each oFile In fso.GetFolder(sDir).Files
        Debug.Print "looking at", oFile.Name
        Debug.Print "will load", oFile.Path
        If doc.Load(oFile.Path) Then
            Debug.Print "successfully loaded", oFile.Name
        End If
    Next
    Set ndlEventId = doc.documentElement.selectNodes("//*")
    For i = 0 To ndlEventId.length - 1
        Debug.Print ndlEventId(i).nodeName & " :: " & ndlEventId(i).Text
        If ndlEventId(i).Text = "" Then
            s = ndlEventId(i).nodeName
            Debug.Print s
            Set attrvalue = doc.getAttribute(s)
            Debug.Print attrvalue
        End If
    Nex
End Sub

Konversi Detik Ke Hari, Jam, Menit, dan Detik

Public Function SecondsToDateTimeSerial(ByVal Sec As Long) As String
    Dim lngSecParam As Long
    Dim lngSeconds As Long
    Dim lngHours As Long
    Dim lngMinutes As Long
    Dim tempSecParam As Long

    lngSecParam = Sec
    lngSeconds = lngSecParam \ 86400
    lngSecParam = lngSecParam - (lngSeconds * 86400)
    lngHours = lngSecParam \ 3600
    lngSecParam = lngSecParam - (lngHours * 3600)
    lngMinutes = lngSecParam \ 60
    lngSecParam = lngSecParam - (lngMinutes * 60)
    tempSecParam = lngSecParam

    SecondsToDateTimeSerial = _
    IIf(Sec >= 86400, lngSeconds & " day(s), ", vbNullString) & _
    IIf(Sec >= 0, Format(lngHours, "0#") & ":", vbNullString) & _
    Format(lngMinutes, "0#") & ":" & Format(tempSecParam, "0#")
End Function

MSXML Encode Decode Base64

Private Function EncodeBase64(ByRef arrData() As Byte) As String

    Dim objXML As MSXML2.DOMDocument
    Dim objNode As MSXML2.IXMLDOMElement

    ' help from MSXML
    Set objXML = New MSXML2.DOMDocument

    ' byte array to base64
    Set objNode = objXML.createElement("b64")
    objNode.dataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    EncodeBase64 = objNode.Text

    ' thanks, bye
    Set objNode = Nothing
    Set objXML = Nothing

End Function

Private Function DecodeBase64(ByVal strData As String) As Byte()

    Dim objXML As MSXML2.DOMDocument
    Dim objNode As MSXML2.IXMLDOMElement

    ' help from MSXML
    Set objXML = New MSXML2.DOMDocument
    Set objNode = objXML.createElement("b64")
    objNode.dataType = "bin.base64"
    objNode.Text = strData
    DecodeBase64 = objNode.nodeTypedValue

    ' thanks, bye
    Set objNode = Nothing
    Set objXML = Nothing

End Function

Public Sub Main()

    Dim strData As String

    strData = EncodeBase64(StrConv("Greetings and Salutations", vbFromUnicode))
    Debug.Print strData
    Debug.Print StrConv(DecodeBase64(strData), vbUnicode)

End Sub

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

Contoh Menggunakan Proxy Pada Internet Transfer Control

Private Sub Command1_Click()
    Inet1.AccessType = icNamedProxy
    Inet1.Proxy = "ftp=ftp://ftp-gw"
    Inet1.URL = "ftp://ftp.microsoft.com"
    Inet1.Execute , "DIR"
End Sub

Private Sub Command2_Click()
    Inet2.AccessType = icNamedProxy
    Inet2.Proxy = "http://proxy:80"
    MsgBox Inet1.OpenURL("http://www.microsoft.com")
End Sub

Private Sub Command3_Click()
    Inet3.AccessType = icNamedProxy
    Inet3.Proxy = "ftp=ftp://ftp-gw http=http://itgproxy:80"
    MsgBox Inet2.OpenURL("http://www.microsoft.com")
End Sub

Private Sub Inet1_StateChanged(ByVal State As Integer)
    Dim vtData As Variant
    Select Case State
        Case icResponseCompleted
            Open "c:\temp\output.txt" For Binary Access Write As #1

            vtData = Inet1.GetChunk(1024, icString)

            Do While LenB(vtData) > 0
                Put #1, , vtData
                vtData = Inet1.GetChunk(1024, icString)
            Loop
            Put #1, , vtData
            Close #1
    End Select
End Sub

Contoh Mengurutkan ListView Berdasarkan Tanggal

'Kode pada Module
Option Explicit

Public Type POINT
    x As Long
    y As Long
End Type

Public Type LV_FINDINFO
    flags As Long
    psz As String
    lParam As Long
    pt As POINT
    vkDirection As Long
End Type

Public Type LV_ITEM
    mask As Long
    iItem As Long
    iSubItem As Long
    State As Long
    stateMask As Long
    pszText As Long
    cchTextMax As Long
    iImage As Long
    lParam As Long
    iIndent As Long
End Type

Private Const LVFI_PARAM = 1
Private Const LVIF_TEXT = &H1
Private Const LVM_FIRST = &H1000
Private Const LVM_FINDITEM = LVM_FIRST + 13
Private Const LVM_GETITEMTEXT = LVM_FIRST + 45
Public Const LVM_SORTITEMS = LVM_FIRST + 48

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

Public Function CompareDates(ByVal lngParam1 As Long, ByVal lngParam2 As Long, ByVal hWnd As Long) As Long

    Dim strName1 As String
    Dim strName2 As String
    Dim dDate1 As Date
    Dim dDate2 As Date

    ListView_GetItemData lngParam1, hWnd, strName1, dDate1
    ListView_GetItemData lngParam2, hWnd, strName2, dDate2

    If dDate1 < dDate2 Then
        CompareDates = 0
    ElseIf dDate1 = dDate2 Then
        CompareDates = 1
    Else
        CompareDates = 2
    End If

End Function

Public Sub ListView_GetItemData(lngParam As Long, hWnd As Long, strName As String, dDate As Date)
    Dim objFind As LV_FINDINFO
    Dim lngIndex As Long
    Dim objItem As LV_ITEM
    Dim baBuffer(32) As Byte
    Dim lngLength As Long

    objFind.flags = LVFI_PARAM
    objFind.lParam = lngParam
    lngIndex = SendMessage(hWnd, LVM_FINDITEM, -1, VarPtr(objFind))

    objItem.mask = LVIF_TEXT
    objItem.iSubItem = 0
    objItem.pszText = VarPtr(baBuffer(0))
    objItem.cchTextMax = UBound(baBuffer)
    lngLength = SendMessage(hWnd, LVM_GETITEMTEXT, lngIndex, VarPtr(objItem))
    strName = Left$(StrConv(baBuffer, vbUnicode), lngLength)

    objItem.mask = LVIF_TEXT
    objItem.iSubItem = 1
    objItem.pszText = VarPtr(baBuffer(0))
    objItem.cchTextMax = UBound(baBuffer)
    lngLength = SendMessage(hWnd, LVM_GETITEMTEXT, lngIndex, VarPtr(objItem))
    If lngLength > 0 Then
        dDate = CDate(Left$(StrConv(baBuffer, vbUnicode), lngLength))
    End If

End Sub

Public Sub ListView_GetListItem(lngIndex As Long, hWnd As Long, strName As String, dDate As Date)
    Dim objItem As LV_ITEM
    Dim baBuffer(32) As Byte
    Dim lngLength As Long

    objItem.mask = LVIF_TEXT
    objItem.iSubItem = 0
    objItem.pszText = VarPtr(baBuffer(0))
    objItem.cchTextMax = UBound(baBuffer)
    lngLength = SendMessage(hWnd, LVM_GETITEMTEXT, lngIndex, VarPtr(objItem))
    strName = Left$(StrConv(baBuffer, vbUnicode), lngLength)

    objItem.mask = LVIF_TEXT
    objItem.iSubItem = 1
    objItem.pszText = VarPtr(baBuffer(0))
    objItem.cchTextMax = UBound(baBuffer)
    lngLength = SendMessage(hWnd, LVM_GETITEMTEXT, lngIndex, VarPtr(objItem))
    If lngLength > 0 Then
        dDate = CDate(Left$(StrConv(baBuffer, vbUnicode), lngLength))
    End If

End Sub


'Kode pada Form
Option Explicit

Private Sub Form_Load()

    Dim clmAdd As ColumnHeader
    Dim itmAdd As ListItem

    Set clmAdd = ListView1.ColumnHeaders.Add(Text:="Name")
    Set clmAdd = ListView1.ColumnHeaders.Add(Text:="Date")

    ListView1.View = lvwReport

    Set itmAdd = ListView1.ListItems.Add(Text:="Joe")
    itmAdd.SubItems(1) = "05/07/97"

    Set itmAdd = ListView1.ListItems.Add(Text:="Sally")
    itmAdd.SubItems(1) = "04/08/97"

    Set itmAdd = ListView1.ListItems.Add(Text:="Bill")
    itmAdd.SubItems(1) = "05/29/97"

    Set itmAdd = ListView1.ListItems.Add(Text:="Fred")
    itmAdd.SubItems(1) = "05/17/97"

    Set itmAdd = ListView1.ListItems.Add(Text:="Anne")
    itmAdd.SubItems(1) = "04/01/97"

End Sub

Private Sub ListView1_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)

    Dim strName As String
    Dim dDate As Date
    Dim lngItem As Long

    If ColumnHeader.Text = "Name" Then
        ListView1.Sorted = True
        ListView1.SortKey = 0
    Else
        ListView1.Sorted = False
        SendMessage ListView1.hWnd, LVM_SORTITEMS, ListView1.hWnd, AddressOf CompareDates
    End If

    ListView1.Refresh

    For lngItem = 0 To ListView1.ListItems.Count - 1
        ListView_GetListItem lngItem, ListView1.hWnd, strName, dDate
    Next

End Sub

Contoh Menggunakan tarts-with() Dalam Fungsi XPath

Private Sub Command1_Click()
    Dim doc As MSXML2.DOMDocument
    Dim nlist As MSXML2.IXMLDOMNodeList
    Dim node As MSXML2.IXMLDOMNode

    Set doc = New MSXML2.DOMDocument
    doc.setProperty "SelectionLanguage", "XPath"
    doc.Load "c:\books.xml"
    Set nlist = doc.selectNodes("//book/author/first-name[starts-with(.,'M')]")
    MsgBox "Matching Nodes : " & nlist.length

    For Each node In nlist
      Debug.Print node.nodeName & " : " & node.Text
    Next
End Sub

Contoh Kode XML Query XPath

Option Explicit

Dim gCn As New ADODB.Connection

Const DBGUID_DEFAULT As String = "{C8B521FB-5CF3-11CE-ADE5-00AA0044773D}"
Const DBGUID_SQL As String = "{C8B522D7-5CF3-11CE-ADE5-00AA0044773D}"
Const DBGUID_MSSQLXML As String = "{5D531CB2-E6Ed-11D2-B252-00C04F681B71}"
Const DBGUID_XPATH As String = "{ec2a4293-e898-11d2-b1b7-00c04f680c56}"

Private Sub cmdExitProgram_Click()
    Unload Me
    End
End Sub

Private Sub cmdTestIt_Click()

    Dim cmd As ADODB.Command
    Dim strm As ADODB.Stream

    On Error GoTo trap
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = gCn

    Set strm = New ADODB.Stream
    strm.Open
    cmd.Dialect = DBGUID_XPATH

    cmd.Properties("Mapping Schema") = App.Path & "\CustomerOrder.xdr"
    cmd.Properties("Output Stream") = strm

    txtXPath = Trim(txtXPath)
    If txtXPath = "" Then
        txtXPath = "Customers"
    End If

    cmd.CommandText = txtXPath
    cmd.Execute , , adExecuteStream
    strm.Position = 0
    txtResults = strm.ReadText
    txtResults = Replace(txtResults, "><", ">" & vbCrLf & "<")
    strm.Position = 0
    strm.Close

    GoTo cleanup

trap:

    MsgBox "Error (" & Err.Number & ") -- " & Err.Description

cleanup:
    Set strm = Nothing
    Set cmd = Nothing

    Exit Sub

End Sub

Private Sub Form_Load()

On Error GoTo trap
    Set gCn = New ADODB.Connection
    gCn.ConnectionString = "PROVIDER=SQLOLEDB;Data Source=.;Initial Catalog=Northwind;uid=sa;pwd="
    gCn.Open
    Exit Sub
trap:
    MsgBox "Failed to connect to database.  Program Shutting down."
    Unload Me
    End
End Sub

Penyimpanan URL Seperti Pada Blogger - Blogspot

Private Function BloggerTitle(Title As String) As String
    Dim strCaption() As String
    strCaption = Split(Title, " ")
    Dim i As Integer
    Dim o As String
    For i = 0 To UBound(strCaption)
        If Len(Trim$(o) & " " & strCaption(i)) < 40 Then
            o = Trim$(o) & " " & strCaption(i)
        Else
            Exit For
        End If
    Next
    BloggerTitle = LCase(Replace(Trim$(o), " ", "-"))
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

Cara Menggunakan CommonDialog Printer

Private Sub Command1_Click()
    Dim BeginPage, EndPage, NumCopies, i
On Error GoTo ErrHandler
    With CommonDialog1
        .CancelError = True
        .ShowPrinter
        BeginPage = .FromPage
        EndPage = .ToPage
        NumCopies = .Copies
    End With
    
    For i = 1 To NumCopies
        'simpan kode di sini
    Next i
    Exit Sub
ErrHandler:
    Exit Sub
End Sub

CommonDialog Help, Cara Menggunakannya

Private Sub Command1_Click()
    With CommonDialog1
        .HelpFile = "mis.chm"
        .HelpCommand = cdlHelpContents
        .ShowHelp
    End With
End Sub

CommonDialog Font, Cara Menggunakannya

Private Sub Command1_Click()
    With CommonDialog1
        .CancelError = True
        On Error GoTo ErrHandler
        .Flags = cdlCFEffects Or cdlCFBoth
        .ShowFont
        Text1.Font.Name = .FontName
        Text1.Font.Size = .FontSize
        Text1.Font.Bold = .FontBold
        Text1.Font.Italic = .FontItalic
        Text1.Font.Underline = .FontUnderline
        Text1.FontStrikethru = .FontStrikethru
        Text1.ForeColor = .Color
    End With
    Exit Sub
ErrHandler:
    Exit Sub
End Sub

CommonDialog Color, Cara Menggunakannya

Private Sub Command1_Click()
    With CommonDialog1
        .CancelError = True
        On Error GoTo ErrHandler
        .Flags = cdlCCRGBInit
        .ShowColor
        Form1.BackColor = .Color
    End With
    Exit Sub
ErrHandler:
End Sub

VB6 Code - XML Yang Mengandung Binary Data

Option Explicit

Dim oDoc As DOMDocument
Dim DOCINPATH As String
Dim XMLOUTPATH As String
Dim DOCOUTPATH As String

Private Sub cmdCreateXML_Click()

    Dim oEle As IXMLDOMElement
    Dim oRoot As IXMLDOMElement
    Dim oNode As IXMLDOMNode

    DOCINPATH = App.Path & "\DocInput.doc"
    XMLOUTPATH = App.Path & "\XmlOuput.xml"

    Call ReleaseObjects

    Set oDoc = New DOMDocument
    oDoc.resolveExternals = True

    Set oNode = oDoc.createProcessingInstruction("xml", "version='1.0'")
    Set oNode = oDoc.insertBefore(oNode, oDoc.childNodes.Item(0))

    Set oRoot = oDoc.createElement("Root")
    Set oDoc.documentElement = oRoot
    oRoot.setAttribute "xmlns:dt", "urn:schemas-microsoft-com:datatypes"

    Set oNode = oDoc.createElement("Document")
    oNode.Text = "Demo"
    oRoot.appendChild oNode

    Set oNode = oDoc.createElement("CreateDate")
    oRoot.appendChild oNode
    Set oEle = oNode

    oEle.dataType = "date"
    oEle.nodeTypedValue = Now

    Set oNode = oDoc.createElement("bgColor")
    oRoot.appendChild oNode
    Set oEle = oNode

    oEle.dataType = "bin.hex"
    oEle.Text = &HFFCCCC

    Set oNode = oDoc.createElement("Data")
    oRoot.appendChild oNode
    Set oEle = oNode

    oEle.dataType = "bin.base64"
    oEle.nodeTypedValue = ReadBinData(DOCINPATH)
    oDoc.Save XMLOUTPATH

    MsgBox XMLOUTPATH & " is created for you."

End Sub

Function ReadBinData(ByVal strFileName As String) As Variant
    Dim lLen As Long
    Dim iFile As Integer
    Dim arrBytes() As Byte
    Dim lCount As Long
    Dim strOut As String

    iFile = FreeFile()
    Open strFileName For Binary Access Read As iFile
    lLen = FileLen(strFileName)
    ReDim arrBytes(lLen - 1)
    Get iFile, , arrBytes
    Close iFile

    ReadBinData = arrBytes
End Function

Private Sub WriteBinData(ByVal strFileName As String)
    Dim iFile As Integer
    Dim arrBuffer() As Byte
    Dim oNode As IXMLDOMNode

    If Not (oDoc Is Nothing) Then
        Set oNode = oDoc.documentElement.selectSingleNode("/Root/Data")
        arrBuffer = oNode.nodeTypedValue
        iFile = FreeFile()
        Open strFileName For Binary Access Write As iFile
        Put iFile, , arrBuffer
        Close iFile
    End If

End Sub

Private Sub cmdGetBinary_Click()
    DOCOUTPATH = App.Path & "\DocOutput.doc"
    Set oDoc = New DOMDocument
    If oDoc.Load(XMLOUTPATH) = True Then
        WriteBinData DOCOUTPATH

        MsgBox DOCOUTPATH & " is created for you."
    Else
        MsgBox oDoc.parseError.reason
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ReleaseObjects
End Sub

Private Sub ReleaseObjects()
    Set oDoc = Nothing
End Sub

Menggunakan XMLHTTP dan MSXML

Private Sub Command1_Click()
    Dim soapReq As String
    Dim objSOAPXMLDoc As New MSXML2.DOMDocument30
    Dim objXMLHTTP As New MSXML2.XMLHTTP30

    Dim btArr() As Byte

    Dim backSlashPos As Integer
    Dim fileNameNoPath As String

    soapReq = " " & _
    " " & _
    "   " & _
    "  " & _
    "    " & _
    "    " & _
    "  " & _
    "   " & _
    " "

    backSlashPos = InStrRev(txtFileName.Text, "\")
    If backSlashPos > 0 Then
        fileNameNoPath = Mid(txtFileName.Text, backSlashPos + 1)
    Else
        fileNameNoPath = txtFileName.Text
    End If

    objSOAPXMLDoc.loadXML soapReq

    objSOAPXMLDoc.setProperty "SelectionNamespaces", _
    "xmlns:pxml='http://samples.perfectxml.com/BinaryData'"

    objSOAPXMLDoc.selectSingleNode("//pxml:fileName").nodeTypedValue = _
    fileNameNoPath

    objSOAPXMLDoc.selectSingleNode("//pxml:imageData").dataType = _
    "bin.base64"

    Open txtFileName.Text For Binary Access Read As #1
    ReDim btArr(LOF(1))
    Get #1, , btArr()
    Close #1

    objSOAPXMLDoc.selectSingleNode("//pxml:imageData").nodeTypedValue = btArr
    MsgBox objSOAPXMLDoc.xml

    objXMLHTTP.open "POST", "http://localhost/EmpImages/EmpImages.asmx", False

    objXMLHTTP.setRequestHeader "Content-Type", "text/xml; charset=utf-8"

    objXMLHTTP.setRequestHeader "SOAPAction", _
    "http://samples.perfectxml.com/BinaryData/SaveImage"

    objXMLHTTP.setRequestHeader "Content-Length", Len(objSOAPXMLDoc.xml)

    objXMLHTTP.send objSOAPXMLDoc.xml

    MsgBox objXMLHTTP.Status & ": " & objXMLHTTP.statusText
    MsgBox objXMLHTTP.responseText

    Set objXMLHTTP = Nothing
    Set objSOAPXMLDoc = Nothing

End Sub

Subscribe to: Posts ( Atom )

Wednesday, June 20, 2012

Sunday, June 17, 2012

Perhatian

Page Rank

Online

Statistik Pengunjung

embrio9 - Auto Reply

Blog Archive

Visual Basic 6.0

Arabic

Blogging

Miscellaneous