Working with the Word Object Library

The word object library is present in the references window and should be included to implement word document applications. The code below describes 3 examples. The first example creates a word document and inserts letters, paragraphs ans sets font sizes to them. The second example inserts text and checks spelling of the inserted text. The third example creates a word document in a given file location and inserts text in it.
Public obWrd As Word.Application
Private Sub Form_Load()
Dim obDc As Word.Document
Set obWrd = New Word.Application
obWrd.Visible = True
Set obDc = objWord.Documents.Add
objDc.Activate
obDc.ActiveWindow.Selection.InsertAfter "The Real Text"
obDc.ActiveWindow.Selection.InsertParagraphAfter
obDc.ActiveWindow.Selection.InsertAfter "The Big Text"
obDc.ActiveWindow.Selection.InsertParagraphAfter
obDc.ActiveWindow.Selection.Font.Bold = True
obDc.ActiveWindow.Selection.EndOf
obWrd.Quit False
Set obWrd = Nothing
End Sub

Public objword1 As Word.Application
Private Sub Form_Load()
Dim objDoc1 As Word.Document
Set objWord = New Word.Application
objword1.Visible = True
Set objDoc = objWord.Documents.Add
objDoc1.Activate
objDoc1.ActiveWindow.Selection.InsertAfter ("The Text")
On Error Resume Next
objDoc1.CheckSpelling
If Err Then
MsgBox Err.Description & Err.Number
End If
End Sub
Private Sub Form_Load()
Dim objWord As Object
Set objWord = CreateObject("Word.Basic")
objWord.filenew
objWord.startofdocument
objWord.FontSize 24
objWord.Insert "Big Letter Text"
objWord.FontSize 12
objWord.insertpara
objWord.Insert "Text with Smaller Font"
objWord.filesaveas "D:\test.doc"
'objWord.Close
Set objWord = Nothing
End Sub

The SysInfo Control

The following example uses a sysInfo control on a form and displays the properties of the system in a listbox.
Private Sub Form_Load()
On Error Resume Next
MsgBox "Sysinfo1.Index: " & SysInfo1.Index
If Err Then
MsgBox "" & Err.Description & Err.Number
End If
List1.AddItem "SysInfo1.OSBuild: " & SysInfo1.OSBuild
List1.AddItem "SysInfo1.BatteryFullTime: " & SysInfo1.BatteryFullTime
List1.AddItem "SysInfo1.ACStatus: " & SysInfo1.ACStatus
List1.AddItem "SysInfo1.BatteryLifePercent: " & SysInfo1.BatteryLifePercent
List1.AddItem "SysInfo1.BatteryLifeTime: " & SysInfo1.BatteryLifeTime
List1.AddItem "SysInfo1.BatteryStatus: " & SysInfo1.BatteryStatus
List1.AddItem "SysInfo1.Name: " & SysInfo1.Name
List1.AddItem "SysInfo1.Object: " & SysInfo1.Object
List1.AddItem "SysInfo1.OSPlatform: " & SysInfo1.OSPlatform
List1.AddItem "Sysinfo1.OSVersion: " & SysInfo1.OSVersion
List1.AddItem "Sysinfo1.Parent: " & SysInfo1.Parent
List1.AddItem "Sysinfo1.scrollbarsize: " & SysInfo1.ScrollBarSize
End Sub

The Beep and Arc Functions

The Beep produces a low frequency beep or system sound for a given number of milliseconds. An arc function prints an arc on the form.

Private Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Sub Form_Activate()
        Dim Cnt As Long
    For Cnt = 0 To 5000 Step 10
        'play a tone of 'Cnt' hertz, for 50 milliseconds
        Beep Cnt, 50
        Me.Caption = Cnt
        DoEvents
    Next Cnt
End Sub

