Sunday, August 29, 2010

Encoding Strings using Escape Characters Basic

This how to encoding string using escape character. First, create new module and copy this code:

Public Function Encode(ByVal Val As String) As String
Dim i As Long, curChar As String

For i = 1 To Len(Val)
curChar = Mid(Val, i, 1)
If curChar = vbCr Then
Encode = Encode & "c"
ElseIf curChar = vbLf Then
Encode = Encode & "l"
ElseIf curChar = "" Then
Encode = Encode & "\"
Else
Encode = Encode & curChar
End If
Next i

End Function

Public Function Decode(ByVal Val As String) As String
Dim i As Long, curChar As String, EscapeMode As Boolean

For i = 1 To Len(Val)
curChar = Mid(Val, i, 1)
If EscapeMode = False Then
If curChar = "" Then
EscapeMode = True
Else
Decode = Decode & curChar
End If
Else
If curChar = "" Then
Decode = Decode & ""
ElseIf curChar = "c" Then
Decode = Decode & vbCr
ElseIf curChar = "l" Then
Decode = Decode & vbLf
End If
EscapeMode = False
End If
Next i

End Function
Read more »»

Friday, August 27, 2010

Make a transparent bitmap

Here's a simple way to create a bitmap to be transparent. First create a new module and paste the following code:

Option Explicit

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Declare Function BitBlt Lib "gdi32" _
(ByVal hDCDest As Long, ByVal XDest As Long, _
ByVal YDest As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hDCSrc As Long, _
ByVal XSrc As Long, ByVal YSrc As Long, _
ByVal dwRop As Long) As Long

Public Declare Function CreateBitmap Lib "gdi32" _
(ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal nPlanes As Long, _
ByVal nBitCount As Long, _
lpBits As Any) As Long

Public Declare Function SetBkColor Lib "gdi32" _
(ByVal hdc As Long, ByVal crColor As Long) As Long

Public Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long

Public Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Public Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long)As Long

Public Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long

Public Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Add this code to the form's General Declarations procedure:

Private Sub Command1_Click()
Dim R As RECT
With R
.Left = 0
.Top = 0
.Right = Picture1.ScaleWidth
.Bottom = Picture1.ScaleHeight
End With
TransparentBlt Form1.hdc, Form1.hdc, Picture1.hdc, R, 20, 20, vbWhite
End Sub

Private Sub TransparentBlt(OutDstDC As Long, _
DstDC As Long,_
SrcDC As Long,_
SrcRect As RECT, _
DstX As Integer,_
DstY As Integer,_
TransColor As Long)

Dim nRet As Long, W As Integer, H As Integer
Dim MonoMaskDC As Long, hMonoMask As Long
Dim MonoInvDC As Long, hMonoInv As Long
Dim ResultDstDC As Long, hResultDst As Long
Dim ResultSrcDC As Long, hResultSrc As Long
Dim hPrevMask As Long, hPrevInv As Long
Dim hPrevSrc As Long, hPrevDst As Long
W = SrcRect.Right - SrcRect.Left + 1
H = SrcRect.Bottom - SrcRect.Top + 1
MonoMaskDC = CreateCompatibleDC(DstDC)
MonoInvDC = CreateCompatibleDC(DstDC)
hMonoMask = CreateBitmap(W, H, 1, 1, ByVal 0&)
hMonoInv = CreateBitmap(W, H, 1, 1, ByVal 0&)
hPrevMask = SelectObject(MonoMaskDC, hMonoMask)
hPrevInv = SelectObject(MonoInvDC, hMonoInv)
ResultDstDC = CreateCompatibleDC(DstDC)
ResultSrcDC = CreateCompatibleDC(DstDC)
hResultDst = CreateCompatibleBitmap(DstDC, W, H)
hResultSrc = CreateCompatibleBitmap(DstDC, W, H)
hPrevDst = SelectObject(ResultDstDC, hResultDst)
hPrevSrc = SelectObject(ResultSrcDC, hResultSrc)
Dim OldBC As Long
OldBC = SetBkColor(SrcDC, TransColor)
nRet = BitBlt(MonoMaskDC, 0, 0, W, H, SrcDC, _
SrcRect.Left, SrcRect.Top, vbSrcCopy)
TransColor = SetBkColor(SrcDC, OldBC)
nRet = BitBlt(MonoInvDC, 0, 0, W, H, _
MonoMaskDC, 0, 0, vbNotSrcCopy)
nRet = BitBlt(ResultDstDC, 0, 0, W, H, _
DstDC, DstX, DstY, vbSrcCopy)
nRet = BitBlt(ResultDstDC, 0, 0, W, H, _
MonoMaskDC, 0, 0, vbSrcAnd)
nRet = BitBlt(ResultSrcDC, 0, 0, W, H, SrcDC, _
SrcRect.Left, SrcRect.Top, vbSrcCopy)
nRet = BitBlt(ResultSrcDC, 0, 0, W, H, _
MonoInvDC, 0, 0, vbSrcAnd)
nRet = BitBlt(ResultDstDC, 0, 0, W, H, _
ResultSrcDC, 0, 0, vbSrcInvert)
nRet = BitBlt(OutDstDC, DstX, DstY, W, H, _
ResultDstDC, 0, 0, vbSrcCopy)
hMonoMask = SelectObject(MonoMaskDC, hPrevMask)
DeleteObject hMonoMask
hMonoInv = SelectObject(MonoInvDC, hPrevInv)
DeleteObject hMonoInv
hResultDst = SelectObject(ResultDstDC, hPrevDst)
DeleteObject hResultDst
hResultSrc = SelectObject(ResultSrcDC, hPrevSrc)
DeleteObject hResultSrc
DeleteDC MonoMaskDC
DeleteDC MonoInvDC
DeleteDC ResultDstDC
DeleteDC ResultSrcDC
End Sub
Read more »»

