Sunday, June 17, 2012

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

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.

Subscribe to: Posts ( Atom )

Sunday, June 17, 2012

Perhatian

Page Rank

Online

Statistik Pengunjung

embrio9 - Auto Reply

Blog Archive

Visual Basic 6.0

Arabic

Blogging

Miscellaneous