Showing posts with label Internet. Show all posts
Showing posts with label Internet. Show all posts

Tuesday, May 29, 2012

Mengirim Email Lewat VB6.0 Menggunakan vbSendMail.dll

Di bawah ini merupakan contoh kode untuk mengirim email lewat VB6.0 menggunakan bantuan ActiveX (vbSendMail.dll). VB SendMail merupakan ActiveX yang digunakan untuk mengirim email, terdokumentasi dengan baik dan lengkap. Anda dapat memperoleh komponen tersebut di freevbsource.com silakan Anda kunjungi situsnya.
Option Explicit 

Private
WithEvents poSendMail As vbSendMail.clsSendMail
Private bSendFailed As Boolean

Private Sub
Command1_Click()
Dim lCount As Long
Dim
lCtr As Long
Dim
t!

Command1.Enabled = False
bSendFailed = False
lstStatus.Clear
lblTime.Caption = ""
Screen.MousePointer = vbHourglass

With
poSendMail
.SMTPHost = "smtp.telkom.net"
.From = txtSender.Text
.FromDisplayName = txtName.Text
.Message = txtMsg.Text
.AsHTML = True
t! = Timer
.Recipient = txtRecipient.Text
.RecipientDisplayName = txtRecName.Text
.Subject = txtSubject.Text
lblTime = "Sending message " & Str(lCtr)
.Send
End With

If Not
bSendFailed Then lblTime.Caption = Str(lCount) & " Messages sent in " & Format$(Timer - t!, "#,##0.0") & " seconds."
Screen.MousePointer = vbDefault
Command1.Enabled = True
End Sub

Private Sub
Form_Load()
Set poSendMail = New clsSendMail
End Sub

Private Sub
poSendMail_Progress(lPercentCompete As Long)
lblProgress = lPercentCompete & "% complete"
End Sub

Private Sub
poSendMail_SendFailed(Explanation As String)
MsgBox ("Your attempt to send mail failed for the following reason(s): " & vbCrLf & Explanation)
bSendFailed = True
lblProgress = ""
lblTime = ""
End Sub

Private Sub
poSendMail_SendSuccesful()
lblProgress = "Send Successful!"
End Sub

Private Sub
poSendMail_Status(Status As String)
lstStatus.AddItem Status
lstStatus.ListIndex = lstStatus.ListCount - 1
lstStatus.ListIndex = -1
End Sub
READ MORE - Mengirim Email Lewat VB6.0 Menggunakan vbSendMail.dll

Monday, May 28, 2012

Fungsi Untuk Memeriksa Apakah Terhubung Ke Internet

Di bawah ini fungsi untuk memeriksa, apakah komputer terhubung ke internet atau tidak?
Option Explicit 

Private Declare Function
RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function
RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
'
Const RAS95_MaxEntryName = 256
Const RAS95_MaxDeviceType = 16
Const RAS95_MaxDeviceName = 32
'
Private Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
'
Private Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Private Function
IsConnected() As Boolean
'
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim
lpcon As Long
Dim
RetVal As Long
Dim
Tstatus As RASCONNSTATUS95
'
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
'
RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
If RetVal <> 0 Then
MsgBox "ERROR"
Exit Function
End If
'
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
If Tstatus.RasConnState = &H2000 Then
IsConnected = True
Else
IsConnected = False
End If
End Function
Private Sub Command1_Click() 
MsgBox IsConnected
End Sub
READ MORE - Fungsi Untuk Memeriksa Apakah Terhubung Ke Internet

Fungsi Untuk Mendownload URL

Di bawah ini merupakan fungsi untuk mendownload sebuah URL.
Option Explicit 

Private Function
DownloadFile(ByVal sFileSource As String, ByVal sDestFile As String) As Boolean
Dim
bytes() As Byte
Dim
fnum As Integer
bytes() = Inet1.OpenUrl(sFileSource, icByteArray)
fnum = FreeFile

Open
sDestFile For Binary Access Write As #fnum
Put #fnum, , bytes()
Close #fnum

DownloadFile = True
End Function

Contoh penggunaan fungsi di atas:
Private Sub Command1_Click() 
Call DownloadFile("http://4basic-vb.blogspot.com", "C:\download.html")
End Sub
READ MORE - Fungsi Untuk Mendownload URL

Sunday, May 27, 2012

Download File Menggunakan IE

