Sunday, June 17, 2012

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

Menutup Aplikasi Lain Berdasarkan Caption Menggunakan VB6

Mengenai cara menutup (close) aplikasi lain/luar berdasarkan caption yang ditentukan menggunakan Visual Basic 6.0 - Bagaimana kode menutup aplikasi lain menggunakan VB6 ini, bisa Anda simak kodenya di bawah ini:

Option Explicit

Private Const PROCESS_ALL_ACCESS = &H1F0FFF
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 GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal process As Long, lpExitCode As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal process As Long, ByVal uExitCode As Long) As Long

'Code that does the work
Public Function EndApplication(ByRef caption As String, ByRef frm As Form) As Boolean
    Dim hwnd As Long
    Dim appInstance As Long
    Dim process As Long
    Dim processID
    Dim result As Boolean
    Dim exitCode As Long
    Dim returnValue As Long

    On Error GoTo Error

    If Trim(caption) = "" Then Exit Function
    Do
        hwnd = FindWindowByTitle(caption, frm)
        If hwnd = 0 Then Exit Do
        appInstance = GetWindowThreadProcessId(hwnd, processID)
        'Get a handle for the process we're looking for
        process = OpenProcess(PROCESS_ALL_ACCESS, 0&, processID)
        If process <> 0 Then
            'Next get our exit code (for use later)
            GetExitCodeProcess process, exitCode
                'Check for an exit code of 9 (zero)
                If exitCode <> 0 Then
                     'It's not zero so close the window
                    returnValue = TerminateProcess(process, exitCode)
                    If result = False Then result = returnValue > 0
                End If
        End If
    Loop
    EndApplication = result
Error:
'    MsgBox (Err.Number & ": " & Err.Description)
End Function

Private Function FindWindowByTitle(ByRef str As String, ByRef frm As Form) As Long
    Dim handle As Long
    Dim caption As String
    Dim sTitle As String

    handle = frm.hwnd
    sTitle = LCase(str)
    Do
       DoEvents
          If handle = 0 Then Exit Do
            caption = LCase$(GetWindowCaption(handle))

           If InStr(caption, sTitle) Then
              FindWindowByTitle = handle
              Exit Do
           Else
             FindWindowByTitle = 0
           End If
           handle = GetNextWindow(handle, 2)
    Loop
End Function

Private Function GetWindowCaption(ByRef handle As Long) As String
    Dim str As String
    Dim length As Long

    length& = GetWindowTextLength(handle)
    str = String(length, 0)
    Call GetWindowText(handle, str, length + 1)
    GetWindowCaption = str
End Function

Contoh penggunaan kode di atas:

Private Sub Command1_Click()
    Shell "Regedit", vbNormalFocus 'membuka regedit.exe
End Sub

Private Sub Command2_Click()
    EndApplication "Registry Editor", Me 'menutup regedit.exe yang memiliki caption 'Registry Editor'
End Sub

Manipulasi ShowInTaskBar Pada Form

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_EXSTYLE = (-20)
Private Const WS_EX_APPWINDOW = &H40000

Private Function ShowInTheTaskbar(frm As Form, b As Boolean)
    Dim l As Long
    frm.Hide
    l = IIf(b, Not WS_EX_APPWINDOW, WS_EX_APPWINDOW)
    SetWindowLong frm.hWnd, GWL_EXSTYLE, (GetWindowLong(hWnd, GWL_EXSTYLE) And l)
    frm.Show
End Function

Private Sub Check1_Click()
    ShowInTheTaskbar Me, Check1.Value = 1 'toggle
End Sub

XML VB6 - Mencari Node Tertentu Menggunakan XPath

Public Function SearchForNodes(ByVal strXML As String, ByVal strTag As String, ByVal strSearchText As String) As DOMDocument
    'Will Search an XML String for a Tag-value pair and return
    'the entire node containing that pair in the form
    'of a DOM Document: 'REQUIRES REFERENCE TO MSXML
    'EXAMPLE: 'Dim objXMLDoc As New DOMDocument
    'Dim objXMLFound As DOMDocument 'Dim strXML As String
    'Load XML from file 'If objXMLDoc.Load("C:\My Documents\MyXMLFile.xml") Then
    'strXML = objXMLDoc.xml 'Search for a tag that looks like this in the xml:
    '583 'Set objXMLFound = SearchForNodes(strXML, "User_ID", "583")
    'Display the Node that was found 'Debug.Print objXMLFound.xml
    'End If
    Dim lngIterator As Long
    Dim strResults As String
    Dim objXMLSearchDocument As DOMDocument
    Dim objXMLSearchElements As IXMLDOMSelection
    Dim objXMLSearchElement As IXMLDOMElement
    Dim strXPath As String
    strResults = ""
    Set objXMLSearchDocument = New DOMDocument
    objXMLSearchDocument.async = False
    objXMLSearchDocument.setProperty "SelectionLanguage", "XPath"
    Call objXMLSearchDocument.loadXML(strXML)
    Set objXMLSearchElements = objXMLSearchDocument.getElementsByTagName(strTag)
    If objXMLSearchElements.length > 0 Then
        Set objXMLSearchElement = objXMLSearchElements.Item(0)
        Do Until Len(objXMLSearchElement.parentNode.baseName) = 0
            strXPath = "/" + objXMLSearchElement.parentNode.baseName + strXPath
            Set objXMLSearchElement = objXMLSearchElement.parentNode
        Loop
        Set objXMLSearchElement = Nothing
        strXPath = strXPath + "[" + strTag + " = '" + strSearchText + "']"
    End If
    Set objXMLSearchElements = Nothing
    If Len(strXPath) > 0 Then
        Set objXMLSearchElements = objXMLSearchDocument.selectNodes(strXPath)

        If objXMLSearchElements.length > 0 Then
            For lngIterator = 0 To (objXMLSearchElements.length - 1)
                strResults = strResults + objXMLSearchElements.Item(lngIterator).xml
            Next lngIterator
        End If
        Set objXMLSearchElements = Nothing
    End If
    Set objXMLSearchDocument = Nothing
    strResults = strResults + ""
    Set objXMLSearchDocument = New DOMDocument
    objXMLSearchDocument.async = False
    Call objXMLSearchDocument.loadXML(strResults)
    Set SearchForNodes = objXMLSearchDocument
    Set objXMLSearchDocument = Nothing
End Function

Spin Artikel Bahasa Indonesia

Apa yang dimaksud artikel spin/spin artikel/article spinner? bisa Anda baca di sini. Dengan kata lain artikel spin adalah mengganti kata dengan menggunakan sinonim dari kata tersebut secara besar-besaran. Tujuannya? Mengecoh mesin pencari agar artikel yang kita duplikatkan (copy paste) berubah menjadi sebuah konten unik menurut pengamatan robot/mesin pencari (bukan menurut pengamatan manusia). Contoh:

Saya akan pergi ke pasar. berubah menjadi
Ana berencana berangkat ke pasar. atau
Ane mau pergi ke pasar. atau
Aku berencana pergi ke pasar. atau
Gue akan berangkat ke pasar. atau
gw mo pergi ke pasar. atau
dan seterusnya. dan seterusnya.

