Create Indonesia Decimal Speller Functions In Visual Basic 6.0

The following functions are one of the most commonly used functions for creating a project such as Sales and Inventory programs, as they usually need to generate transaction receipts.

Open a new project (Standard.Exe), in Form1 put 2 pieces of textbox for Name property leave with its default name.

Go to editor mode, click View -> Code, and enter the following code :

Public Function TerbilangDesimal(InputCurrency As String, Optional MataUang As String = "rupiah") As String
 Dim strInput As String
 Dim strBilangan As String
 Dim strPecahan As String
   On Error GoTo Pesan
   Dim strValid As String, huruf As String * 1
   Dim i As Integer
   'Periksa setiap karakter yg diketikkan ke kotak
   'UserID
   strValid = "1234567890,"
   For i% = 1 To Len(InputCurrency)
     huruf = Chr(Asc(Mid(InputCurrency, i%, 1)))
     If InStr(strValid, huruf) = 0 Then
       Set AngkaTerbilang = Nothing
       MsgBox "Harus karakter angka!", _
              vbCritical, "Karakter Tidak Valid"
       Exit Function
     End If
   Next i%

 If InputCurrency = "" Then Exit Function
 If Len(Trim(InputCurrency)) > 15 Then GoTo Pesan

 strInput = CStr(InputCurrency) 'Konversi ke string
 'Periksa apakah ada tanda "," jika ya berarti pecahan
 If InStr(1, strInput, ",", vbBinaryCompare) Then
      
  strBilangan = Left(strInput, InStr(1, strInput, _
                ",", vbBinaryCompare) - 1)
  'strBilangan = Right(strInput, InStr(1, strInput, _
  '              ".", vbBinaryCompare) - 2)
  strPecahan = Trim(Right(strInput, Len(strInput) - Len(strBilangan) - 1))
  
  If MataUang <> "" Then
      
  If CLng(Trim(strPecahan)) > 99 Then
     strInput = Format(Round(CDbl(strInput), 2), "#0.00")
     strPecahan = Format((Right(strInput, Len(strInput) - Len(strBilangan) - 1)), "00")
    End If
    
    If Len(Trim(strPecahan)) = 1 Then
       strInput = Format(Round(CDbl(strInput), 2), _
                  "#0.00")
       strPecahan = Format((Right(strInput, _
          Len(strInput) - Len(strBilangan) - 1)), "00")
    End If
    
    If CLng(Trim(strPecahan)) = 0 Then
    TerbilangDesimal = (KonversiBilangan(strBilangan) & MataUang & " " & KonversiBilangan(strPecahan))
 Else
  TerbilangDesimal = (KonversiBilangan(strBilangan) & MataUang & " " & KonversiBilangan(strPecahan) & "sen")
    End If
  Else
    TerbilangDesimal = (KonversiBilangan(strBilangan) & "koma " & KonversiPecahan(strPecahan))
  End If
  
 Else
    TerbilangDesimal = (KonversiBilangan(strInput))
  End If
 Exit Function
Pesan:
  TerbilangDesimal = "(maksimal 15 digit)"
End Function

'Fungsi ini untuk mengkonversi nilai pecahan (setelah 'angka 0)
Private Function KonversiPecahan(strAngka As String) As String
Dim i%, strJmlHuruf$, Urai$, Kar$
 If strAngka = "" Then Exit Function
    strJmlHuruf = Trim(strAngka)
    Urai = ""
    Kar = ""
    For i = 1 To Len(strJmlHuruf)
      'Tampung setiap satu karakter ke Kar
      Kar = Mid(strAngka, i, 1)
      Urai = Urai & Kata(CInt(Kar))
    Next i
    KonversiPecahan = Urai
End Function

'Fungsi ini untuk menterjemahkan setiap satu angka ke 'kata
Private Function Kata(angka As Byte) As String
   Select Case angka
          Case 1: Kata = "satu "
          Case 2: Kata = "dua "
          Case 3: Kata = "tiga "
          Case 4: Kata = "empat "
          Case 5: Kata = "lima "
          Case 6: Kata = "enam "
          Case 7: Kata = "tujuh "
          Case 8: Kata = "delapan "
          Case 9: Kata = "sembilan "
          Case 0: Kata = "nol "
   End Select