Di bawah ini merupakan procedure untuk mendownload sebuah file dengan memanfaatkan file bawaan IE (internet explorer) hdocvw.dll. Bagaimana implementasinya dalam Visual Basic 6.0? bisa Anda simak kodenya di bawah ini:
Option Explicit 

Private Declare Function
DoFileDownload Lib "shdocvw.dll" (ByVal lpszFile As String) As Long

Public Sub
DownloadFile(URL As String)
Dim sDownload As String
sDownload = StrConv(Text1.Text, vbUnicode)
Call DoFileDownload(sDownload)
End Sub
Contoh penggunaan procedure di atas:
Private Sub Command1_Click()   
DownloadFile "http://google.co.id"
End Sub
READ MORE - Download File Menggunakan IE

Fungsi Untuk Mendapatkan Source HTML dari URL Tertentu

Di bawah ini merupakan fungsi untuk mendapatkan source code HTML dari URL tertentu.
Option Explicit 

Function
GetSource(ByVal URL As String) As String

MousePointer = vbHourglass

Dim
Data() As Byte
Dim
sText As String
Dim i As Long

Data() = Inet1.OpenURL(URL)

sText = Data()
GetSource = sText

MousePointer = vbDefault

End Function
Cara penggunaan fungsi di atas:
Private Sub Command1_Click() 
Dim sUrl As String
sUrl = Text1.Text
Text2.Text = GetSource(sUrl)
End Sub

Untuk tujuan tertentu, maka dengan sedikit modifikasi tentu saja Anda dapat menyimpannya ke dalam hardisk Anda.
READ MORE - Fungsi Untuk Mendapatkan Source HTML dari URL Tertentu

Monday, February 28, 2011

VB6 Code - Save As MHTML

Mengenai cara menyimpan halaman dengan format MHTML menggunakan Visual Basic 6.0 - Menyimpan file dalam format MHTML tentunya memiliki banyak keuntungan, salah satu dari banyak keuntungan tersebut ialah terintegrasinya seluruh gambar dan file dengan baik, sehingga kita bisa mendownload halaman situs/blog yang kita kunjungi utuh dengan seluruh gambarnya.
Option Explicit  

Public Function
SaveWebPageToMHTFile(url As String, filepath As String)

On Error GoTo
ErrHandler

Dim
msg As New CDO.Message
Dim
stm As New ADODB.Stream

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

Exit Function

ErrHandler:

MsgBox Err.Description

End Function
Contoh pemanggilan prosedur fungsi di atas:
Private Sub Command1_Click()  
'//Coba menyimpan file dalam bentuk MHTML </i>
SaveWebPageToMHTFile "http://www.planet-source-code.com/vb/default.asp?lngWId=1", "c:\psc.MHTML"
End Sub
Catatan: Sebelum Anda menggunakan fungsi di atas, tambahkan referensi Microsoft ActiveX Data Objects 2.8 Liblary dan Microsoft CDO for Windows 2000 Liblary
READ MORE - VB6 Code - Save As MHTML

Saturday, February 26, 2011

VB6.0 - Set Google Chrome Default Home Site Programmatically

Mendefaultkan home site IE (Internet Explorer) atau Mozilla Firefox secara pemrograman mungkin kita sudah mengetahuinya, tapi bagaimana dengan Google Chrome yang tergolong relatif masih muda untuk saat ini (2011).

Masalah mendefaultkan Google Chrome home page, hanyalah masalah merubah 1 baris kode yang terdapat pada file preferences yang terdapat pada folder: .... \Local Settings\Application Data\Google\Chrome\User Data\Default.

Atau tepatnya merubah 1 baris kode yang terdapat pada gambar di bawah ini:

Gambar 1  Kode yang dirubah pada file preferences
Di bawah ini merupakan kode untuk mendefaultkan home page Google Chrome. Letakan kode ini pada module.

'---------------------------------------------------------------------------------- 
'From: http://khoiriyyah.blogspot.com
'By: Asep Hibban
'----------------------------------------------------------------------------------
Option Explicit

Public Sub
SetChromeHomepage(URL As String)

Dim
strPath As String, strProfile As String
Dim
strContent As String, strReplace As String
Dim
regex As RegExp, strSystemDrive As String