Bukankah seluruh kalimat di atas tersebut unik menurut versi mesin pencari? Nah, bagaimana menurut versi manusia (saya dan Anda)?

Spin artikel bisa dikategorikan sebagai sebuah teknik SEO yang sedikit hitam yang dapat menyebabkan banyaknya duplikasi konten/sampah menurut pengamatan manusia. Tetapi dalam dunia sales online/reseller/affeliate hal ini tidak bisa dihindari. Ya saya ulangi, dalam dunia sales online hal ini tidak bisa dihindari. Satu produk dengan merk yang sama dijual oleh ribuah atau jutaan orang secara online.

Di bawah ini merupakan contoh kode spin artikel bahasa indonesia dengan menggunakan 5 kata dan sinonimnya (seharusnya 5000 kata beserta sinonimnya), yakni saya, pergi, blogger, gmail, akan.

Option Explicit 
 
Private Function ChooseWord(choice As Variant, bWord, Optional bUnik As Boolean) As String 
 
    Dim i As Integer 
    Dim strSpin() As String, strChooseWord As String 
    strSpin = Split(choice, ",") 
    If Not bUnik Then 
        Randomize 
        i = CInt((UBound(strSpin) * Rnd) + 1) 
        strChooseWord = strSpin(i - 1) 
    Else 
        Do 
            Randomize 
            i = CInt((UBound(strSpin) * Rnd) + 1) 
            strChooseWord = strSpin(i - 1) 
        Loop While strChooseWord = bWord 
    End If 
    ChooseWord = strChooseWord 
 
End Function 
 
Private Sub cmdDoSpin_Click() 
    Dim strResult As String 
    Dim strSource As String 
    strResult = txtResult.Text 
    strSource = txtSource.Text 
 
    strResult = LCase(strSource) 
 
    Dim arrWord() As String 
    ReDim arrWord(4) 'gantilah menjadi 40, 400, atau 4000 
    'apabila algoritmanya telah dimodif dan mantap maka 
    'tambahkan sinonim menjadi 40, 400, atau 4000 
    arrWord(0) = "saya, aku, ane, ana" 
    arrWord(1) = "pergi, berangkat" 
    arrWord(2) = " akan, berencana" 
    arrWord(3) = "blogger, blogspot, blog milik google (blogspot)" 
    arrWord(4) = "gmail, gmail.com, google mail, layanan email milik google (gmail)" 
    '-------------------------------------------------------- 
    Dim i As Integer, k As Integer 
 
    For i = LBound(arrWord) To UBound(arrWord) 
        Dim strSpin() As String 
        strSpin = Split(arrWord(i), ",") 
        For k = LBound(strSpin) To UBound(strSpin) 
            If InStr(1, strSource, strSpin(k)) > 0 Then 
                strResult = Replace(strResult, strSpin(k), ChooseWord(arrWord(i), strSpin(k), Check1.Value = 1)) 
                Exit For 
            End If 
        Next 
    Next 
    txtResult.Text = Trim$(strResult) 
End Sub

Cobalah Anda kembangkan. Semoga kode spin artikel bahasa indonesia di atas bermanfaat. Terima kasih atas kunjungannya.

Alternatif Lain Menulis Kode Pada Posting Menggunakan Tag [P

Pernahkah Anda menulis kode dengan menggunakan tag <PRE> di blogspot. Jika belum, mungkin ini saatnya. Mengapa tag <PRE>? bukankah lebih baik menggunakan syntax highlighter? Tag <PRE> dalam kode HTML digunakan khusus untuk menuliskan kode. Dengan menggunakan tag <PRE> maka sebuah postingan akan memelihara indent dari kode tersebut, ini sangatlah penting. Penggunaan tag <PRE>: <PRE> code HTML, VB, C++, CSS, dll </PRE> Contoh kode CSS yang menggunakan tag <pre>:

<b:includable id='feedLinks'>
  <b:if cond='data:blog.pageType != "item"'>
    <!-- Blog feed links -->
    <b:if cond='data:feedLinks'>
      <div class='blog-feeds'>
        <b:include data='feedLinks' name='feedLinksBody' />
      </div>
    </b:if>
    <b:else />
    <!--Post feed links -->
    <div class='post-feeds'>
      <b:loop values='data:posts' var='post'>
        <b:if cond='data:post.allowComments'>
          <b:if cond='data:post.feedLinks'>
            <b:include data='post.feedLinks'
            name='feedLinksBody' />
          </b:if>
        </b:if>
      </b:loop>
    </div>
  </b:if>
</b:includable>

Bandingkan dengan kode di bawah:

<b:includable id='feedLinks'>
<b:if cond='data:blog.pageType != &quot;item&quot;'> <!-- Blog feed links -->
<b:if cond='data:feedLinks'>
<div class='blog-feeds'>
<b:include data='feedLinks' name='feedLinksBody'/>
</div>
</b:if>

<b:else/> <!--Post feed links -->
<div class='post-feeds'>
<b:loop values='data:posts' var='post'>
<b:if cond='data:post.allowComments'>
<b:if cond='data:post.feedLinks'>
<b:include data='post.feedLinks' name='feedLinksBody'/>
</b:if>
</b:if>
</b:loop>
</div>
</b:if>
</b:includable>

Kode VB6.0 di bawah ini menggunakan tag <PRE>:

'Automatic select listbox when mouse over
Option Explicit

Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function LBItemFromPt Lib "COMCTL32.DLL" (ByVal hLB As Long, ByVal ptX As Long, ByVal ptY As Long, ByVal bAutoScroll As Long) As Long
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 Const LB_SETCURSEL = &H186
Private Const LB_GETCURSEL = &H188

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Sub HightLightListBox(ByVal hwndLB As Long, ByVal X As Single, ByVal Y As Single)
    
    Dim IndexItem As Long
    Dim Point As POINTAPI
    
    Point.X = X \ Screen.TwipsPerPixelX
    Point.Y = Y \ Screen.TwipsPerPixelY
    
    Call ClientToScreen(hwndLB, Point)
    
    IndexItem = LBItemFromPt(hwndLB, Point.X, Point.Y, False)
    
    If IndexItem <> SendMessage(hwndLB, LB_GETCURSEL, 0, 0) Then
        Call SendMessage(hwndLB, LB_SETCURSEL, IndexItem, 0)
    End If
    
End Sub
    
Private Sub Form_Load()
    Dim i As Long
    For i = 0 To 100
        List1.AddItem 1234567 + i
    Next
End Sub
    
Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    HightLightListBox List1.hwnd, X, Y
End Sub

Bandingkan dengan yang di bawah:

'Automatic select listbox when mouse over
Option Explicit

Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function LBItemFromPt Lib "COMCTL32.DLL" (ByVal hLB As Long, ByVal ptX As Long, ByVal ptY As Long, ByVal bAutoScroll As Long) As Long
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 Const LB_SETCURSEL = &H186
Private Const LB_GETCURSEL = &H188

Private Type POINTAPI
X As Long
Y As Long
End Type

Private Sub HightLightListBox(ByVal hwndLB As Long, ByVal X As Single, ByVal Y As Single)

Dim IndexItem As Long
Dim Point As POINTAPI

Point.X = X \ Screen.TwipsPerPixelX
Point.Y = Y \ Screen.TwipsPerPixelY

Call ClientToScreen(hwndLB, Point)

IndexItem = LBItemFromPt(hwndLB, Point.X, Point.Y, False)

If IndexItem <> SendMessage(hwndLB, LB_GETCURSEL, 0, 0) Then
Call SendMessage(hwndLB, LB_SETCURSEL, IndexItem, 0)
End If

End Sub

Private Sub Form_Load()
Dim i As Long
For i = 0 To 100
List1.AddItem 1234567 + i
Next
End Sub

Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
HightLightListBox List1.hwnd, X, Y
End Sub

Menutup Sebuah Aplikasi Secara Paksa (Force Terminate)

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, ByRef lpdwProcessId As Long) As Long
Private Declare Function OpenProcess Lib "Kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long
Private Declare Function CloseHandle Lib "Kernel32" (ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "Kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

Private Const SYNCHRONIZE = &H100000
Private Const PROCESS_TERMINATE As Long = &H1

Public Sub terminateApp(ByVal sWindowTitle As String, ByVal fSilent As Boolean)

    
    Dim lHwnd As Long
    Dim lProc As Long
    Dim lProcHnd As Long
    
    On Error GoTo ErrHandler
    
    sWindowTitle = "Inbox - Thunderbird"
    sWindowTitle = "Test"
    
    lHwnd = FindWindow(vbNullString, sWindowTitle)
    If lHwnd = 0 Then
        If fSilent Then
            Exit Sub
        Else
            Err.Raise 1, , "Can"
        End If
    End If

    GetWindowThreadProcessId lHwnd, lProc
    If lProc = 0 Then
        If fSilent Then
            Exit Sub
        Else
            Err.Raise 1, , "Can"
        End If
    End If

    lProcHnd = OpenProcess(SYNCHRONIZE Or PROCESS_TERMINATE, 0, lProc)
    If lProcHnd = 0 Then
        If fSilent Then
            Exit Sub
        Else
            Err.Raise 1, , "Can"
        End If
    End If

    If TerminateProcess(lProcHnd, 0&) <> 0 Then
        If Not fSilent Then
            Err.Raise 1, , "Failed to terminate process"
        End If
    End If

    CloseHandle lProcHnd
    
    Exit Sub

ErrHandler:

    Err.Raise Err.Number, , Err.Description

End Sub

Menutup Sebuah Aplikasi Secara Request

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const WM_CLOSE As Long = &H10

Public Sub closeApp(ByVal sWindowTitle As String, Optional ByVal fSilent As Boolean = False)
    Dim lHwnd As Long
    On Error GoTo ErrHandler

    lHwnd = FindWindow(vbNullString, sWindowTitle)

    If lHwnd = 0 Then
        If Not fSilent Then
            Err.Raise 1, , "Can"
        End If
    Else
        PostMessage lHwnd, WM_CLOSE, 0, 0
    End If

    Exit Sub

ErrHandler:
    Err.Raise Err.Number, , Err.Description
End Sub

Aplikasi Untuk Melihat Warna Yang Ada Di bawah Pointer

'simpan kode di bawah pada module
Option Explicit

Private Declare Function CreateDC& Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any)
Private Declare Function DeleteDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'simpan kode di bawah pada form
'Timer.Interval = 1
'Picture1.AutoRedraw = True