Private Declare Function Arc Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
Private Sub Form_Load()
    'Set graphical mode to persistent
    Me.AutoRedraw = True
    'Draw to arcs
    Arc Me.hdc, 0, 0, 100, 100, 100, 50, 50, 100
    Arc Me.hdc, 49, 49, 149, 149, 49, 99, 99, 49
End Sub

The FlashWindow, GetsystemDirectory and GetSystemInfo Api Call

The FlashWindow function flashes a window to a user. The GetSystemDirecoty prints the present system directory and the GetSystemInfo function presents the system information to the user.
Private Declare Function FlashWindow Lib "user32" (ByVal hWnd As Long, ByVal bInvert As Long) As Long
Private Sub Timer1_Timer()
Dim nReturnValue As Long
nReturnValue = FlashWindow(Form1.hWnd, True)
End Sub

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Sub Form_Load()
    Dim sSave As String, Ret As Long
    'Create a buffer
    sSave = Space(255)
    'Get the system directory
    Ret = GetSystemDirectory(sSave, 255)
    'Remove all unnecessary chr$(0)'s
    sSave = Left$(sSave, Ret)
    'Show the windows directory
    MsgBox "Windows System directory: " + sSave
End Sub

Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Private Type SYSTEM_INFO
    dwOemID As Long
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOrfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    dwReserved As Long
End Type
Private Sub Form_Load()
    Dim SInfo As SYSTEM_INFO
    'Set the graphical mode to persistent
    Me.AutoRedraw = True
    'Get the system information
    GetSystemInfo SInfo
    'Print it to the form
    Me.Print "Number of procesor:" + Str$(SInfo.dwNumberOrfProcessors)
    Me.Print "Processor:" + Str$(SInfo.dwProcessorType)
    Me.Print "Low memory address:" + Str$(SInfo.lpMinimumApplicationAddress)
    Me.Print "High memory address:" + Str$(SInfo.lpMaximumApplicationAddress)
End Sub


 

Creating a Window Using the Windows API

The Windows API is used to create windows for forms in Visual Basic. These forms have properties such as title, custom text and other features such as forecolor and backcolor. Users can create and destroy windows on forms. API functions are declared before being used or implemented. You must declare functions as private to use on forms.
Const WS_EX_STATICEDGE = &H20000
Const WS_EX_TRANSPARENT = &H20&
Const WS_CHILD = &H40000000
Const CW_USEDEFAULT = &H80000000
Const SW_NORMAL = 1
Private Type CREATESTRUCT
    lpCreateParams As Long
    hInstance As Long
    hMenu As Long
    hWndParent As Long
    cy As Long
    cx As Long
    y As Long
    x As Long
    style As Long
    lpszName As String
    lpszClass As String
    ExStyle As Long
End Type
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Dim mWnd As Long
Private Sub Form_Load()
    Dim CS As CREATESTRUCT
    'Create a new label
    mWnd = CreateWindowEx(WS_EX_STATICEDGE Or WS_EX_TRANSPARENT, "STATIC", "Hello World !", WS_CHILD, 0, 0, 300, 50, Me.hwnd, 0, App.hInstance, CS)
    Me.Caption = mWnd
    'Show our label
    ShowWindow mWnd, SW_NORMAL
End Sub
Private Sub Form_Unload(Cancel As Integer)
    'destroy our label
    DestroyWindow mWnd
End Sub

Working with String Objects

The string object has several functions that are able to reverse a string-strreverse(), compare a string strcomp(), extract characters from a string-Left(), mid(), right(), UCase(), Lcase() and InStr().
The mid(string, start of string to extract, number of characters) function is used to extract a string inside a given string.
The Left(string, start of string, number of characters) is used to extract charcters from the left portion of a string. The Mid$() functions return a string value compared the Mid() functions returning a variant.
Private Sub Form_Load()
Dim str As String
Dim i As Integer
str = "stringring"
str1 = "ring"
'MsgBox UCase(str)
'MsgBox LCase(str)
'i = InStr(str, str1)
i = InStrRev(str, str1)
'str = Mid(str, 2, 5)
'str = Left(str, 4)
'str = Right(str, 4)
'MsgBox " " & Mid$(str, 2, 5) & vbCrLf & Left(str, 4)
'MsgBox Left(str, 1)
'MsgBox Mid(str1, 3, 1)
End Sub