End Function

'Ini untuk mengkonversi nilai bilangan sebelum pecahan
Private Function KonversiBilangan(strAngka As String) As String
Dim strJmlHuruf$, intPecahan As Integer, strPecahan$, Urai$, Bil1$, strTot$, Bil2$
 Dim X, Y, z As Integer

 If strAngka = "" Then Exit Function
    strJmlHuruf = Trim(strAngka)
    X = 0
    Y = 0
    Urai = ""
    While (X < Len(strJmlHuruf))
      X = X + 1
      strTot = Mid(strJmlHuruf, X, 1)
      Y = Y + Val(strTot)
      z = Len(strJmlHuruf) - X + 1
      Select Case Val(strTot)
      'Case 0
       '   Bil1 = "NOL "
      Case 1
          If (z = 1 Or z = 7 Or z = 10 Or z = 13) Then
              Bil1 = "satu "
          ElseIf (z = 4) Then
              If (X = 1) Then
                  Bil1 = "se"
              Else
                  Bil1 = "satu "
              End If
          ElseIf (z = 2 Or z = 5 Or z = 8 Or z = 11 Or z = 14) Then
              X = X + 1
              strTot = Mid(strJmlHuruf, X, 1)
              z = Len(strJmlHuruf) - X + 1
              Bil2 = ""
              Select Case Val(strTot)
              Case 0
                  Bil1 = "sepuluh "
              Case 1
                  Bil1 = "sebelas "
              Case 2
                  Bil1 = "dua belas "
              Case 3
                  Bil1 = "tiga belas "
              Case 4
                  Bil1 = "empat belas "
              Case 5
                  Bil1 = "lima belas "
              Case 6
                  Bil1 = "enam belas "
              Case 7
                  Bil1 = "tujuh belas "
              Case 8
                  Bil1 = "delapan belas "
              Case 9
                  Bil1 = "sembilan belas "
              End Select
          Else
              Bil1 = "se"
          End If
      
      Case 2
          Bil1 = "dua "
      Case 3
          Bil1 = "tiga "
      Case 4
          Bil1 = "empat "
      Case 5
          Bil1 = "lima "
      Case 6
          Bil1 = "enam "
      Case 7
          Bil1 = "tujuh "
      Case 8
          Bil1 = "delapan "
      Case 9
          Bil1 = "sembilan "
      Case Else
          Bil1 = ""
      End Select
       
      If (Val(strTot) > 0) Then
         If (z = 2 Or z = 5 Or z = 8 Or z = 11 Or z = 14) Then
            Bil2 = "puluh "
         ElseIf (z = 3 Or z = 6 Or z = 9 Or z = 12 Or z = 15) Then
            Bil2 = "ratus "
         Else
            Bil2 = ""
         End If
      Else
         Bil2 = ""
      End If
      If (Y > 0) Then
          Select Case z
          Case 4
              Bil2 = Bil2 + "ribu "
              Y = 0
          Case 7
              Bil2 = Bil2 + "juta "
              Y = 0
          Case 10
              Bil2 = Bil2 + "milyar "
              Y = 0
          Case 13
              Bil2 = Bil2 + "trilyun "
              Y = 0
          End Select
      End If
      Urai = Urai + Bil1 + Bil2
  Wend
  KonversiBilangan = Urai
End Function

Private Sub Text1_Change()  'Isi besar nilai angka diulangi 'dengan terbilang huruf...
   Text2.Text = TerbilangDesimal(Text1.Text)
End Sub

Run the project (press F5) and try to enter some number of values into the first textbox, then the second textbox will generate a sentence counted from the number of numbers you enter.

Good luck.

Be My Friend On Facebook

Create Initial Word into a Capitalized Letters In Visual Basic 6.0

for this post we will discuss a function that can change every initial letter on a word into uppercase or capslock.

Open a new project (Standard.Exe), in Form1 add a textbox and set the Height and Width property of a rather large size make sure your Multiline property is set to True, so that its textbox can be widened down, and let the Name property match its default name .

Now let's move to editor mode, click View -> Code, and enter the following code :