Thursday, January 14, 2010

Get Mouse Cursor Position Inside or Outside Form

Here is a simple way to get mouse cursor position on the form or outside the form. First create a new form, then add the label and the timer control on the form. After that, paste the following code:

Private Declare Function GetCursorPos Lib "user32" (lpPoint As _
POINTAPI) As Long

Private Type POINTAPI
x As Long
y As Long
End Type
Dim a As POINTAPI
Dim b As Long
Dim c As Long

Private Sub Form_Load()
Timer1.Interval = 1
End Sub

Private Sub Timer1_Timer()
mousepos
End Sub

Private Sub mousepos()
ret = GetCursorPos(a)
b = a.x
c = a.y
Label1.Caption = b
Label2.Caption = c
End Sub

Read more »»

Wednesday, January 13, 2010

Send Email using MAPI control on VB6

Here is a simple way to send messages using MAPI control. First add the MAPI component and add the MAPI session and MAPI mail control in your form. Then paste the following code:

Public Function send_mail(sendto As String, subject As String, _
text As String) As Boolean

On Error GoTo ErrHandler
With MAPISession1
.DownLoadMail = False
.LogonUI = True
.SignOn
.NewSession = True
MAPIMessages1.SessionID = .SessionID
End With
With MAPIMessages1
.Compose
.RecipAddress = sendto
.AddressResolveUI = True
.ResolveName
.MsgSubject = subject
.MsgNoteText = text
.Send False
End With
sendmail = True
ErrHandler:
End Function

Read more »»

Wednesday, January 6, 2010

Play MPEG files in VB6

Here is a simple example to play MPEG files in VB6. First create a new User Control, and then give the name MPEGViewer or whatever. After that, paste the code below:

Option Explicit

Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long

Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Const m_def_FileName = ""

Dim m_FileName As String

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
UserControl.Enabled() = New_Enabled
PropertyChanged "Enabled"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,
Public Property Get FileName() As String
FileName = m_FileName
End Property

Public Property Let FileName(ByVal New_FileName As String)
m_FileName = New_FileName
PropertyChanged "FileName"
End Property

Private Sub UserControl_InitProperties()
m_FileName = m_def_FileName
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
m_FileName = PropBag.ReadProperty("FileName", m_def_FileName)
End Sub

Private Sub UserControl_Terminate()
mmStop
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
Call PropBag.WriteProperty("FileName", m_FileName, m_def_FileName)
End Sub

Public Function IsPlaying() As Boolean
Static s As String * 30
mciSendString "status MPEGPlay mode", s, Len(s), 0
IsPlaying = (Mid$(s, 1, 7) = "playing")
End Function

Public Function mmPlay()
Dim cmdToDo As String * 255
Dim dwReturn As Long
Dim ret As String * 128

Dim tmp As String * 255
Dim lenShort As Long
Dim ShortPathAndFie As String

If Dir(FileName) = "" Then
mmOpen = "Error with input file"
Exit Function
End If
lenShort = GetShortPathName(FileName, tmp, 255)
ShortPathAndFie = Left$(tmp, lenShort)
glo_hWnd = hWnd
cmdToDo = "open " & ShortPathAndFie & " type MPEGVideo Alias MPEGPlay Parent " & UserControl.hWnd & " Style 1073741824"
dwReturn = mciSendString(cmdToDo, 0&, 0&, 0&)

If dwReturn <> 0 Then
mciGetErrorString dwReturn, ret, 128
mmOpen = ret
MsgBox ret, vbCritical
Exit Function
End If

mmPlay = "Success"
mciSendString "play MPEGPlay", 0, 0, 0
End Function

Public Function mmPause()
mciSendString "pause MPEGPlay", 0, 0, 0
End Function

Public Function mmStop() As String
mciSendString "stop MPEGPlay", 0, 0, 0
mciSendString "close MPEGPlay", 0, 0, 0
End Function

Public Function PositionInSec()
Static s As String * 30
mciSendString "set MPEGPlay time format milliseconds", 0, 0, 0
mciSendString "status MPEGPlay position", s, Len(s), 0
PositionInSec = Round(Mid$(s, 1, Len(s)) / 1000)
End Function