strPath = Environ("SystemDrive") & Environ("HOMEPATH")
strPath = strPath & "\Local Settings\Application Data\Google\Chrome\User Data\Default"
strProfile = Dir(strPath, vbDirectory)
Debug.Print strPath
If Len(strPath) Then
strPath = strPath & "\Preferences"
strReplace = Chr(34) & "homepage" & Chr(34) & ": " & Chr(34) & URL & Chr(34) & ","
strContent = fGetFileContents(strPath)
Set regex = New RegExp
If InStr(1, strContent, Chr(34) & "homepage" & Chr(34)) = 0 Then
strContent = strContent & vbCrLf & Chr(34) & "homepage" & Chr(34) & ": " & Chr(34) & URL & Chr(34) & ","
sPutStringToFile strContent, strPath
Exit Sub
ElseIf
InStr(1, strContent, strReplace) Then
Exit Sub
End If
'tidak bisa direplace menggunakan replace biasa
'maka kita gunakan regular expressions untuk keperluan ini
regex.Pattern = Chr(34) & "homepage" & Chr(34) & ": .*)"

strContent = regex.Replace(strContent, strReplace)
strContent = Replace(strContent, Chr(34) & "homepage_is_newtabpage" & Chr(34) & ": true,", vbCrLf & Chr(34) & "homepage_is_newtabpage" & Chr(34) & ": false,")
sPutStringToFile strContent, strPath

End If
End Sub

Public Function
fGetFileContents(strPath As String) As String
Dim
hFile As Integer
Dim
strFileContent As String


If
Len(Dir(strPath)) = 0 Then Exit Function

On Error GoTo
ErrGetFile
hFile = FreeFile

Open
strPath For Binary As #hFile
strFileContent = Space(LOF(hFile))
Get #hFile, , strFileContent
Close #hFile

fGetFileContents = strFileContent
Exit Function

ErrGetFile:

Close
MsgBox Err.Description, vbCritical, "GetFileContents"

End Function

Public Sub
sPutStringToFile(strContent As String, strPath As String)
Dim hFile As Integer

'If file exists delete it.
On Error Resume Next
Kill
strPath
On Error GoTo ErrPutString

'Write file
hFile = FreeFile
Open
strPath For Binary As #hFile
Put #hFile, , strContent
Close #hFile

Exit Sub

ErrPutString:

Close #hFile
MsgBox Err.Description, vbCritical, "PutStringToFile"

End Sub
Contoh pemanggilan prosedure di atas:
Private Sub Command1_Click() 
SetChromeHomepage "http://khoiriyyah.blogspot.com"
End Sub
READ MORE - VB6.0 - Set Google Chrome Default Home Site Programmatically

Wednesday, December 22, 2010

Web Color Spy - Mendeteksi Warna Standar Web

Di bawah ini merupakan project VB6 sederhana untuk mendeteksi warna standar web. Bagaimana kode project web color spy untuk mendeteksi warna standar web, bisa lihat di bawah ini:
'simpan kode di bawah pada module 
Option Explicit

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

Type
POINTAPI
X As Long
Y As Long
End Type

Public 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
READ MORE - Web Color Spy - Mendeteksi Warna Standar Web

Thursday, April 15, 2010

Mengirim Email Lewat VB6.0 Menggunakan Vbsendmail.dll

Di bawah ini merupakan contoh kode untuk mengirim email lewat VB6.0 menggunakan bantuan ActiveX (vbSendMail.dll). VB SendMail merupakan ActiveX yang digunakan untuk mengirim email, terdokumentasi dengan baik dan lengkap. Anda dapat memperoleh komponen tersebut di freevbsource.com silakan Anda kunjungi situsnya.
Option Explicit

Private WithEvents poSendMail As vbSendMail.clsSendMail
Private bSendFailed As Boolean

Private Sub Command1_Click()
Dim lCount As Long
Dim lCtr As Long
Dim t!

Command1.Enabled = False
bSendFailed = False
lstStatus.Clear
lblTime.Caption = ""
Screen.MousePointer = vbHourglass

With poSendMail
.SMTPHost = "smtp.telkom.net"
.From = txtSender.Text
.FromDisplayName = txtName.Text
.Message = txtMsg.Text
.AsHTML = True
t! = Timer
.Recipient = txtRecipient.Text
RecipientDisplayName = txtRecName.Text
.Subject = txtSubject.Text
lblTime = "Sending message " & Str(lCtr)
.Send
End With

If Not bSendFailed Then lblTime.Caption = Str(lCount) & " Messages sent in " & Format$(Timer - t!, "#,##0.0") & " seconds."
Screen.MousePointer = vbDefault
Command1.Enabled = True
End Sub

Private Sub Form_Load()
Set poSendMail = New clsSendMail
End Sub

Private Sub poSendMail_Progress(lPercentCompete As Long)
lblProgress = lPercentCompete & "% complete"
End Sub

