Saturday, April 17, 2010

Menampilkan Kata Yang Berada Di atas Pointer Mouse - VB6

Ini merupakan fungsi untuk menampilkan kata yang berada tepat di bawah pointer mouse. Fungsi ini hanya berjalan pada object RichTextBox. Bagaimana implementasi dari kodenya? bisa Anda perhatikan di bawah:
Option Explicit 

Private Const
EM_CHARFROMPOS& = &HD7

Private Type
POINTAPI
x As Long
y As Long
End Type

Private Declare Function
SendMessage Lib "USER32" Alias "SendMessageA" ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

' Return the word the mouse is over.
Public Function RichWordOver(rch As RichTextBox, x As Single, y As Single) As String

Dim pt As
POINTAPI
Dim Pos As Integer
Dim
start_pos As Integer
Dim
end_pos As Integer
Dim ch As String
Dim
txt As String
Dim
txtlen As Integer

' Convert the position to pixels.
pt.x = x \ Screen.TwipsPerPixelX
pt.y = y \ Screen.TwipsPerPixelY

' Get the character number
Pos = SendMessage(rch.hWnd, EM_CHARFROMPOS, 0&, pt)
If Pos <= 0 Then Exit Function

' Find the start of the word.
txt = rch.Text
For start_pos = Pos To 1 Step -1
ch = Mid$(rch.Text, start_pos, 1)
' Allow digits, letters, and underscores.
If Not _
ch >= "0" And ch <= "9") Or _
ch >= "a" And ch <= "z") Or _
ch >= "A" And ch <= "Z") Or _
ch = "_" _
) Then Exit For
Next
start_pos
start_pos = start_pos + 1

' Find the end of the word.
txtlen = Len(txt)
For end_pos = Pos To txtlen
ch = Mid$(txt, end_pos, 1)
' Allow digits, letters, and underscores.
If Not _
ch >= "0" And ch <= "9") Or _
ch >= "a" And ch <= "z") Or _
ch >= "A" And ch <= "Z") Or _
ch = "_" _
) Then Exit For
Next
end_pos
end_pos = end_pos - 1

If
start_pos <= end_pos Then RichWordOver = Mid$(txt, start_pos, end_pos - start_pos + 1)
End Function
Contoh penggunaanya:
Option Explicit 

Dim
strWordOver As String

Private Sub
RichTextBox1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
strWordOver = RichWordOver(RichTextBox1, x, y)
If Trim(strWordOver) = "" Then Exit Sub
If
Text1.Text <> strWordOver Then
Text1.Text = strWordOver
End If
End Sub
READ MORE - Menampilkan Kata Yang Berada Di atas Pointer Mouse - VB6

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

Wednesday, April 14, 2010

VB6 Code - Fungsi Format RTF Untuk Pembuatan Kamus

Pernah menggunakan Kamus 2.04 (Kamus Bahasa Inggris)? Di sana terdapat objek RichTextBox yang memuat terjemahan bahasa Inggris yang diformat secara warna-warni. Kamus tersebut dibuat dengan bahasa pemrograman Delphi. Nah, Bagaimana imlementasi format RichTextBox tersebut dalam bahasa pemrograman VB6.0.
Di bawah ini merupakan contoh format RTF untuk keperluan pembuatan kamus Bahasa Inggris. Fungsi di bawah ini dapat bekerja dengan sangat cepat, mengapa? karena ia tidak memformat tulisan pada objeknya secara langsung akan tetapi, memformat string yang terdapat dalam memori kemudian mem-feed-nya kembali ke dalam objek RichTextBox.

Bukankah:
Private Sub Command1_Click()
Dim i As Integer
For i = 1 To 1000
Text1.Text = Text1.Text & "contoh tulisan" & vbCrLf
Next
End Sub
Berbeda dengan kode di bawah ini:
Private Sub Command1_Click()
Dim i As Integer
Dim sText As String
sText = Text1.Text
For i = 1 To 1000
sText = sText & "contoh tulisan" & vbCrLf
Next
Text1.Text = sText
End Sub
Sepintas dua kode di atas akan memberikan hasil yang sama akan tetapi berbeda jauh dalam segi kecepatan.

Di bawah ini merupakan fungsi format RTF untuk pembuatan kamus bahasa inggris:
Option Explicit