Public Function Position()
Static s As String * 30
mciSendString "set MPEGPlay time format milliseconds", 0, 0, 0
mciSendString "status MPEGPlay position", s, Len(s), 0
sec = Round(Mid$(s, 1, Len(s)) / 1000)
If sec < 60 Then Position = "0:" & Format(sec, "00")
If sec > 59 Then
mins = Int(sec / 60)
sec = sec - (mins * 60)
Position = Format(mins, "00") & ":" & Format(sec, "00")
End If
End Function

Public Function LengthInSec()
Static s As String * 30
mciSendString "set MPEGPlay time format milliseconds", 0, 0, 0
mciSendString "status MPEGPlay length", s, Len(s), 0
LengthInSec = Round(Val(Mid$(s, 1, Len(s))) / 1000) 'Round(CInt(Mid$(s, 1, Len(s))) / 1000)
End Function

Public Function Length()
Static s As String * 30
mciSendString "set MPEGPlay time format milliseconds", 0, 0, 0
mciSendString "status MPEGPlay length", s, Len(s), 0
sec = Round(Val(Mid$(s, 1, Len(s))) / 1000) 'Round(CInt(Mid$(s, 1, Len(s))) / 1000)
If sec < 60 Then Length = "0:" & Format(sec, "00")
If sec > 59 Then
mins = Int(sec / 60)
sec = sec - (mins * 60)
Length = Format(mins, "00") & ":" & Format(sec, "00")
End If
End Function

Public Function SeekTo(Second)
mciSendString "set MPEGPlay time format milliseconds", 0, 0, 0
If IsPlaying = True Then mciSendString "play MPEGPlay from " & Second, 0, 0, 0
If IsPlaying = False Then mciSendString "seek MPEGPlay to " & Second, 0, 0, 0
End Function

Read more »»

Sunday, January 3, 2010

Create Shortcut using VB6

The following simple code example to create a shortcut. First of all, create a new module and name it "myshortcut" or whatever. After that, paste the code below :

Sub CreateShortCut(File As String, icon As String, iconindex As Long, Target As String)
Dim intFreeFile As Integer
File = File & ".url"
intFreeFile = FreeFile
Open File For Output As intFreeFile
Print #intFreeFile, "[InternetShortcut]"
Print #intFreeFile, "URL=" & Target
Print #intFreeFile, "IconFile=" & icon
Print #intFreeFile, "Iconindex=" & iconindex
Close intFreeFile
End Sub


Hopefully this code can be useful for you :)
Read more »»

Monday, December 14, 2009

Disable Keyboard and Mouse using VB6

The following simple example code to disable the keyboard and mouse. First create a form and add the two commands on the form, then paste the following code:

' for disable keyboard
Private Sub Command1_Click()
dim aa
aa=shell("rundll keyboard,disable")
End Sub

'for disable mouse
Private Sub Command2_Click()
dim aa
aa=shell("RUNDLL MOUSE,DISABLE")
End Sub


NOTE;
To reactive them you may need to restart your computer :)
Read more »»

Saturday, December 12, 2009

Read Text From a File

Here's how to read text from a file. First create a new module and paste the following code:

Public Function TextFromFile(fInStream As String) As String
Dim i As Long, strText As String
i = FreeFile
strText = ""
Open fInStream For Input Lock Write As #i
Screen.MousePointer = vbHourglass
DoEvents
strText = StrConv(InputB$(LOF(i), i), vbUnicode)
Close #i
Screen.MousePointer = vbDefault
TextFromFile = strText
End Function

Read more »»

Saturday, November 14, 2009

Execute a file with its default program

To execute application or file using vb6 you can insert this code:

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal _
lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Sub RunCMD(Optional Filename As String)
Call ShellExecute(0&,vbNullString,Filename, vbNullString, _
vbNullString, vbNormalFocus)
End Sub
Read more »»

Sunday, August 30, 2009

Export SQL data to CSV

Maybe you are confused to export SQL data to CSV file format. Here is a simple source code to export SQL data to CSV file format

First create a new module and paste the following code:

Public Function CSVExport(db As DAO.Database, sSQL As String, sDest As String) As Boolean

Dim record As Recordset
Dim nI As Long
Dim nJ As Long
Dim nFile As Integer
Dim sTmp As String

On Error GoTo Err_Handler

Set record = db.OpenRecordset(sSQL, DAO.dbOpenDynaset, DAO.dbReadOnly)

nFile = FreeFile

Open sDest For Output As #nFile

For nI = 0 To record.Fields.Count - 1
sTmp = "" & (record.Fields(nI).Name)
Write #nFile, sTmp;
Next
Write #nFile,

If record.RecordCount > 0 Then
record.MoveLast
record.MoveFirst

For nI = 1 To record.RecordCount
For nJ = 0 To record.Fields.Count - 1
sTmp = "" & (record.Fields(nJ))
Write #nFile, sTmp;
Next
Write #nFile,
record.MoveNext
Next
End If

Close #nFile
CSVExport = True

Exit Function

Err_Handler:
MsgBox ("Error: " & Err.Description)

CSVExport = False

End Function

Read more »»