Private Sub poSendMail_SendFailed(Explanation As String)
MsgBox ("Your attempt to send mail failed for the following reason(s): " & vbCrLf & Explanation)
bSendFailed = True
lblProgress = ""
lblTime = ""
End Sub

Private Sub poSendMail_SendSuccesful()
lblProgress = "Send Successful!"
End Sub

Private Sub poSendMail_Status(Status As String)
lstStatus.AddItem Status
lstStatus.ListIndex = lstStatus.ListCount - 1
lstStatus.ListIndex = -1
End Sub
Download: Source Code
READ MORE - Mengirim Email Lewat VB6.0 Menggunakan Vbsendmail.dll

Sunday, April 4, 2010

VB6 Code - Mendownload Sebuah URL

Di bawah ini merupakan fungsi VB6 untuk mendownload sebuah URL. Adapun kode VB6 untuk mendownload sebuah URL adalah sebagai berikut:
Option Explicit

Private Function DownloadFile(ByVal sFileSource As String, ByVal sDestFile As String) As Boolean
Dim bytes() As Byte
Dim fnum As Integer
bytes() = Inet1.OpenUrl(sFileSource, icByteArray)
fnum = FreeFile

Open sDestFile For Binary Access Write As #fnum
Put #fnum, , bytes()
Close #fnum

DownloadFile = True
End Function
Contoh penggunaan fungsi di atas:
Private Sub Command1_Click()
Call DownloadFile("http://4basic-vb.blogspot.com", "C:\download.html")
End Sub
Demikian kode VB6 untuk mendownload sebuah URL. Semoga bermanfaat.
READ MORE - VB6 Code - Mendownload Sebuah URL

VB6 Code - Memeriksa Apakah Komputer Terhubung Ke Internet

Di bawah ini merupakan fungsi VB6 untuk memeriksa sebuah komputer terhubung ke internet atau tidak?. Adapun kode VB6 untuk memeriksa sebuah komputer apakah terhubung ke internet adalah sebagai berikut:
Option Explicit

Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
'
Const RAS95_MaxEntryName = 256
Const RAS95_MaxDeviceType = 16
Const RAS95_MaxDeviceName = 32
'
Private Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
'
Private Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Private Function IsConnected() As Boolean
'
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95
'
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
'
RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
If RetVal <> 0 Then
MsgBox "ERROR "
Exit Function
End If
'
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
If Tstatus.RasConnState = &H2000 Then
IsConnected = True
Else
IsConnected = False
End If
End Function
Contoh penggunaan fungsi VB6 di atas:
Private Sub Command1_Click()
MsgBox IsConnected
End Sub
Demikian mengenai fungsi VB6 untuk memeriksa apakah sebuah komputer terhubung ke internet?
READ MORE - VB6 Code - Memeriksa Apakah Komputer Terhubung Ke Internet

Saturday, April 3, 2010

VB6 Code - Download File Menggunakan IE

Di bawah ini merupakan procedure VB6 untuk mendownload sebuah file dengan memanfaatkan file bawaan IE (internet explorer) hdocvw.dll. Bagaimana implementasinya dalam Visual Basic 6.0? bisa Anda simak kodenya di bawah ini:
Option Explicit

Private Declare Function DoFileDownload Lib "shdocvw.dll" (ByVal lpszFile As String) As Long

Public Sub DownloadFile(URL As String)
Dim sDownload As String
sDownload = StrConv(Text1.Text, vbUnicode)
Call DoFileDownload(sDownload)
End Sub
Contoh penggunaan procedure VB6 di atas:
Private Sub Command1_Click()
DownloadFile "http://google.co.id"
End Sub
READ MORE - VB6 Code - Download File Menggunakan IE

VB6 Code - Mendapatkan Source Html Dari URLTertentu

Di bawah ini merupakan fungsi VB6 untuk mendapatkan source code HTML dari URL tertentu.
Option Explicit

Function GetSource(ByVal URL As String) As String

MousePointer = vbHourglass

Dim Data() As Byte
Dim sText As String
Dim i As Long

Data() = Inet1.OpenURL(URL)

sText = Data()
GetSource = sText

MousePointer = vbDefault

End Function
Cara penggunaan fungsi VB6 di atas:
Private Sub Command1_Click()
Dim sUrl As String
sUrl = Text1.Text
Text2.Text = GetSource(sUrl)
End Sub