'Option Explicit

Dim pt As POINTAPI

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Timer1.Enabled = True
    Picture1.MousePointer = vbCrosshair
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Timer1.Enabled = False
    Picture1.MousePointer = vbDefault
End Sub

Private Sub Timer1_Timer()
    Dim screendc As Long
    GetCursorPos pt
    screendc = CreateDC("DISPLAY", "", "", 0&)
    Picture1.BackColor = GetPixel(screendc, pt.X, pt.Y)
    Text1.Text = "#" & Hex(GetPixel(screendc, pt.X, pt.Y))
    DeleteDC (screendc)
End Sub

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

Membikin Menu Multi Kolom (Win32) - (API Call)

Private Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type

Private Const MF_MENUBARBREAK = &H20&
Private Const MF_MENUBREAK = &H40&
Private Const MF_STRING = &H0&
Private Const MF_HELP = &H4000&
Private Const MFS_DEFAULT = &H1000&
Private Const MIIM_ID = &H2
Private Const MIIM_SUBMENU = &H4
Private Const MIIM_TYPE = &H10
Private Const MIIM_DATA = &H20
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal B As Boolean, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long

Private Sub Command1_Click()
    Dim mnuItemInfo As MENUITEMINFO, hMenu As Long, hSubMenu As Long
    Dim BuffStr As String * 80

    hMenu = GetMenu(Me.hwnd)
    BuffStr = Space(80)
    With mnuItemInfo
        .cbSize = Len(mnuItemInfo)
        .dwTypeData = BuffStr & Chr(0)
        .fType = MF_STRING
        .cch = Len(mnuItemInfo.dwTypeData)
        .fState = MFS_DEFAULT
        .fMask = MIIM_ID Or MIIM_DATA Or MIIM_TYPE Or MIIM_SUBMENU
    End With
    hSubMenu = GetSubMenu(hMenu, 0)
    If GetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
        MsgBox "GetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
    Else
        mnuItemInfo.fType = mnuItemInfo.fType Or MF_MENUBARBREAK
        If SetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
            MsgBox "SetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
        End If
    End If
    DrawMenuBar (Me.hwnd)
End Sub

Private Sub Form_Load()
    Dim mnuItemInfo As MENUITEMINFO, hMenu As Long, hSubMenu As Long
    Dim BuffStr As String * 80

    hMenu = GetMenu(Me.hwnd)
    BuffStr = Space(80)

    With mnuItemInfo
        .cbSize = Len(mnuItemInfo)
        .dwTypeData = BuffStr & Chr(0)
        .fType = MF_STRING
        .cch = Len(mnuItemInfo.dwTypeData)
        .fState = MFS_DEFAULT
        .fMask = MIIM_ID Or MIIM_DATA Or MIIM_TYPE Or MIIM_SUBMENU
    End With
    hSubMenu = GetSubMenu(hMenu, 1)
    If GetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
        MsgBox "GetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
    Else
        mnuItemInfo.fType = mnuItemInfo.fType Or MF_MENUBREAK
        If SetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
            MsgBox "SetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
        End If
    End If
    DrawMenuBar (Me.hwnd)
End Sub