Using the Treeview Control

Private Sub Form_Load()
Dim tempnode As Node
Set tempnode = TreeView1.Nodes.Add(, , "mykey", "Health")
tempnode.Image = 1
tempnode.SelectedImage = 1
tempnode.ExpandedImage = 1
Set tempnode = TreeView1.Nodes.Add("mykey", tvwChild, "E", "East Division")
Set tempnode = TreeView1.Nodes.Add("E", tvwChild, "B", "Big")
Set tempnode = TreeView1.Nodes.Add("E", tvwChild, "s", "Small")
Set tempnode = TreeView1.Nodes.Add("E", tvwChild, "St", "Strong")
Set tempnode = TreeView1.Nodes.Add("E", tvwChild, "Ta", "Tall")
Set tempnode = TreeView1.Nodes.Add("E", tvwChild, "ft", "Fit")
Set tempnode = TreeView1.Nodes.Add("mykey", tvwChild, "C", "Central Division")
Set tempnode = TreeView1.Nodes.Add("mykey", tvwChild, "W", "West Division")
tempnode.EnsureVisible
End Sub

Building a Listview Control

A Listview uses an imagelist to create groups and assign numbers to them as per list criterias. Columnheaders are created and listitems and list subitems are added to them.

ListView1.Icons = ImageList1
ListView1.SmallIcons = ImageList2
ListView1.ColumnHeaderIcons = ImageList3
Dim clmx As ColumnHeader
Set clmx = ListView1.ColumnHeaders.Add(, , " EL Magazine Member Groups", , , 1)
Set clmx = ListView1.ColumnHeaders.Add(, , "Free", , , 2)
Set clmx = ListView1.ColumnHeaders.Add(, , "Subscription", , , 3)
Dim itmx1 As ListItem
Dim itmx2 As ListItem
Dim itmx3 As ListItem
Set itmx1 = ListView1.ListItems.Add(, "NR", "North", 1, 1)
itmx1.Selected = False
ListView1.ListItems.Item(ListView1.ListItems.Count).ListSubItems.Add , , "14", 0
ListView1.ListItems.Item(ListView1.ListItems.Count).ListSubItems.Add , , "25", 0
Set itmx2 = ListView1.ListItems.Add(, , "East", 1, 1)
ListView1.ListItems.Item(ListView1.ListItems.Count).ListSubItems.Add , , "04", 0
ListView1.ListItems.Item(ListView1.ListItems.Count).ListSubItems.Add , , "28", 0
Set itmx3 = ListView1.ListItems.Add(, , "West", 1, 1)
ListView1.ListItems.Item(ListView1.ListItems.Count).ListSubItems.Add , , "12", 0
ListView1.ListItems.Item(ListView1.ListItems.Count).ListSubItems.Add , , "15", 0
     
ListView1.View = lvwReport
End Sub

The File List Box User Control

The File List Box user control combines a file list, a drive list and a directory list to display the file name in a text box.
Private Sub File1_Click()
Dim FileName As String
FileName = File1.Path
If Right$(FileName, 1) <> "\" Then FileName = FileName & "\"
FileName = FileName & File1.FileName
Text1.Text = FileName
End Sub
Private Sub Drive1_Change()
 ' The Drive property also returns the volume label, so trim it.
 Dir1.Path = Left$(Drive1.Drive, 1) & ":\"
 End Sub

 Private Sub Dir1_Change()
 File1.Path = Dir1.Path
 End Sub

A User Control to Check Textbox data

A user control is used to check the data being entered in a text control for alphabet characters and throws an error when other characters are entered in it.