Untuk tujuan tertentu, maka dengan sedikit modifikasi tentu saja Anda dapat menyimpannya ke dalam hardisk Anda.
READ MORE - VB6 Code - Mendapatkan Source Html Dari URLTertentu

VB Code - Fungsi Personal Editor Html Unordering List [ ul ]

Ini merupakan fungsi VB6 yang digunakan untuk membuat personal editor. Tag yang akan kita modifikasi adalah tag UL (Unordering List).
Option Explicit

Function UL(strText As String) As String
Dim sText As String
Dim aText() As String
Dim i As Integer
sText = strText
aText = Split(sText, vbCrLf)
For i = LBound(aText) To UBound(aText)
Select Case i
Case LBound(aText)
sText = "<ul>" & "<li>" & aText(i) & "</li>" & vbCrLf
Case UBound(aText)
sText = sText & "<li>" & aText(i) & "</li>" & "</ul>"
Case Else
sText = sText & "<li>" & aText(i) & "</li>" & vbCrLf
End Select
Next
UL = sText
End Function
Cara penggunaan Fungsi Personal Editor HTML Unordering List <UL>
Private Sub Command1_Click()
Text1.SelText = UL(Text1.SelText)
End Sub
READ MORE - VB Code - Fungsi Personal Editor Html Unordering List [ ul ]

VB6 Code - Fungsi Encode Dan Decode Tag HTML

Mengenai Fungsi VB6 untuk meng-encode dan decode tag HTML - Kode HTML yang dituliskan dalam sebuah tulisan/postingan tentu saja tidak dapat ditulis secara langsung tetapi harus dikonversi terlebih dahulu agar format tulisannya sesuai dengan apa yang diharapkan. Perlu kita ketahui bahwa mesin penerjemah (compiler) akan menganggap tulisannya merupakan kode HTML dan menerjemahkannya, padahal yang kita maksud adalah tulisan, tulisan yang mengandung kode HTML . Dibawah ini merupakan fungsi encode dan decode tag HTML yang bisa Anda gunakan ketika membuat tulisan/postingan yang melibatkan banyak kode/tag HTML.
Option Explicit

Dim EncodeTag() As String
Dim DecodeTag() As String

Enum eType
Decode
Encode
End Enum

Public Function EncDecTag(strText As String, EncDec As eType) As String
Dim i As Integer
InitTagArray
For i = LBound(EncodeTag) To UBound(EncodeTag)
If EncDec = Encode Then
strText = Replace(strText, EncodeTag(i), DecodeTag(i), , , vbTextCompare)
Else
strText = Replace(strText, DecodeTag(i), EncodeTag(i), , , vbTextCompare)
End If
Next
EncDecTag = strText
End Function

Private Function InitTagArray()
Dim EncTag As String
Dim DecTag As String
EncTag = "&,<,>," & Chr(34) & ",±"
DecTag = "&amp;,&lt;,&gt;,&quot;,&plusmn;"
EncodeTag = Split(EncTag, ",")
DecodeTag = Split(LCase(DecTag), ",")
End Function
Cara Penggunaan Fungsi Encode dan Decode Tag HTML
Private Sub Command1_Click()
Text1.SelText = EncDecTag(Text1.SelText, Decode)
End Sub

Private Sub Command2_Click()
Text1.SelText = EncDecTag(Text1.SelText, Encode)
End Sub
READ MORE - VB6 Code - Fungsi Encode Dan Decode Tag HTML

VB6 Code - Fungsi Personal Editor HTML Ordering List [ ol ]

Ini merupakan fungsi VB6 yang digunakan untuk membuat personal editor. Tag yang akan kita modifikasi adalah tag OL (Ordering List).
Option Explicit

Function OL(strText As String) As String
Dim sText As String
Dim aText() As String
Dim i As Integer
sText = strText
aText = Split(sText, vbCrLf)
For i = LBound(aText) To UBound(aText)
Select Case i
Case LBound(aText)
sText = "<ol>" & "<li>" & aText(i) & "</li>" & vbCrLf
Case UBound(aText)
sText = sText & "<li>" & aText(i) & "</li>" & "</ol>"
Case Else
sText = sText & "<li>" & aText(i) & "</li>" & vbCrLf
End Select
Next
OL = sText
End Function

Cara penggunaan Fungsi Personal Editor HTML Ordering List <OL>
Private Sub Command1_Click()
Text1.SelText = OL(Text1.SelText)
End Sub
READ MORE - VB6 Code - Fungsi Personal Editor HTML Ordering List [ ol ]