Membikin Area Transparan Obyek Geometri - (API Call)

Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Private Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean
    Const RGN_DIFF = 4
    Dim lOriginalForm As Long
    Dim ltheHole As Long
    Dim lNewForm As Long
    Dim lFwidth As Single
    Dim lFHeight As Single
    Dim lborder_width As Single
    Dim ltitle_height As Single
    On Error GoTo Trap
    lFwidth = ScaleX(Width, vbTwips, vbPixels)
    lFHeight = ScaleY(Height, vbTwips, vbPixels)
    lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)

    lborder_width = (lFHeight - ScaleWidth) / 2
    ltitle_height = lFHeight - lborder_width - ScaleHeight
    Select Case AreaType

        Case "Elliptic"
            ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
        Case "RectAngle"
            ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
        Case "RoundRect"
            ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))
        Case "Circle"
            ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))
        Case Else
            MsgBox "Unknown Shape!!"
            Exit Function
    End Select
    lNewForm = CreateRectRgn(0, 0, 0, 0)
    CombineRgn lNewForm, lOriginalForm, _
    ltheHole, RGN_DIFF

    SetWindowRgn hWnd, lNewForm, True
    Me.Refresh
    fMakeATranspArea = True
    Exit Function
Trap:
    MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.Description
End Function

Private Sub Command1_Click()
    Dim lParam(1 To 6) As Long
    lParam(1) = 100
    lParam(2) = 100
    lParam(3) = 250
    lParam(4) = 250
    lParam(5) = 50
    lParam(6) = 50
    Call fMakeATranspArea("Circle", lParam())
End Sub

Asc: Mengenal Fungsi String VB6

Asc - Kegunaan fungsi string dalam VB6.

Kegunaan Asc dalam VB6:

Fungsi Asc berguna untuk memperoleh nilai angka yang merupakan kode ANSI dari sebuah string.

Contoh Asc dalam VB6:

    txtHasil.Text = Asc("A") 'maka akan memperoleh nilai 65
    'demikian juga
    txtHasil.Text = Asc("AAA")  'maka akan memperoleh nilai 65
    'demikian juga
    txtHasil.Text = Asc("AB") 'akan memperoleh nilai 65

Catatan mengenai Asc dalam VB6:

Dari ketiga contoh di atas yang menjadi patokan adalah karakter pertama, selanjutnya karakter pertama tersebut akan dirubah menjadi kode ANSI berupa angka, yang secara kebetulan dalam contoh di atas adalah karakter A dan kode ANSI untuk karakter A adalah 65.

Demikian fungsi string Asc dalam VB6, semoga bermanfaat bagi mereka yang sedang ingin mengetahui fungsi-fungsi string dalam VB6 khususnya fungsi string Asc.

LCase: Mengenal Fungsi String VB6

LCase - Mengenal fungsi-fungsi string dalam VB6

Kegunaan LCase dalam VB6:

Fungsi LCase berguna untuk mengkonversi seluruh string menjadi huruf kecil.

Contoh LCase dalam VB6:

    Msgbox LCase("Jakarta Bandung") 'maka jakarta bandung

Demikian kegunaan fungsi string LCase dalam VB6, semoga bermanfaat.

Filter: Mengenal Fungsi String VB6

Filter- Kegunaan fungsi string dalam VB6.

Kegunaan Filter dalam VB6:

Fungsi Filter berguna untuk memfilter sebuah array (include atau exclude).

Contoh Filter dalam VB6:

Option Explicit

'Contoh include (memperoleh string yang sama dengan "B" dari arrTest)
'dan case-sensitive (memperdulikan apakah B huruf besar atau huruf kecil)
Private Sub cmdEvaluate_Click()
    Dim arrTest() As String
    Dim arrMatch() As String
    
    arrTest = Split("A,B,C,D,B,B,B,B,B,B,B,C", ",")
    arrMatch = Filter(arrTest, "B", True)
    
    MsgBox "Banyaknya string yang sesuai: " & UBound(arrMatch)
    txtResult.Text = arrMatch(0) & " " & arrMatch(1) & " " & arrMatch(2) & " " & arrMatch(3)
End Sub

'Contoh include (memperoleh string yang sama dengan "B" dari arrTest)
'dan case-insensitive (tidak memperdulikan apakah B huruf besar atau huruf kecil)
Private Sub cmdEvaluate_Click()
    Dim arrTest() As String
    Dim arrMatch() As String
    
    arrTest = Split("A,B,C,D,B,B,B,B,B,B,B,C", ",")
    arrMatch = Filter(arrTest, "B", True, vbTextCompare)
    
    MsgBox "Banyaknya string yang sesuai: " & UBound(arrMatch)
    txtResult.Text = arrMatch(0) & " " & arrMatch(1) & " " & arrMatch(2) & " " & arrMatch(3)
End Sub

'contoh exclude (memperoleh string yang tidak sama dengan "B" dari arrTest)
Private Sub cmdEvaluate_Click()
    Dim arrTest() As String
    Dim arrMatch() As String
    
    arrTest = Split("A,B,C,D,B,B,B,B,B,B,B,C", ",")
    arrMatch = Filter(arrTest, "B", False)
    
    MsgBox "Banyaknya string yang sesuai: " & UBound(arrMatch)
    txtResult.Text = arrMatch(0) & " " & arrMatch(1) & " " & arrMatch(2) & " " & arrMatch(3)
End Sub

Demikian contoh fungsi string Filter sebuah Array dalam VB6.

Chr: Mengenal Fungsi String VB6

Chr - Kegunaan fungsi string dalam VB6.

Kegunaan Chr dalam VB6:

Fungsi Chr berguna untuk memperoleh string dari kode karakter.

Contoh Chr dalam VB6:

    txtHasil.Text = Chr(65)    ' akan memperoleh A.
    txtHasil.Text = Chr(97)    ' akan memperoleh a.
    txtHasil.Text = Chr(62)    ' akan memperoleh >.
    txtHasil.Text = Chr(37)    ' akan memperoleh %.

Demikian fungsi string Chr dalam VB6, semoga bermanfaat.

Right: Mengenal Fungsi String Dalam VB6

Right- Mengenal fungsi-fungsi string dalam VB6

Kegunaan Right dalam VB6:

Fungsi Right berguna untuk memperoleh string dari kiri ke kanan sejumlah yang telah ditentukan

Contoh Right dalam VB6:

Private Sub cmdEvaluate_Click()
    MsgBox Right("abcdefghijklmnopqrstu", 1) 'akan memperoleh "u"
    MsgBox Right("abcdefghijklmnopqrstu", 2) 'akam memperoleh "tu"
    MsgBox Right("abcdefghijklmnopqrstu", 3) 'akan memperoleh "stu"
    MsgBox Right("abcdefghijklmnopqrstu", 4) 'akan memperoleh "rstu"
    MsgBox Right("abcdefghijklmnopqrstu", 5) 'akan memperoleh "qratu"
    
    'dan seterusnya
End Sub

Demikian kegunaan fungsi string Right dalam VB6, semoga bermanfaat.

Left: Mengenal Fungsi String Dalam VB6

Left - Mengenal fungsi-fungsi string dalam VB6

Kegunaan Left dalam VB6:

Fungsi LCase berguna untuk memperoleh string dari kiri ke kanan sejumlah yang telah ditentukan

Contoh Left dalam VB6:

Private Sub cmdEvaluate_Click()
    MsgBox Left("abcdefghijklmnopqrstu", 1) 'akan memperoleh "a"
    MsgBox Left("abcdefghijklmnopqrstu", 2) 'akam memperoleh "ab"
    MsgBox Left("abcdefghijklmnopqrstu", 3) 'akan memperoleh "abc"
    MsgBox Left("abcdefghijklmnopqrstu", 4) 'akan memperoleh "abcd"
    MsgBox Left("abcdefghijklmnopqrstu", 5) 'akan memperoleh "abcde"



    'dan seterusnya