Private Sub Text1_LostFocus()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim str As String
str = Trim(Text1.Text)
k = 0
l = 0
For i = 1 To Len(str)
For j = 65 To 122
If Mid(str, i, 1) = Chr(j) Then
k = k + 1
End If
Next j
If Mid(str, i, 1) = Chr(32) Then
l = l + 1
End If
Next i
'MsgBox "K: " & k
'MsgBox Len(str)
'MsgBox str
k = k + l
If k < Len(str) Then
MsgBox "Please Enter Valid Characters"
End If
End Sub

A Form with a Status Bar, Progress Bar and an Error Object

A status bar can be used to display several form and user key stats such as caps lock, scroll lock, INS key and to display the system time. A timer object is used to create an auto increment for the time object to be placed in the status bar.
time1 = Time + Timer1.Interval
time1 = Format(time1, "HH:MM:SS")
StatusBar1.Panels(6).Text = time1
A progress bar uses an increment value in a timer object to display form load progress.
Private Sub Timer2_Timer()
If ProgressBar1.Value < 10 Then
ProgressBar1.Value = ProgressBar1.Value + 1
ElseIf ProgressBar1.Value = 10 Then
ProgressBar1.Value = 0
Timer2.Enabled = False
ProgressBar1.Visible = False
End If
The error object traps errors in the form for an animation object:
'On Error GoTo FileOpenError
On Error Resume Next
Animation1.Open ("c:\Users\PC\Desktop\photos\MVI_1230.avi")
Animation1.AutoPlay = True
If Err Then
MsgBox Err.Description & vbCrLf & Err.Number
End If
Timer1.Enabled = True
MsgBox "Total Message"
FileOpenError:
MsgBox "The Avi file is not ok. Please Try Another File"
Option Explicit
Dim time1 As Date
'Dim sbr1 As sbrTime
Private Sub Form_Load()
time1 = Format(Time, "HH:MM:SS")
'Text1.Text = sbr1
With StatusBar1
.Panels.Remove 1
.Panels.Add 1, "my key", "Form 6", sbrText
.Panels(1).AutoSize = sbrSpring
.Panels(1).Text = Form4.Caption
'sbrTime = time1
.Panels.Add , , , sbrCaps
.Panels.Add , , , sbrNum
.Panels.Add , , , sbrIns
.Panels.Add , , , sbrScrl
.Panels.Add 6
End With
'On Error GoTo FileOpenError
On Error Resume Next
Animation1.Open ("c:\Users\PC\Desktop\photos\MVI_1230.avi")
Animation1.AutoPlay = True
If Err Then
MsgBox Err.Description & vbCrLf & Err.Number
End If
Timer1.Enabled = True
MsgBox "Total Message"
FileOpenError:
MsgBox "The Avi file is not ok. Please Try Another File"
End Sub
Private Sub Timer1_Timer()
time1 = Time + Timer1.Interval
time1 = Format(time1, "HH:MM:SS")
StatusBar1.Panels(6).Text = time1
Text1.Text = Time + Timer1.Interval
'Text1.Text = Format(Text1.Text, "HH:MM:SS")
'Text1.Text = FormatDateTime(Text1.Text, vbGeneralDate)
'Text1.Text = Format(time, "HH:MM:SS")
End Sub
Private Sub Timer2_Timer()
If ProgressBar1.Value < 10 Then
ProgressBar1.Value = ProgressBar1.Value + 1
ElseIf ProgressBar1.Value = 10 Then
ProgressBar1.Value = 0
Timer2.Enabled = False
ProgressBar1.Visible = False
End If
End Sub

A Module Object for Automated Customer ID Generation