Public Function AwalKataKapital(strKalimat As String)
Dim i As Integer
Dim Temp As String
Dim Lokasi As Integer
Dim huruf As String * 1
  Temp$ = ""
  For i% = 1 To Len(strKalimat)
    huruf = Chr(Asc(Mid(strKalimat, i%, 1)))
    If Len(Trim(huruf)) < 1 Then
      Lokasi% = i% + 1
    End If
    If i% = Lokasi% Or i% = 1 Then
       Temp$ = Temp$ + UCase(Chr(Asc(Mid(strKalimat, _
               i%, 1))))
    Else
       Temp$ = Temp$ + LCase(Chr(Asc(Mid(strKalimat, _
                i%, 1))))
    End If
  Next i
  AwalKataKapital = Temp$
End Function

Private Sub Text1_Change()
  Dim posisi As Integer
  posisi = Text1.SelStart
  Text1.Text = AwalKataKapital(Text1.Text)
  Text1.SelStart = posisi
End Sub

Press F5 to run the project, you try to type some words in the textbox we have provided, then every letter of the beginning of the word will automatically turn into capital letters.

Good luck.

Be My Friend On Facebook

Remove a Title Bar or None BorderStyle On MDI Form

Sometime we want to manipulate the entire screen appearance, without having to be limited by the title bar or status bar, if that's what you want, refer to the following reviews

On the reguler form this is very easy to do, we only have to set the property BorderStyle = 0 - None, but to remove Title Bar on MDI Form we need to call some API function.

Add an MDI Form to the project via Project -> Add MDI Form, and a Module from the menu Project -> Add Module

Double klik Module1, and type in the following code :

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_STYLE = (-16)
Private Const WS_BORDER = &H800000
Private Const WS_CAPTION = &HC00000

Public Sub MDINoBorder(ByRef nFormHWND As Long)
Dim sHandle As Long
On Error GoTo errMDINoBorder

sHandle = GetWindowLong(nFormHWND, GWL_STYLE)
sHandle = sHandle And Not WS_CAPTION
SetWindowLong nFormHWND, GWL_STYLE, sHandle

Exit Sub

errMDINoBorder:
  MsgBox "[" & Err.Number & "] - " & Err.Description, _
  vbExclamation, "MDI No Border Error"
End Sub

And then double click the MDIForm1, and type in the following code :

Private Sub MDIForm_Activate()
  MDINoBorder Me.hwnd
End Sub

Run the project by pressing the F5 key, and see the result now MDIForm on your project does not have a Title Bar.

Good luck.

Be My Friend On Facebook

Handling Files and Directories In Visual Basic 6.0

Sometimes we need to interact with files and directories that exist on the hard drive, for example if we want to export existing data into MS. Excel files, or maybe you want can to restore its database from backup results that have been made before

Here are some examples of code that can handle file and directory issues

T&T#1) CHECK FILE PROPERTIES

Open the new Standard.Exe project, place 1 CommandButton and change its caption to Properties, double click commandbutton and insert the following code:

Private Sub Command1_Click()
  'Ganti 'c:\autoexec.bat' dengan nama file yang Anda
  'ingin lihat kotak dialog property-nya...
  Call ShowProps("c:\autoexec.bat", Me.hwnd)
End Sub

Public Sub ShowProps(FileName As String, OwnerhWnd _
As Long)
Dim SEI As SHELLEXECUTEINFO
Dim r As Long
With SEI
  .cbSize = Len(SEI)
  .fMask = SEE_MASK_NOCLOSEPROCESS Or _
  SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
  .hwnd = OwnerhWnd
  .lpVerb = "properties"
  .lpFile = FileName
  .lpParameters = vbNullChar
  .lpDirectory = vbNullChar
  .nShow = 0
  .hInstApp = 0
  .lpIDList = 0
End With
r = ShellExecuteEX(SEI)
End Sub

Click Project -> Add Module, double click module1 and enter the following code :

Type SHELLEXECUTEINFO
  cbSize As Long
  fMask As Long
  hwnd As Long
  lpVerb As String
  lpFile As String
  lpParameters As String
  lpDirectory As String
  nShow As Long
  hInstApp As Long
  lpIDList As Long
  lpClass As String
  hkeyClass As Long
  dwHotKey As Long
  hIcon As Long
  hProcess As Long