End Sub

Demikian kegunaan fungsi string Left dalam VB6, semoga bermanfaat.

UCase: Mengenal Fungsi String VB6

UCase - Mengenal fungsi-fungsi string dalam VB6

Kegunaan UCase dalam VB6:

Fungsi UCase berguna untuk mengkonversi seluruh string menjadi huruf besar.

Contoh UCase dalam VB6:

    Msgbox LCase("Jakarta Bandung") 'maka akan menjadi JAKARTA BANDUNG

Demikian kegunaan fungsi string UCase dalam VB6, semoga bermanfaat.

Encode-Decode String Base64 Secara Cepat

Option Explicit

Private Const clOneMask = 16515072          '000000 111111 111111 111111
Private Const clTwoMask = 258048            '111111 000000 111111 111111
Private Const clThreeMask = 4032            '111111 111111 000000 111111
Private Const clFourMask = 63               '111111 111111 111111 000000

Private Const clHighMask = 16711680         '11111111 00000000 00000000
Private Const clMidMask = 65280             '00000000 11111111 00000000
Private Const clLowMask = 255               '00000000 00000000 11111111

Private Const cl2Exp18 = 262144             '2 to the 18th power
Private Const cl2Exp12 = 4096               '2 to the 12th
Private Const cl2Exp6 = 64                  '2 to the 6th
Private Const cl2Exp8 = 256                 '2 to the 8th
Private Const cl2Exp16 = 65536              '2 to the 16th

Public Function Encode64(sString As String) As String

    Dim bTrans(63) As Byte, lPowers8(255) As Long, lPowers16(255) As Long, bOut() As Byte, bIn() As Byte
    Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long, lOutSize As Long

    For lTemp = 0 To 63                                 'Fill the translation table.
        Select Case lTemp
            Case 0 To 25
                bTrans(lTemp) = 65 + lTemp              'A - Z
            Case 26 To 51
                bTrans(lTemp) = 71 + lTemp              'a - z
            Case 52 To 61
                bTrans(lTemp) = lTemp - 4               '1 - 0
            Case 62
                bTrans(lTemp) = 43                      'Chr(43) = "+"
            Case 63
                bTrans(lTemp) = 47                      'Chr(47) = "/"
        End Select
    Next lTemp

    For lTemp = 0 To 255                                'Fill the 2^8 and 2^16 lookup tables.
        lPowers8(lTemp) = lTemp * cl2Exp8
        lPowers16(lTemp) = lTemp * cl2Exp16
    Next lTemp

    iPad = Len(sString) Mod 3                           'See if the length is divisible by 3
    If iPad Then                                        'If not, figure out the end pad and resize the input.
        iPad = 3 - iPad
        sString = sString & String(iPad, Chr(0))
    End If

    bIn = StrConv(sString, vbFromUnicode)               'Load the input string.
    lLen = ((UBound(bIn) + 1) \ 3) * 4                  'Length of resulting string.
    lTemp = lLen \ 72                                   'Added space for vbCrLfs.
    lOutSize = ((lTemp * 2) + lLen) - 1                 'Calculate the size of the output buffer.
    ReDim bOut(lOutSize)                                'Make the output buffer.

    lLen = 0                                            'Reusing this one, so reset it.

    For lChar = LBound(bIn) To UBound(bIn) Step 3
        lTrip = lPowers16(bIn(lChar)) + lPowers8(bIn(lChar + 1)) + bIn(lChar + 2)    'Combine the 3 bytes
        lTemp = lTrip And clOneMask                     'Mask for the first 6 bits
        bOut(lPos) = bTrans(lTemp \ cl2Exp18)           'Shift it down to the low 6 bits and get the value
        lTemp = lTrip And clTwoMask                     'Mask for the second set.
        bOut(lPos + 1) = bTrans(lTemp \ cl2Exp12)       'Shift it down and translate.
        lTemp = lTrip And clThreeMask                   'Mask for the third set.
        bOut(lPos + 2) = bTrans(lTemp \ cl2Exp6)        'Shift it down and translate.
        bOut(lPos + 3) = bTrans(lTrip And clFourMask)   'Mask for the low set.
        If lLen = 68 Then                               'Ready for a newline
            bOut(lPos + 4) = 13                         'Chr(13) = vbCr
            bOut(lPos + 5) = 10                         'Chr(10) = vbLf
            lLen = 0                                    'Reset the counter
            lPos = lPos + 6
        Else
            lLen = lLen + 4
            lPos = lPos + 4
        End If
    Next lChar

    If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2 'Shift the padding chars down if it ends with CrLf.

    If iPad = 1 Then                                    'Add the padding chars if any.
        bOut(lOutSize) = 61                             'Chr(61) = "="
    ElseIf iPad = 2 Then
        bOut(lOutSize) = 61
        bOut(lOutSize - 1) = 61
    End If

    Encode64 = StrConv(bOut, vbUnicode)                 'Convert back to a string and return it.

End Function

Public Function Decode64(sString As String) As String

    Dim bOut() As Byte, bIn() As Byte, bTrans(255) As Byte, lPowers6(63) As Long, lPowers12(63) As Long
    Dim lPowers18(63) As Long, lQuad As Long, iPad As Integer, lChar As Long, lPos As Long, sOut As String
    Dim lTemp As Long

    sString = Replace(sString, vbCr, vbNullString)      'Get rid of the vbCrLfs.  These could be in...
    sString = Replace(sString, vbLf, vbNullString)      'either order.

    lTemp = Len(sString) Mod 4                          'Test for valid input.
    If lTemp Then
        Call Err.Raise(vbObjectError, "MyDecode", "Input string is not valid Base64.")
    End If

    If InStrRev(sString, "==") Then                     'InStrRev is faster when you know it's at the end.
        iPad = 2                                        'Note:  These translate to 0, so you can leave them...
    ElseIf InStrRev(sString, "=") Then                  'in the string and just resize the output.
        iPad = 1
    End If

    For lTemp = 0 To 255                                'Fill the translation table.
        Select Case lTemp
            Case 65 To 90
                bTrans(lTemp) = lTemp - 65              'A - Z
            Case 97 To 122
                bTrans(lTemp) = lTemp - 71              'a - z
            Case 48 To 57
                bTrans(lTemp) = lTemp + 4               '1 - 0
            Case 43
                bTrans(lTemp) = 62                      'Chr(43) = "+"
            Case 47
                bTrans(lTemp) = 63                      'Chr(47) = "/"
        End Select
    Next lTemp

    For lTemp = 0 To 63                                 'Fill the 2^6, 2^12, and 2^18 lookup tables.
        lPowers6(lTemp) = lTemp * cl2Exp6
        lPowers12(lTemp) = lTemp * cl2Exp12
        lPowers18(lTemp) = lTemp * cl2Exp18
    Next lTemp

    bIn = StrConv(sString, vbFromUnicode)               'Load the input byte array.
    ReDim bOut((((UBound(bIn) + 1) \ 4) * 3) - 1)       'Prepare the output buffer.

    For lChar = 0 To UBound(bIn) Step 4
        lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lChar + 1))) + _
                lPowers6(bTrans(bIn(lChar + 2))) + bTrans(bIn(lChar + 3))           'Rebuild the bits.
        lTemp = lQuad And clHighMask                    'Mask for the first byte
        bOut(lPos) = lTemp \ cl2Exp16                   'Shift it down
        lTemp = lQuad And clMidMask                     'Mask for the second byte
        bOut(lPos + 1) = lTemp \ cl2Exp8                'Shift it down
        bOut(lPos + 2) = lQuad And clLowMask            'Mask for the third byte
        lPos = lPos + 3
    Next lChar

    sOut = StrConv(bOut, vbUnicode)                     'Convert back to a string.
    If iPad Then sOut = Left$(sOut, Len(sOut) - iPad)   'Chop off any extra bytes.
    Decode64 = sOut