Public Function FormatSentence(sSentence As String) As String
Dim sFormat As String
Dim sKosakata As String
Dim sText As String
Dim i As Integer
sFormat = "{\rtf1\fbidis\ansi\ansicpg1256\deff0\deflang1025{\fonttbl{\f0\fswiss\fcharset0 Arial;}}" & vbCrLf & _
"{\colortbl ;\red128\green0\blue0;\red0\green0\blue255;\red0\green128\blue128;\red0\green0\blue128;\red255\green0\blue0;\red128\green0\blue128;}" & vbCrLf & _
"{\*\generator Msftedit 5.41.15.1512;}\viewkind4\uc1\pard\ltrpar\lang1033\f0\fs17"
sKosakata = sSentence
sText = " " & Text1.Text
sText = Replace(sText, vbCrLf, " \Par" & vbCrLf)
sText = Replace(sText, " kb. ", " \cf2\b kb. \cf0\b0 ")
sText = Replace(sText, " -kki. ", " \cf5\b kki. \cf0\b0 ")
sText = Replace(sText, " kk. ", " \cf1\b kk. \cf0\b0 ")
sText = Replace(sText, " ks. ", " \cf3\b ks. \cf0\b0 ")
sText = Replace(sText, " -ks. ", " \cf3\b -ks. \cf0\b0 ")
sText = Replace(sText, " -kkt. ", " \cf5\b -kkt. \cf0\b0 ")
sText = Replace(sText, "(", "\cf5(\cf0 ")
sText = Replace(sText, ")", "\cf5)\cf0 ")
For i = 1 To 100
If InStr(1, sText, i) Then
sText = Replace(sText, " " & i & " ", " \b " & i & " \cf0\b0 ")
End If
Next
sText = Replace(sText, " -kkt. ", " \cf5\b -kkt. \cf0\b0 ")
sText = Replace(sText, " ks. ", " \cf3\b ks. \cf0\b0 ")
sText = sFormat & "\b " & sKosakata & "\b0 " & sText & "\par" & vbCrLf & "}"
FormatSentence = sText
End Function

Private Sub Form_Load()
RTF.BackColor = RGB(241, 243, 241)
End Sub
Contoh penggunaan fungsi di atas:
Private Sub Command1_Click()
RTF.TextRTF = FormatSentence(Text2.Text)
End Sub
Maka hasilnya seperti gambar di bawah ini:


Catatan:
Fungsi di atas hanyalah sekadar contoh, Anda dapat memodifikasinya untuk disesuaikan dengan kebutuhan.

Download: Source code fungsi format RTF untuk Kamus Bahasa Inggris
READ MORE - VB6 Code - Fungsi Format RTF Untuk Pembuatan Kamus

Advance Form Center - Bagian Dua

Advance form center - Ini merupakan fungsi untuk menyimpan form di tengah layar, adapun ditambah kata advance, karena ia memiliki beberapa keunggulan, yaitu:menjalankan form dan menempatkannya di tengah layar, ini hanya dilakukan sekali pada saat ia ditampilkan pertama kali, setelah itu form akan mengikuti nilai yang ada pada registry.
'simpan kode di bawah pada module 
Option Explicit

Private Declare Function
GetSystemMetrics Lib "user32" ByVal nIndex As Long) As Long
Private Const
SM_CXFULLSCREEN = 16
Private Const SM_CYFULLSCREEN = 17

Private Const
strKey As String = "HKEY_CURRENT_USER\Software\"

Public Function
SavePositionsInRegistry(frm As Form)

If
frm.WindowState = vbMaximized Or frm.WindowState = vbMinimized Then Exit Function

Dim
KeyReg As String, k As String

KeyReg = strKey & App.Title & "\" & frm.Name & "\"
RegWrite KeyReg & "FormLeft", frm.Left
RegWrite KeyReg & "FormTop", frm.Top
RegWrite KeyReg & "FormWidth", frm.Width
RegWrite KeyReg & "FormHeight", frm.Height

End Function

Public Function
GetPositionsFromRegistry(frm As Form)

If
frm.WindowState = vbMaximized Or frm.WindowState = vbMinimized Then Exit Function

Dim
KeyReg As String
Dim
ileft, itop, iwidth, iheight
Dim lCenterLeft As Long, lCenterTop As Long

GetFormCenter frm, lCenterLeft, lCenterTop
KeyReg = strKey & App.Title & "\" & frm.Name & "\"

ileft = IIf(IsEmpty(RegRead(KeyReg & "FormLeft")), lCenterLeft, RegRead(KeyReg & "FormLeft"))
itop = IIf(IsEmpty(RegRead(KeyReg & "FormTop")), lCenterTop, RegRead(KeyReg & "FormTop"))
iwidth = IIf(IsEmpty(RegRead(KeyReg & "FormWidth")), frm.Width, RegRead(KeyReg & "FormWidth"))
iheight = IIf(IsEmpty(RegRead(KeyReg & "FormHeight")), frm.Height, RegRead(KeyReg & "FormHeight"))

frm.Move ileft, itop, iwidth, iheight

End Function

Private Function
GetFormCenter(frm As Form, lLeft As Long, lTop As Long)
With frm
lLeft = Screen.TwipsPerPixelX * GetSystemMetrics(SM_CXFULLSCREEN) / 2)) - .Width / 2)
lTop = Screen.TwipsPerPixelY * GetSystemMetrics(SM_CYFULLSCREEN) / 2)) - .Height / 2)
End With
End Function
READ MORE - Advance Form Center - Bagian Dua