The Customer.bas module has a procedure named customer_ID_auto to generate automated customer ID numbers to be loaded into the customer form on form load. The call Customer_ID_auto() statement is used to invoke this method: Private Sub Form_Load()
Call customer_ID_auto
Text1.Text = str
End Sub
in the Form_Load sub procedure. The str string is public and hence the value is populated in the form text field on form load.
The Customer.bas module:
Option Explicit
Public str As String
Sub customer_ID_auto()
Dim rvalue As Integer
Dim upperbound As Integer
Dim lowerbound As Integer
Dim i As Integer
' Initialize the random-number generator.
Randomize
' Generate random value between 1 and 6.
upperbound = 65
lowerbound = 90
'rvalue = CInt(Int((upperbound - lowerbound + 1) * Rnd() + lowerbound))
str = "CMP"
For i = 1 To 8
rvalue = CInt(Int((upperbound - lowerbound + 1) * Rnd() + lowerbound))
str = str + Chr(rvalue)
Next i
'Form6.List1.AddItem str
End Sub

Creating a Customer Form using the Customer Class

The customer form shown on the left uses the customer class object given below to retrieve and update data in tables stored in a database.Option Explicit

Private Sub Command1_Click()
Dim clsCust As New clsCustomerOne
clsCust.CustomerID = Text1.Text
clsCust.CustomerName = Text2.Text
clsCust.CustomerAddress = Text3.Text
clsCust.CompanyName = Text4.Text
clsCust.CompanyAddress = Text5.Text
clsCust.PhoneNumberR = Text8.Text
clsCust.PhoneNumberM = Text9.Text
clsCust.RegistrationDate = Text6.Text
clsCust.RegistrationNumber = Text7.Text
clsCust.Customer_ID_Date = MonthView1.Value
clsCust.customer_update
End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
Call customer_ID_auto
Text1.Text = str
End Sub

Creating Classes for User Objects