End Function

LTrim - RTrim - Trim: Mengenal Fungsi String Dalam VB6

LTrim - RTrim - Trim - Mengenal fungsi-fungsi string dalam VB6

Kegunaan LTrim - RTrim - Trim dalam VB6:

Fungsi LTrim berguna untuk menghilangkan spasi yang ada di sebelah kiri.
Fungsi RTrim berguna untuk menghilangkan spasi yang ada di sebelah kanan.
Fungsi Trim berguna untuk menghilangkan spasi di sebelah kiri dan kanan.

Contoh LTrim - RTrim - Trim dalam VB6:

Private Sub cmdEvaluate_Click()
    MsgBox ("   abc      ") 'dengan spasi di kiri dan di kanan
    MsgBox LTrim("   abc      ") 'menjadi "abc   " menghilangkan spasi kiri
    MsgBox RTrim("    abc      ") 'menjadi "    abc" menghilangkan spasi kanan
    MsgBox Trim("     abc      ") 'menjadi "abc" menghilang spasi kiri dan kanan
End Sub

Demikian kegunaan fungsi string LTrim - RTrim - Trim dalam VB6, semoga bermanfaat.

Mid: Mengenal Fungsi String Dalam VB6

Mid - Mengenal fungsi-fungsi string dalam VB6

Kegunaan Mid dalam VB6:

Fungsi Mid berguna untuk memperoleh string dari awal yang ditentukan dan jumlah yang ditentukan

Contoh Mid dalam VB6:

Private Sub cmdEvaluate_Click()
    Debug.Print Mid("abcdefghijklmnopqrstu", 1, 1) 'akan memperoleh "a"
    Debug.Print Mid("abcdefghijklmnopqrstu", 2, 1) 'akam memperoleh "b"
    Debug.Print Mid("abcdefghijklmnopqrstu", 1, 3) 'akan memperoleh "abc"
    Debug.Print Mid("abcdefghijklmnopqrstu", 2, 4) 'akan memperoleh "bcde"
    Debug.Print Mid("abcdefghijklmnopqrstu", 2, 5) 'akan memperoleh "bcdef"
    
    'dan seterusnya
End Sub

Demikian kegunaan fungsi string Mid dalam VB6, semoga bermanfaat.

VB6 WebBrowser - Menampilkan Pop Up

Private Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)
    Dim frm As Form1
    Set frm = New Form1
    Set ppDisp = frm.WebBrowser1.Object
    frm.Show
End Sub

Membuat Aplikasi Console Sederhana Menggunakan VB6

Option Explicit
'
'Reference to Microsoft Scripting Runtime.
'

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

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

Private Allocated As Boolean

Private Sub Setup()
    Dim Title As String

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

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

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

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

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

    TearDown 'Omit for Console Subsystem.
End Sub

Cara Membulatkan Angka Yang Berada Di belakang Koma

Mengenai cara membulatkan angka yang berada di belakang koma - Adapun cara membulatkan angka di belakang koma adalah sebagai berikut:

Text1.Text = Format (0.026, "#0.##")

Maka dari kode di atas akan diperoleh 0.03

Contoh Fungsi API GetTickCount Dalam VB6

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

Private Sub Command1_Click()

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


    For M = 1 To 10

        StartTime = GetTickCount

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

        EndTime = GetTickCount

        List1.AddItem EndTime - StartTime
        DoEvents

    Next M

End Sub

Parse XML Menggunakan Visual Basic 6.0

Sub ParseXmlDocument()
   Dim doc As New MSXML2.DOMDocument
   Dim success As Boolean

   success = doc.Load(App.Path & "\test.xml")
   If success = False Then
      MsgBox doc.parseError.reason
   Else
      Dim nodeList As MSXML2.IXMLDOMNodeList

      Set nodeList = doc.selectNodes("/Report/Categories/Category")

      If Not nodeList Is Nothing Then
         Dim node As MSXML2.IXMLDOMNode
         Dim name As String
         Dim value As String

         For Each node In nodeList
            ' Could also do node.attributes.getNamedItem("name").text
            name = node.selectSingleNode("@name").Text
            value = node.selectSingleNode("@value").Text
         Next node
      End If
   End If
End Sub

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.

Cara Mem-Print Sebuah Gambar Yang Ada Dalam PictureBox

Mengenai cara mem-print gambar yang terdapat pada objek PictureBox menggunakan VB6 - Adapun cara mem-print gambar yang terdapat pada PictureBox menggunakan VB6 adalah sebagai berikut:

Private Sub Command1_Click()
    Printer.PaintPicture Picture1.Picture, 0, 0, Picture1.Width, Picture1.Height
    Printer.EndDoc
End Sub

Demikian sederhana cara mem-print sebuah gambar yang terdapat pada PictureBox menggunakan VB6.

Bagaimana Membuat Function Yang Mengandung Array - VB6

Mengenai cara membuat fungsi yang memperoleh (return) nilai array dalam bahasa pemrograman Visual Basic 6.0 - Untuk membuat fungsi yang mendapatkan nilai array dalam VB6, coba perhatikan bentuk fungsi berikut:

Private Function GetArrFunction() As String()
    Dim c(2) As String
    c(0) = 1
    c(1) = 100
    c(2) = 300
    GetArrFunction = c
End Function

Private Sub Command2_Click()
    Dim s() As String
    s = GetArrFunction
    MsgBox s(1) 'akan menghasilkan 100
End Sub

Demikianlah contoh sederhana mengenai cara membuat fungsi yang memperoleh (return) nilai array dalam VB6, semoga bermanfaat. nn

Mengetahui Tanggal Berada Pada Posisi Minggu Ke Berapa?

Private Function GetDayInWeek(d As Date) As Integer
    Dim dt As Date, i As Integer
    For dt = CDate(Format$(d, "mm/yyyy")) To DateAdd("m", 1, d)
        If Weekday(dt) = 2 Then
            i = i + 1
            If dt > d Then Exit For
        End If
    Next
    GetDayInWeek = i
End Function

Konversi Masehi Ke Hijriyah Dan Sebaliknya