End Type

Public Const SEE_MASK_INVOKEIDLIST = &HC
Public Const SEE_MASK_NOCLOSEPROCESS = &H40
Public Const SEE_MASK_FLAG_NO_UI = &H400
Declare Function ShellExecuteEX Lib "shell32.dll" Alias _
"ShellExecuteEx" (SEI As SHELLEXECUTEINFO) As Long

Press F5 and run the project

Click the Properties button, it will display the properties of the autoexec.bat file that we use as an example

T&T#2) CREATE EXCEL FILE

Open the new Standard.Exe project, insert 1 CommandButton into the form, double click commandbutton and enter the following code:

Private Sub Command1_Click()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet

Set xlApp = New Excel.Application
Set xlWB = xlApp.Workbooks.Add
Set xlWS = xlWB.Worksheets.Add

'this line will fill cell (2,2) with
'text "hello" and fill cell (1,3) with
'text "World"

xlWS.Cells(2, 2).Value = "hello"
xlWS.Cells(1, 3).Value = "World"

'This line will save the spreadsheet into
'file "c:\mysheet.xls".

xlWS.SaveAs "c:\mysheet.xls"
xlApp.Quit

'free some memory...

Set xlWS = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
End Sub

Press F5 and run the project

T&T#3) OPEN THE DIALOGUE BOX “BROWSE FOR FOLDER”

Open the new Standard.Exe project, insert 1 CommandButton into the form, and change the caption to Browse, double click commandbutton, and enter the following code:

Private Sub Command1_Click()
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo

'Change the "Browse For Folders" dialogue title

szTitle = "This Is My Title"
With tBrowseInfo
  .hWndOwner = Me.hWnd
  .lpszTitle = lstrcat(szTitle, "")
  .ulFlags = BIF_RETURNONLYFSDIRS + _
  BIF_DONTGOBELOWDOMAIN
End With

lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer

'sBuffer var is the selected directory choose by user.

sBuffer = Left(sBuffer, InStr(sBuffer, _
vbNullChar) - 1)

MsgBox sBuffer
End If
End Sub

Last but not least click Project -> Add Module, double click Module1, and enter the following code:

Public Const BIF_RETURNONLYFSDIRS = 1
Public Const BIF_DONTGOBELOWDOMAIN = 2
Public Const MAX_PATH = 260
Declare Function SHBrowseForFolder Lib _
"shell32" (lpbi As BrowseInfo) As Long
Declare Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long
Declare Function lstrcat Lib "kernel32" _
Alias "lstrcatA" (ByVal lpString1 As String, ByVal _
lpString2 As String) As Long

Public Type BrowseInfo
   hWndOwner As Long
   pIDLRoot As Long
   pszDisplayName As Long
   lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

Press F5 and run the project

T&T#4) OPEN WINDOWS EXPLORER WITH SPECIFIC DIREKTORY

Open the new Standard.Exe project, insert 1 CommandButton into the form, double click commandbutton, and enter the following code:

Private Sub Command1_Click()
'specify the directory name that you will be open with Windows Explorer
   OpenExplorer ("C:\Program Files\")
End Sub

Public Sub OpenExplorer(Optional InitialDirectory As String)
     ShellExecute 0, "Explore", InitialDirectory, vbNullString, _
     vbNullString, SW_SHOWNORMAL
End Sub

Click Project -> Add Module, double klik Module1, and enter the following code :

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 Const SW_SHOWNORMAL = 1

Press F5 and run the project

T&T#5) CHECK IF DIRECTORY EXIST

Open the new Standard.Exe project, double click Form1 and enter the following code:
'The example of the checked directory is "C: \ Windows"

Private Sub Form_Load()
Const ATTR_DIRECTORY = 16
If Dir$("c:\windows", ATTR_DIRECTORY) <> "" Then
MsgBox "Direktori ada!", vbInformation, "Ada"
Else MsgBox "Directory does not exist!", vbCritical, "Not Found" 
End If 
End Sub 

Press F5 and run the project

T&T#6) CHECK IF FILE EXIST

Open the new Standard.Exe project, double click Form1 and enter the following code:

'Example file"C:\autoexec.bat"
Private Sub Form_Load()
'Change "c:\autoexec.bat" with the complete file name (include the path)

If Dir$("c:\autoexec.bat") <> "" Then
   MsgBox "File Exist!", vbInformation, "Exist"
Else
   MsgBox "File Not Found!", vbCritical, "Not Found"
End If
End Sub

Press F5 and run the project

T&T#7) MOVING FILE

Open the new Standard.Exe project, insert 1 CommandButton into the form, double click commandbutton, and enter the following code:

'this will move file 'c:\MyFile.Zip' to 'direktori 'c:\MyDir'.
Private Sub Command1_Click()
A = MoveFile("c:\MyFile.Zip", "c:\MyDir\MyFile.Zip")
If A Then
       MsgBox "File successfully move!", _
              vbInformation, "Sukses Pindah File"
Else
       MsgBox "Error. Can not move file!" & Chr(13) & _
              "Maybe file does not exist" & _
              Chr(13) & "or file already exist in " & _
              Chr(13) & _
              "destination folder!", vbCritical, "Error: Moving File"
End If
End Sub

Click Project -> Add Module, double click Module1, and enter the following code :

Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" _ 
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String) _
As Long