The below program uses a class module to create a user object for customer databases. Customer information is stored in a user object that adds, update or deletes customer information from a database.
The customer_retrieve method retrieves or gets customer information using a ADO connection and the Customer_update method updates data in the tabels. The let and get methods updates the properties of the customer object.
Option Explicit
Private MCustomerID As String
Private MCustomerName As String
Private MPhoneNumberR As Long
Private MPhoneNumberM As Long
Private MCustomerAddress As String
Private MCustomer_ID_Date As Date
Private MCompanyName As String
Private MRegistrationNumber As Long
Private MRegistrationDate As Date
Private MCompanyAddress As String
Public Property Let CustomerID(ByVal cID As String)
MCustomerID = cID
End Property
Public Property Get CustomerID() As String
CustomerID = MCustomerID
End Property
Public Property Let CustomerName(ByVal CName As String)
MCustomerName = CName
End Property
Public Property Get CustomerName() As String
CustomerName = MCustomerName
End Property
Public Property Let PhoneNumberR(ByVal PR As Long)
MPhoneNumberR = PR
End Property
Public Property Get PhoneNumberR() As Long
'Dim PhoneNumberR As Long
PhoneNumberR = MPhoneNumberR
End Property
Public Property Let PhoneNumberM(ByVal PM As Long)
MPhoneNumberM = PM
End Property
Public Property Get PhoneNumberM() As Long
'Dim PhoneNumberM As Long
PhoneNumberM = MPhoneNumberM
End Property
Public Property Let CustomerAddress(ByVal CA As String)
MCustomerAddress = CA
End Property
Public Property Get CustomerAddress() As String
CustomerAddress = MCustomerAddress
End Property
Public Property Let Customer_ID_Date(ByVal CIDDate As Date)
MCustomer_ID_Date = CIDDate
End Property
Public Property Get Customer_ID_Date() As Date
Customer_ID_Date = MCustomer_ID_Date
End Property
Public Property Let CompanyName(ByVal CN As String)
MCompanyName = CN
End Property
Public Property Get CompanyName() As String
CompanyName = MCompanyName
End Property
Public Property Let RegistrationNumber(ByVal RN As Long)
MRegistrationNumber = RN
End Property
Public Property Get RegistrationNumber() As Long
'Dim RegistrationNumber As Long
RegistrationNumber = MRegistrationNumber
End Property
Public Property Let RegistrationDate(ByVal RD As Date)
MRegistrationDate = RD
End Property
Public Property Get RegistrationDate() As Date
RegistrationDate = MRegistrationDate
End Property
Public Property Let CompanyAddress(ByVal CAdd As String)
MCompanyAddress = CAdd
End Property
Public Property Get CompanyAddress() As String
CompanyAddress = MCompanyAddress
End Property
'Public Property Set Customer_Object(objOwner As clsCustomer)
'Set objCust = objOwner
'End Property
Public Sub customer_update()
Dim ado As ADODB.Connection
Dim rs As ADODB.Recordset
Set ado = New ADODB.Connection
ado.Open "DSN=cis_dsn"
Set rs = New ADODB.Recordset
rs.CursorType = adOpenKeyset
rs.LockType = adLockOptimistic
rs.Source = "customer"
rs.ActiveConnection = ado
rs.Open
rs.AddNew
rs.Fields("Customer ID") = MCustomerID
rs.Fields("Customer Name") = MCustomerName
rs.Fields("Customer Address") = MCustomerAddress
rs.Fields("Phone Number (R)") = MPhoneNumberR
rs.Fields("Phone Number (M)") = MPhoneNumberM
rs.Fields("Customer ID Date") = MCustomer_ID_Date
rs.Fields("Company Name") = MCompanyName
rs.Fields("Registration Number") = MRegistrationNumber
rs.Fields("Registration Date") = MRegistrationDate
rs.Fields("Company Address") = MCompanyAddress
rs.Update
rs.Close
ado.Close
Set rs = Nothing
End Sub
Public Function customer_retrieve(MCustID As String)
Dim myConnection As ADODB.Connection
Dim myRecordSet As ADODB.Recordset
Set myConnection = New ADODB.Connection
myConnection.Open "DSN=cis_dsn"
Set myRecordSet = New ADODB.Recordset
myRecordSet.CursorType = adOpenKeyset
myRecordSet.LockType = adLockOptimistic
myRecordSet.Source = "customer"
myRecordSet.ActiveConnection = myConnection
myRecordSet.Open ("Select * From Customer")
'Set myRecordSet = myConnection.Execute()
Do While Not myRecordSet.EOF
If myRecordSet.Fields(0) = MCustID Then
'MsgBox "" & myRecordSet.Fields(0)
CustomerID = myRecordSet.Fields("Customer ID")
CustomerName = myRecordSet.Fields("Customer Name")
CustomerAddress = myRecordSet.Fields("Customer Address")
PhoneNumberR = myRecordSet.Fields("Phone Number (R)")
PhoneNumberM = myRecordSet.Fields("Phone Number (M)")
Customer_ID_Date = myRecordSet.Fields("Customer ID Date")
CompanyName = myRecordSet.Fields("Company Name")
RegistrationNumber = myRecordSet.Fields("Registration Number")
RegistrationDate = myRecordSet.Fields("Registration Date")
CompanyAddress = myRecordSet.Fields("Company Address")
End If
myRecordSet.MoveNext
Loop
'myConnection.ConnectionString = "Provider=Microsoft.Jet.OLEDB.3.51;Data Source=D:\CIS\CIS.mdb"
' Create a Recordset by executing a SQL statement
' Show the first title in the recordset.
'MsgBox myRecordSet("Title")
' Close the recordset and connection.
myRecordSet.Close
myConnection.Close
Set myRecordSet = Nothing
End Function

Error Reporting

Error reporting is used to capture errors in programs. On Error GoTo FileError- This statement goes to a code label FileError
On Error Resume Next- This executes when an error occurs and the code flow jumps to the next immediate line
If Err Then
MsgBox Err.Description & vbCrLf & Err.Number
End If
Err is an error object and its methods and properties are used to display the error number and the error description.