Private Sub Command2_Click()
    Dim c As Date
    c = CDate("21/12/1945")
    Calendar = vbCalHijri
    MsgBox c
    MsgBox Format(#8/17/1945#, "dddd")
End Sub

Private Sub Command3_Click()
    Dim c As Date
    Calendar = vbCalHijri
    c = CDate("1/1/1455")
    Calendar = vbCalGreg
    MsgBox c
    MsgBox Format(#8/17/1945#, "dddd")
End Sub

Memperoleh Jumlah Hari Dari Bulan Yang Ditentukan

Private Function DayCount(d As Date) As Integer
    DayCount = Day(DateSerial(Year(d), Month(d) + 1, 0))
End Function

Private Sub Command3_Click()
    MsgBox DayCount(#2/2/2008#)
End Sub

Merubah Time Zone Secara Pemrograman

Option Explicit

Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

Private 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 REGTIMEZONEINFORMATION
    Bias As Long
    StandardBias As Long
    DaylightBias As Long
    StandardDate As SYSTEMTIME
    DaylightDate As SYSTEMTIME
End Type

Private Type TIME_ZONE_INFORMATION
    Bias As Long
    StandardName(0 To 63) As Byte
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(0 To 63) As Byte
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type

Private Const TIME_ZONE_ID_INVALID = &HFFFFFFFF
Private Const TIME_ZONE_ID_UNKNOWN = 0
Private Const TIME_ZONE_ID_STANDARD = 1
Private Const TIME_ZONE_ID_DAYLIGHT = 2

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

Private Const REG_SZ As Long = 1
Private Const REG_BINARY = 3
Private Const REG_DWORD As Long = 4

Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003

Private Const ERROR_SUCCESS = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_ARENA_TRASHED = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259

Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0

Private 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
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpszValueName As String, ByVal lpdwReserved As Long, lpdwType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Const SKEY_NT = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Time Zones"
Const SKEY_9X = "SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones"

Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, lpWideCharStr As Any, ByVal cchWideChar As Long) As Long

Private Const CP_ACP = 0
Private Const MB_PRECOMPOSED = &H1
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal numbytes As Long)
Dim SubKey As String

Private Sub Form_Load()
    Dim lRetVal As Long, lResult As Long, lCurIdx As Long
    Dim lDataLen As Long, lValueLen As Long, hKeyResult As Long
    Dim strvalue As String
    Dim osV As OSVERSIONINFO

    osV.dwOSVersionInfoSize = Len(osV)
    Call GetVersionEx(osV)
    If osV.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        SubKey = SKEY_NT
    Else
        SubKey = SKEY_9X
    End If

    lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, 0, KEY_ALL_ACCESS, hKeyResult)

    If lRetVal = ERROR_SUCCESS Then

        lCurIdx = 0
        lDataLen = 32
        lValueLen = 32

        Do
            strvalue = String(lValueLen, 0)
            lResult = RegEnumKey(hKeyResult, lCurIdx, strvalue, lDataLen)

            If lResult = ERROR_SUCCESS Then
                List1.AddItem Left(strvalue, lValueLen)
            End If

            lCurIdx = lCurIdx + 1

        Loop While lResult = ERROR_SUCCESS

        RegCloseKey hKeyResult
    Else
        List1.AddItem "Could not open registry key"
    End If
End Sub

Private Sub List1_DblClick()
    Dim TZ As TIME_ZONE_INFORMATION, oldTZ As TIME_ZONE_INFORMATION
    Dim rTZI As REGTIMEZONEINFORMATION
    Dim bytDLTName(32) As Byte, bytSTDName(32) As Byte
    Dim cbStr As Long, dwType As Long
    Dim lRetVal As Long, hKeyResult As Long, lngData As Long

    lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey & "\" & List1.Text, 0, KEY_ALL_ACCESS, hKeyResult)

    If lRetVal = ERROR_SUCCESS Then
        lRetVal = RegQueryValueEx(hKeyResult, "TZI", 0&, ByVal 0&, rTZI, Len(rTZI))

        If lRetVal = ERROR_SUCCESS Then
            TZ.Bias = rTZI.Bias
            TZ.StandardBias = rTZI.StandardBias
            TZ.DaylightBias = rTZI.DaylightBias
            TZ.StandardDate = rTZI.StandardDate
            TZ.DaylightDate = rTZI.DaylightDate

            cbStr = 32
            dwType = REG_SZ

            lRetVal = RegQueryValueEx(hKeyResult, "Std", 0&, dwType, bytSTDName(0), cbStr)

            If lRetVal = ERROR_SUCCESS Then
                Call MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, bytSTDName(0), cbStr, TZ.StandardName(0), 32)
            Else
                RegCloseKey hKeyResult
                Exit Sub
            End If

            cbStr = 32
            dwType = REG_SZ

            lRetVal = RegQueryValueEx(hKeyResult, "Dlt", 0&, dwType, bytDLTName(0), cbStr)

            If lRetVal = ERROR_SUCCESS Then
                Call MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, bytDLTName(0), cbStr, TZ.DaylightName(0), 32)
            Else
                RegCloseKey hKeyResult
                Exit Sub
            End If

            lRetVal = GetTimeZoneInformation(oldTZ)

            If lRetVal = TIME_ZONE_ID_INVALID Then
                MsgBox "Error getting original TimeZone Info"
                RegCloseKey hKeyResult
                Exit Sub
            Else
                If TZ.DaylightDate.wMonth <> 0 And TZ.DaylightBias <> 0 Then
                    lRetVal = SetTimeZoneInformation(TZ)
                Else
                    Call CopyMemory(TZ.DaylightName(0), TZ.StandardName(0), 64)
                    TZ.DaylightBias = 0
                    lRetVal = SetTimeZoneInformation(TZ)
                End If
                MsgBox "Time Zone Changed, Click OK to restore"
                lRetVal = SetTimeZoneInformation(oldTZ)
            End If
        End If

        RegCloseKey hKeyResult
    End If
End Sub

Saturday, June 16, 2012

Mengektrak Seluruh Link Atau Elemen Menggunakan MSHTML - VB6

Mengenai cara mengekstrak seluruh link atau elemen yang ditentukan dalam sebuah halamn HTML menggunakan VB6 dengan bantuan ActiveX MSHTML - Adapun contoh kode untuk mengektrak seluruh link menggunakan VB6 dengan bantuan MSHTML adalah sebagai berikut:

Private Sub Command1_Click()

    Dim d As New MSHTML.HTMLDocument
    Dim l As HTMLImg
    Dim x As HTMLHtmlElement
    
    List1.Clear
    d.body.innerHTML = Text1.Text
    
    Set x = d.getElementById("IMG")
   
    For Each l In d.images
        If l.src <> "" Then
            List1.AddItem l.src
        End If
    Next
    Text1.Text = d.body.innerHTML
    
End Sub

Demikian contoh untuk mengekstrak link atau elemen yang ditentukan menggunkan VB6 dengan bantuan ActiveX MSHTML, semoga bermanfaat.

Thursday, June 14, 2012

TwitterCOM.dll - Mengirim Tweet Ke Twitter Dari VB6