Press F5 and run the project

T&T#8) GET FILE NAME

Open the new Standard.Exe project, double click Form1 and enter the following code:

Private Sub Form_Load()
   MsgBox StripPath("c:\myfolder\myfile.exe") 
End Sub

Function StripPath(T$) As String
Dim x%, ct%
StripPath$ = T$
x% = InStr(T$, "\")
Do While x%
  ct% = x%
  x% = InStr(ct% + 1, T$, "\")
Loop
If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function

Press F5 and run the project

T&T#9) GET FILE EXTENSION

Open the new Standard.Exe project, double click Form1 and enter the following code:

Private Sub Form_Load()
    MsgBox GetExtension("c:\myfolder\myfile.exe")
End Sub

Function GetExtension(FileName As String)
    Dim PthPos, ExtPos As Integer
    For i = Len(FileName) To 1 Step -1
        If Mid(FileName, i, 1) = "." Then
            ExtPos = i
            For j = Len(FileName) To 1 Step -1
                If Mid(FileName, j, 1) = "\" Then
                    PthPos = j
                    Exit For
                End If
            Next j
            Exit For
        End If
    Next i
    If PthPos > ExtPos Then
        Exit Function
    Else
        If ExtPos = 0 Then Exit Function
        GetExtension = Mid(FileName, ExtPos + 1, _
                       Len(FileName) - ExtPos)
    End If
End Function

Press F5 and run the project

T&T#10) GET DIRECTORY SIZE

Open the new Standard.Exe project, insert 1 CommandButton into the form, double click commandbutton, and enter the following code:

Private Sub Command1_Click()
  MsgBox "Directory Size C:\Windows = " & _
  Format(SizeOf("C:\Windows"), "#,#") & _
  " bytes", vbInformation, "Directory Size"
End Sub

Public Function SizeOf(ByVal DirPath As String) As Double
Dim hFind As Long
Dim fdata As WIN32_FIND_DATA
Dim dblSize As Double
Dim sName As String
Dim x As Long
On Error Resume Next
  x = GetAttr(DirPath)
  If Err Then SizeOf = 0: Exit Function
  If (x And vbDirectory) = vbDirectory Then
     dblSize = 0
     Err.Clear
     sName = Dir$(EndSlash(DirPath) & "*.*", vbSystem _
            Or vbHidden Or vbDirectory)
     If Err.Number = 0 Then
        hFind = FindFirstFile(EndSlash(DirPath) & _
                "*.*", fdata)
       If hFind = 0 Then Exit Function
        Do
        If (fdata.dwFileAttributes And vbDirectory) = _
           vbDirectory Then
           sName = Left$(fdata.cFileName, _
                InStr(fdata.cFileName, vbNullChar) - 1)
           If sName <> "." And sName <> ".." Then
              dblSize = dblSize + _
                      SizeOf(EndSlash(DirPath) & sName)
            End If
          Else
            dblSize = dblSize + fdata.nFileSizeHigh * _
                      65536 + fdata.nFileSizeLow
          End If
          DoEvents
        Loop While FindNextFile(hFind, fdata) <> 0
        hFind = FindClose(hFind)
     End If
  Else
     On Error Resume Next
     dblSize = FileLen(DirPath)
  End If
  SizeOf = dblSize
End Function

Private Function EndSlash(ByVal PathIn As String) As String
  If Right$(PathIn, 1) = "\" Then
     EndSlash = PathIn
  Else
     EndSlash = PathIn & "\"
  End If
End Function

Click Project -> Add Module, double klik Module1 and enter the following code :

Public Const MAX_PATH = 260
Public Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Public Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * MAX_PATH
  cAlternate As String * 14
End Type

Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" (ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
  
Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" (ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
  
Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long

Press F5 and run the project

T&T#11) DELETE FILE TO RECYCLE BIN

Open the new Standard.Exe project, insert 1 CommandButton into the form, double click commandbutton, and enter the following code:

Private Sub Command1_Click()
Dim MyBool As Boolean
  DelToRecycBin ("c:\My Documents\MyFile.Zip")
End Sub

Public Function DelToRecycBin(FileName As String)
Dim FileOperation As SHFILEOPSTRUCT
Dim lReturn As Long
On Error GoTo DelToRecycBin_Err
  With FileOperation
     .wFunc = F0_DELETE
     .pFrom = FileName
     .fFlags = F0F_ALLOWUNDO + F0F_CREATEPROGRESSDLG
  End With
  lReturn = SHFileOperation(FileOperation)
  Exit Function
DelToRecycBin_Err:
  MsgBox Err.Number & Err.Description
End Function

Click Project -> Add Module, double klik Module1, and enter the following code :

'Depend on your windows setting if you disable delete to recycle bin
'file akan will be deleted permanently

Public Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
Declare Function SHFileOperation Lib "shell32.dll" _
Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Public Const F0_DELETE = &H3
Public Const F0F_ALLOWUNDO = &H40
Public Const F0F_CREATEPROGRESSDLG As Long = &H0

Press F5 and run the project

Good luck.

Be My Friend On Facebook

Handling TextBox In Visual Basic 6.0

TextBox is one of the most important components in the visual-based programming environment, because this component will accept the data input from the user, the lack of attention to this component will be very fatal, ranging from Runtime Error to Invalid data and others.

Here are some tips and tricks in handling textbox :

T&T#1) ONLY ACCPET NUMERIC VALUE

For the demo please open a new project, select standard exe, then place a textbox for experiment material and set with the following properties:

Name : Text1
Text : (clear)

Then press F7 to switch to view code mode, or through the View -> Code menu, then type in the following code :

Private Sub Text1_KeyPress(KeyAscii As Integer)
    If Not (KeyAscii >= Asc("0") & Chr(13) _
    And KeyAscii <= Asc("9") & Chr(13) _
        Or KeyAscii = vbKeyBack _
        Or KeyAscii = vbKeyDelete _
        Or KeyAscii = vbKeySpace) Then
            Beep
            KeyAscii = 0
   End If
End Sub 

Press F5, and see the result

Based on the above code then the data that we entry into the textbox only receive numerical data, and some other key like BackSpace, Delete and Space.

T&T#2) ONLY ACCPET UPPER CASE ENTRY INTO THE TEXTBOX
Open the new project Standard Exe, then place 2 pieces of textbox with the following properties :
Name : Text1
Text : (empty)

Name : Text2
Text : (empty)

Press F7, or select View -> Code, then type the following code :

Private Sub Text1_Change()
'Text1 menggunakan event Change
Dim posisi As Integer
    posisi = Text1.SelStart
    Text1.Text = UCase(Text1.Text)
    Text1.SelStart = posisi
End Sub

Private Sub Text2_KeyPress(KeyAscii As Integer)
'Text2 menggunakan event KeyPress
    KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub 

Press F5 and see the result

T&T#3) ONLY ACCEPT LOWER CASE ENTRY INTO THE TEXTBOX
Open the new project Standard Exe, then place 2  textbox with the following properties :
Name : Text1
Text : (empty)

Name : Text2
Text : (empty)

Press F7, or select View -> Code, then type the following code :

Private Sub Text1_Change()
'Text1 use event Change
    Dim posisi As Integer
    posisi = Text1.SelStart
    Text1.Text = LCase(Text1.Text)
    Text1.SelStart = posisi
End Sub

Private Sub Text2_KeyPress(KeyAscii As Integer)
'Text2 use KeyPress
    KeyAscii = Asc(LCase(Chr(KeyAscii)))
End Sub 

Press F5 and see the result

T&T#4) CLEAR ALL TEXTBOX VALUE
Open a new project and place 4 textbox, and 1 commanbutton, let the default property settings do not need to change name or any other properties.

Press F7, and type in the following code :

Private Sub Command1_Click()
    Dim Contrl As Control
    For Each Contrl In Form1.Controls
        If (TypeOf Contrl Is TextBox) Then Contrl.Text = ""
    Next Contrl
End Sub 

Press F5 and see the result

T&T#5) AVOID CERTAIN CHARACTER ENTRY
Open the new Standard Exe project, then place a textbox and leave the default name 'Text1', then press F7 and type the following code :

Private Sub Text1_KeyPress(KeyAscii As Integer)
    Dim sTemplate As String
    'Ganti '!@#$%^&*()_+=' dengan karakter yang Anda
    'inginkan untuk dihindari diinput pada Text1
    sTemplate = "!@#$%^&*()_+="
    If InStr(1, sTemplate, Chr(KeyAscii)) > 0 Then _
    KeyAscii = 0
End Sub 

Note the code above, each data that we input in the textbox will be accepted except the characters contained in the sTemplate variable

Press F5 and see the result


T&T#6) CALCULATING THE WORD IN TEXTBOX
Open the new Standard Exe project, and place 1 textbox and 1 commandbutton, and set it with the following properties :

TextBox
Name : Text1
Text : (empty)

CommandButton
Name : cmdCount
Caption : &Count

Press F7 and type in the following code :

Private Sub cmdCount_Click()
    'Type a few sentences long enough
    'thus containing up to tens or even hundreds
    'words to try the word count function below.
    MsgBox GetWordCount(Text1.Text)
End Sub

Public Function GetWordCount(ByVal Text As String) As Long
'Define a hyphen at each end
'lines that are part of the whole word,
'so combine together.
    Text = Trim(Replace(Text, "-" & vbNewLine, ""))
    'Replace a new row with a single space
    Text = Trim(Replace(Text, vbNewLine, " "))
    'Replace a space more than one (if any)
    'into a single space
    Do While Text Like "*  *"
        Text = Replace(Text, "  ", " ")
    Loop
    'Separate the string and return the calculated word
    GetWordCount = 1 + UBound(Split(Text, " "))
End Function 

Press F5 and see the result

T&T#7) POP UP MENU IN TEXTBOX
Open the new Standard Standard project, and place 1 textbox and name it Text1, and make a menubar, you can specify what is inside the menubar, note the illustration below

Press F7 and type in the following code :

Private Const WM_RBUTTONDOWN = &H204
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
Public Sub OpenContextMenu(FormName As Form, menuName As Menu)
  Call SendMessage(FormName.hwnd, WM_RBUTTONDOWN, 0, 0&)
  FormName.PopupMenu menuName
End Sub

Private Sub Form_Load()
  MyMenu.Visible = False  'To be invisible at the top of the form
End Sub

Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
  'Replace 'MyMenu' with the menu you want to appear as pop up.
If Button = vbRightButton Then _
    Call OpenContextMenu(Me, Me.MyMenu)
End Sub

Press F5 and see the result
Right click on the textbox and a pop up menu will appear


T&T#8) HIGHLIGHT ALL CHARACTERS IN TEXTBOX
Open the new Standard Exe project, then place a textbox and set its properties as follows :
Name : Text1
Text : http://ilmalyakin.blogspot.com

Press F7 and type in the following code :

Private Sub Text1_GotFocus()
  Text1.SelStart = 0
  Text1.SelLength = Len(Text1)
End Sub

Press F5 and see the result


T&T#9) TEXTBOX VALIDATION
Open the new Standard Uns project, then place 2 textbox and 1 commandbutton, and set it with the following properties :

TextBox
Name : Text1
Text : (empty)

Name : Text2
Text : (empty)

CommandButton
Name : cmdExit
Caption : &Exit

Press F7 and type in the following code :

Private Sub cmdExit_Click()
    End
End Sub

Private Sub Text1_Validate(Cancel As Boolean)
    Cancel = Text1.Text <> "abc"
End Sub

Press F5 an see the result

In this example, the cursor will not be able to exit the textbox until the user types "abc".

That's it, some of the common task in TextBox

Good luck.

Create Your Own ActiveX Control With Visual Basic 6

This time I try to share one of the examples of activex control project is quite simple that is making a timepiece, well without any longer let's start

Open the new project with ActiveX Control project type, different from the usual project that is displayed is not the form but the user controls, change the name of the project into MyWatch, then change its user controls to Watch, BorderStyle becomes 0 - None

Then insert a label into the form and set its property to:
Name: lblJam
Appearance: 0 - Flat
Autosize: True
BackColor: & H00E0E0E0 &
BorderStyle: 1 - Fixed Single
Caption: 00:00:00
Font: Ms Sans Serif
Font Style: Bold

The next step we enter a Timer, then set its properties
Name : tmrJam
Interval : 1000

Then move the label that we made to the top left corner of the form, then minimize the size of the form of the label we created earlier

Well until here we save the first project that we created, for the user controls give the name MyWatch.ctl file, for his project give the name MyWatch.vbp

After the design interface is complete, when it is to add code into the project, double click on user controls add the following code:

Private Sub UserControl_Initialize()
    lblJam.Caption = Time
    tmrJam.Enabled = True
End Sub

The Initialize sub procedure will be loaded first when the component is first loaded on the form, then add the following code:

Private Sub tmrJam_Timer()
Dim jam
    jam = Time()
    lblJam.Caption = jam
End Sub 

The above procedure will be called when the component is dragged or slid on the form, to specify the font to use, we use the SET function and to read the value we use the GET function, add the following code:

Public Property Set Font(ByVal NewFont As Font)
    Set lblJam.Font = NewFont
    PropertyChanged "Font"
End Property

Public Property Get Font() As Font
    Set Font = lblJam.Font
End Property 

we know each activex control that we have drag into a form then each control will have property value, with SET procedure we can specify some value that we will change in its properties, while the GET procedure later that will take value on the properties and will be applied when an activex control is dragged or slid into a form

Then we add an Event that will be triggered in the event of a change in the activex control

Make sure your cursor is in position (General) (Declaration),

Then type the following code:

Public Event change() 

This event we need to detect if there is a change in the activex control that will run a procedure we named SetTime (), type the following code:

Private Sub SetTime(ByVal waktu As String)
    lblJam.Caption = waktu
    RaiseEvent change
End Sub 

This procedure will trigger Event change () to run, which will parse a time variable and adjust it to the clock label

To read changes to global properties for fonts, we read through ReadProperties on the UserControl object, in this section the global properties will be read

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    lblJam.Font = PropBag.ReadProperty("Font", Ambient.Font)
    lblJam.FontBold = PropBag.ReadProperty("FontBold", _
                      Ambient.Font.Bold)
    lblJam.FontSize = PropBag.ReadProperty("FontSize", _
                      Ambient.Font.Size)
End Sub 

To write the changes that occur on the global property for the font, we do through WriteProperties on the UserControl object

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Font", lblJam.Font, Ambient.Font)
    Call PropBag.WriteProperty("FontBold", lblJam.FontBold, _
         Ambient.Font.Bold)
    Call PropBag.WriteProperty("FontSize", lblJam.FontSize, _
         Ambient.Font.Size)
End Sub 

Procedure is what will make some property values into one unity or become part of the activex itself

Now it is almost finished, now we can save the project, then try to run the project press F5, and see the results that will be opened on the browser that we use

The next step is to compile the project we have created, click the File menu and select Make MyWatch.ocx, then specify the location of the folder where the ocx we will put it, then click the Ok button, now activex control we have successfully created

Now it's time we add the new activex control we created into our application project, open one of your projects, or create a new Standard.exe app, right click on Toolbox, select Components ..., after show click browse button, then search ocx file that we have created "MyWatch.ocx", then click Open, now in the Toolbox there will be a new component that is MyWatch, try to add to the form, the initial view of the ocx is the current time.