Mengenai cara mengirim tweet ke twitter.com menggunakan aplikasi yang dibuat dengan VB6 menggunakan bantuan COM ActiveX yang miskin fitur yang diberi nama TwitterCOM.dll. Sekarang saya mau share mengenai TwitterCOM.dll sebuah COM ActiveX yang miskin fiture, walaupun miskin fitur, akan tetapi dengan menggunakan TwitterCOM.dll maka mengirim tweet ke twitter menjadi sangat mudah, siapapun dapat melakukannya termasuk saya, Anda, ibu-ibu, kakek-kakek, nenek-nenek, anak di bawah umur, balita, bayi, baik pria maupun wanita. Dengan syarat terkoneksi dengan internet dan memiliki akun twitter. That's All.
Adapun kode untuk mengirim tweet ke twitter adalah sebagai berikut:

Option Explicit

'http://khoiriyyah.blogspot.com

Private Sub cmdSendTweet_Click()
    Dim t As New Twitter
    With t
        .AccessToken = txtToken.Text
        .AccessTokenSecret = txtAccessTokenSecret.Text
        .ConsumerKey = txtConsumerKey.Text
        .ConsumerSecret = txtConsumerSecret.Text
        .Tweet = txtTweet.Text
        .SendTweet
    End With
    Set t = Nothing
End Sub

Wah, ternyata mengirim tweet ke twitter.com menggunakan VB6, kodenya sederhana beungeut.
Catatan sangat penting:
Sebelum menggunakan TwitterCOM.dll Anda harus memperoleh 4 key, yaitu:

Consumer Key
Access Token
Consumer Secret
Access Token Secret

Sekarang kita sudah tidak membutuhkan UserName dan Password untuk melakukan proses ototirasi dan otentifikasi, karena sejak Desember 2009 Twitter sudah tidak menggunakan lagi Basic Auth dan berpindah ke OAuth 1.0a.
Anda dapat memperoleh 4 kunci di atas dari https://dev.twitter.com/apps kemudian aktifkan mode access read-writenya.
Download: TwitterCOM.dll

Contoh Mengambil Image Dari Resource - VB6 Code

Mengenai cara mengambil gambar dari file resource menggunakan pemrograman Visual Basic 6 - Bagaimana kita dapat menggunakan gambar yang terdapat pada resource file, berikut adalah jawabannya:

Private Sub Form_Paint()
    Me.PaintPicture VB.LoadResPicture(101, vbResBitmap), 0, 0
End Sub

Walaupun hanya satu baris, semoga bermanfaat.

Dua Cara Memperoleh Nama Hari Dari Tanggal Tertentu

Cara Pertama

Private Function GetDayName(d As Date) As String
    GetDayName = WeekdayName(Weekday(d, vbMonday))
End Function

Cara Kedua

Private Function GetDayName(d As Date) As String
    GetDayName = Format$(d, "dddd")
End Function

Contoh penggunaan

Private Sub Command1_Click()
    MsgBox GetDayName(#6/14/2012#)
End Sub

Dua Cara Memperoleh Tanggal Terakhir Dari Bulan Tertentu

Cara Pertama:

Private Function GetLastDayOfMonth(d As Date) As Integer
    GetLastDayOfMonth = DateDiff("d", Format$(d, "mm/yyyy"), Format$(DateAdd("m", 1, d), "mm/yyyy"))
End Function

Cara Kedua:

Private Function GetLastDayOfMonth(d As Date) As String
    GetLastDayOfMonth = DateAdd("m", 1, DateSerial(Year(d), Month(d), 1)) - 1
End Function

Contoh Penggunaan:

Private Sub Command2_Click()
    Dim d As Date
    d = #7/13/2012#
    MsgBox GetLastDayOfMonth(d)
End Sub

Tidy XML Menggunakan XSL Transform - VB6 Source Code

Private Function TidyXML(sXML As String) As String
    Dim oXSLT As DOMDocument
    Dim XSL_FILE As String
    Dim sResult As String
    Const DoubleQuotes = """"
    Dim strText As String
    Dim objDom As DOMDocument
 
    Set objDom = New DOMDocument
    objDom.loadXML sXML
 
    Set oXSLT = New DOMDocument
    XSL_FILE = "<?xml version=" & DoubleQuotes & "1.0" & DoubleQuotes & " encoding=" & DoubleQuotes & "UTF-8" & DoubleQuotes & "?>" & vbCrLf & "<xsl:stylesheet version=" & DoubleQuotes & "1.0" & DoubleQuotes & " xmlns:xsl=" & DoubleQuotes & "http://www.w3.org/1999/XSL/Transform" & DoubleQuotes & ">" & vbCrLf & "     <xsl:output method=" & DoubleQuotes & "xml" & DoubleQuotes & " version=" & DoubleQuotes & "1.0" & DoubleQuotes & " encoding=" & DoubleQuotes & "UTF-8" & DoubleQuotes & " indent=" & DoubleQuotes & "yes" & DoubleQuotes & "/>" & vbCrLf & "     <xsl:template match=" & DoubleQuotes & "@* | node()" & DoubleQuotes & ">" & vbCrLf & "          <xsl:copy>" & vbCrLf & "               <xsl:apply-templates select=" & DoubleQuotes & "@* | node()" & DoubleQuotes & " />" & vbCrLf & "          </xsl:copy>" & vbCrLf & "     </xsl:template>" & vbCrLf & "</xsl:stylesheet>"
    objDom.async = False
    oXSLT.async = False
    oXSLT.loadXML XSL_FILE
    If oXSLT.parseError.errorCode = 0 Then
        If oXSLT.readyState = 4 Then
            sResult = objDom.transformNode(oXSLT.documentElement)
            sResult = Replace$(sResult, "<?xml version=" & DoubleQuotes & "1.0" & DoubleQuotes & " encoding=" & DoubleQuotes & "UTF-16" & DoubleQuotes & "?>", vbNullString, , , vbTextCompare)
            objDom.loadXML sResult
        End If
    Else
        Debug.Print Err.Description = oXSLT.parseError.reason & vbCrLf & "Line: " & oXSLT.parseError.Line & vbCrLf & "XML: " & oXSLT.parseError.srcText
        Err.Clear
    End If
 
    strText = objDom.xml
 
    TidyXML = strText
End Function

Cara Yang Sangat Efisien Untuk Mengkonversi Detik

Mengenai cara yang sangat efisien untuk mengkonversi detik ke jam:menit:detik menggunakan VB6 - Kita hanya perlu 1 baris untuk mengkonversi detik ke jam:menit:detik, adapun kodenya adalah sebagai berikut:

Option Explicit

Private Sub Command1_Click()
    MsgBox Format$(DateAdd("s", SecondToConvert, 0), "hh:mm:ss")
End Sub

Subscribe to: Comments ( Atom )

Sunday, June 17, 2012

Saturday, June 16, 2012

Thursday, June 14, 2012

Perhatian

Page Rank

Online

Statistik Pengunjung

embrio9 - Auto Reply

Blog Archive

Visual Basic 6.0

Arabic

Blogging

Miscellaneous