Page History
...
Source Code ActiveX Example 3 - Visual Basic - Object
VERSION 5.00
Begin VB.Form Form1
Caption = "Case 3 - VB"
ClientHeight = 8325
ClientLeft = 60
ClientTop = 345
ClientWidth = 4650
LinkTopic = "Form1"
ScaleHeight = 8325
ScaleWidth = 4650
StartUpPosition = 3 'Windows Default
Begin MSComctlLib.ListView lvwemployees
Height = 3015
Left = 360
TabIndex = 15
Top = 840
Width = 3975
_ExtentX = 7011
_ExtentY = 5318
View = 3
LabelWrap = -1 'True
HideSelection = -1 'True
FullRowSelect = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin VB.ComboBox StatusMsgBox
BackColor = &H80000013&
Height = 315
Left = 120
Style = 2 'Dropdown List
TabIndex = 14
Top = 7920
Width = 4455
End
Begin VB.CommandButton cmdback
Caption = "Back"
Enabled = 0 'False
Height = 375
Left = 1080
Style = 1 'Graphical
TabIndex = 13
Top = 4080
Width = 1095
End
Begin VB.CommandButton cmdforward
Caption = "Forward"
Enabled = 0 'False
Height = 375
Left = 2520
Style = 1 'Graphical
...
TabIndex = 12
Top = 4080
Width = 1095
End
Begin VB.Frame frmEmployeeDetails
Caption = "Employee Details"
Height = 3015
Left = 360
TabIndex = 3
Top = 4680
Width = 3975
Begin VB.CommandButton cmdUpdate
Caption = "Update"
Enabled = 0 'False
Height = 375
Left = 1560
TabIndex = 11
Top = 2400
Width = 1095
End
Begin VB.TextBox uSalary
BeginProperty DataFormat
Type = 1
Format = "0.00"
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 3081
SubFormatType = 1
EndProperty
Height = 350
Left = 1560
MaxLength = 11
TabIndex = 7
Text = "Salary"
Top = 1800
Width = 1215
End
Begin VB.TextBox uGiveName
Height = 350
Left = 1560
TabIndex = 6
Text = "Give Name"
Top = 840
Width = 1815
End
Begin VB.TextBox uSurname
Height = 345
Left = 1560
TabIndex = 5
Text = "Surname"
Top = 1320
Width = 1815
End
Begin VB.TextBox uNumber
BackColor = &H80000013&
Enabled = 0 'False
Height = 350
Left = 1560
TabIndex = 4
TabStop = 0 'False
Top = 360
Width = 1215
End
Begin VB.Label lblSalary
Caption = "Salary:"
Height = 345
Left = 240
TabIndex = 10
Top = 1800
Width = 855
End
Begin VB.Label LblName
Caption = "Name:"
Height = 225
Left = 240
TabIndex = 9
Top = 840
Width = 855
End
Begin VB.Label lblnumber
Caption = "Number:"
Height = 375
Left = 240
TabIndex = 8
Top = 360
Width = 735
End
End
Begin VB.CommandButton cmdSearch
Caption = "Search"
Default = -1 'True
Height = 375
Left = 2880
TabIndex = 2
Top = 240
Width = 1215
End
Begin VB.TextBox uDepartment
Height = 350
Left = 1800
TabIndex = 1
Text = "ADM"
Top = 240
Width = 495
End
Begin VB.Label lblDepartment
Caption = "Department:"
Height = 350
Left = 480
TabIndex = 0
Top = 240
Width = 1215
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Source Code ActiveX Example 3 - Visual Basic - Code
Option Explicit
Public Session As LANSA_ACTIVEX_LIB.Session
Dim axobjecta As LANSA_AXOBJECTA_LIB.axobjecta
Dim axobjectb As LANSA_AXOBJECTB_LIB.axobjectb
Dim gbDirty As Boolean
Dim gbDepartment As String * 3
Dim lvwindex As Long
Private Sub Form_Load()
' login to LANSA using default user, password and session location
If Session Is Nothing Then
Call ConnectToLansa("<user name>", "<password>", "<session.cfg path>")
End If
Set axobjecta = Session.CreateComponent("AXOBJECTA")
Set axobjectb = Session.CreateComponent("AXOBJECTB")
' dynamically create columns for list
...
view
MakeColumns
GetEmployees ("")
End Sub
Private Sub GetEmployees(ByVal gbDepartment)
...
StatusMsgBox.Clear
StatusMsgBox.AddItem ("Building Employee List")
' build collection of all employees for initial display
If gbDepartment = "" Then
' build collection of all employees
Call axobjectb.uGetAllEmployees(gbDirty)
Else
Call axobjectb.uGetDepartEmployees(gbDepartment, gbDirty)
End If
StatusMsgBox.Clear
If UCase(gbDirty) = True Then ' if returned in error
StatusMsgBox.AddItem ("Error when building list")
Else:
NewAddListItems ' add items to list
StatusMsgBox.AddItem ("Employees selected")
...
End If
End Sub
Private Sub cmdSearch_Click()
cmdback.Enabled = False
cmdforward.Enabled = False
StatusMsgBox.Clear
StatusMsgBox.AddItem ("Building Employees for Department")
' build collection of all employees for initial display
Call axobjectb.uGetDepartEmployees(uDepartment, gbDirty)
If gbDirty = True Then
StatusMsgBox.AddItem ("Department not found")
' clear list view
lvwemployees.ListItems.Clear
Else:
' add items to list
NewAddListItems ' add items to list
StatusMsgBox.AddItem (Str$(axobjectb.uEmployees.ItemCount) + " Employees selected")
End If
End Sub
Private Sub NewAddListItems()
Dim employeeli As ListItem
Dim employeesi
...
As ListSubItem
Dim employeeobject As LANSA_AXOBJECTA_LIB.axobjecta
On Error GoTo ErrorHandler
...
' clear list view
lvwemployees.ListItems.Clear
gbDirty = axobjectb.uGetNextEmployee
Do While gbDirty = False
lvwindex = lvwindex + 1
Set employeeobject = axobjectb.uCurrentEmployee
Set employeeli = lvwemployees.ListItems.Add(, _
employeeobject.uNumber)
Call employeeli.ListSubItems.Add(, "surname", employeeobject.uSurname)
Call employeeli.ListSubItems.Add(, "department", employeeobject.uDepartment)
Call employeeli.ListSubItems.Add(, "givenname", employeeobject.uGiveName)
Call employeeli.ListSubItems.Add(, "salary", employeeobject.uSalary)
gbDirty = axobjectb.uGetNextEmployee
Loop
Exit Sub ' Exit to avoid handler.
ErrorHandler: ' Error-handling routine.
MsgBox ("Error :" + Err.Description)
End Sub
Private Sub lvwemployees_ItemClick(ByVal Item As ListItem)
...
On Error GoTo ErrorHandler
Dim employeeli As ListItem
cmdback.Enabled = True
cmdforward.Enabled = True
cmdUpdate.Enabled = True
...
Set employeeli = lvwemployees.SelectedItem
lvwindex = Item.Index
Call GetEmployee(lvwindex)
Exit Sub ' Exit to avoid handler.
ErrorHandler: ' Error-handling
...
routine.
MsgBox ("Error :" + Err.Description)
End Sub
Private Sub GetEmployee(lvwindex)
Dim employeeobject As LANSA_AXOBJECTA_LIB.axobjecta
On Error GoTo ErrorHandler
Call axobjectb.uSetCurrentEmployee(lvwindex)
Set employeeobject = axobjectb.uCurrentEmployee
uNumber = employeeobject.uNumber
uSurname = employeeobject.uSurname
uGiveName = employeeobject.uGiveName
uSalary = employeeobject.uSalary
...
Exit Sub ' Exit to avoid handler.
ErrorHandler: ' Error-handling routine.
MsgBox ("Error :" + Err.Description)
End Sub
Private Sub cmdback_Click()
...
If lvwindex > 1 Then
lvwindex = lvwindex - 1
GetEmployee (lvwindex)
End If
End Sub
Private Sub cmdforward_Click()
If lvwindex < lvwemployees.ListItems.Count Then
lvwindex = lvwindex + 1
End If
GetEmployee (lvwindex)
End Sub
Private Sub cmdUpdate_Click()
Dim Status As String
Dim employeeobject As LANSA_AXOBJECTA_LIB.axobjecta
On Error GoTo ErrorHandler
If uSalary = "" Then uSalary = 0
Set employeeobject = axobjectb.uCurrentEmployee
With employeeobject
.uGiveName = uGiveName
.uSurname = uSurname
.uSalary = uSalary
End With
Status = employeeobject.uSaveEmployee
' Clear the Messages from the Message Combo
StatusMsgBox.Clear
If (Status = "OK")
...
Then
MsgBox ("Successfully updated " + employeeobject.uNumber)
Else
Call ShowMessages(Status, employeeobject)
MsgBox ("Error Updating " + employeeobject.uNumber + " : " + Status)
End If
Exit Sub ' Exit to avoid handler.
ErrorHandler: ' Error-handling routine.
MsgBox ("Error :" + Err.Description)
End Sub
Private Sub ShowMessages(ByRef Status As String, ByRef employeeobject As LANSA_AXOBJECTA_LIB.axobjecta)
Dim msgField As Object
On Error GoTo ErrorHandler
For Each msgField In employeeobject.uMessages
StatusMsgBox.AddItem (msgField.Value())
Next
' Select the first entry in the combo box
If (StatusMsgBox.ListCount = 0) Then
StatusMsgBox.AddItem ("Status = '" + Status + "'"
...
)
End If
StatusMsgBox.ListIndex = 0
Exit Sub ' Exit to avoid handler.
ErrorHandler: ' Error-handling routine.
MsgBox ("Error :" + Err.Description)
End Sub
...
Private Sub MakeColumns()
' Clear the ColumnHeaders collection.
lvwemployees.ColumnHeaders.Clear
' Add four ColumnHeaders.
lvwemployees.ColumnHeaders.Add , , "", 0
lvwemployees.ColumnHeaders.Add , , "Surname", 1500
lvwemployees.ColumnHeaders.Add , , "Department"
lvwemployees.ColumnHeaders.Add , , "Given Name"
lvwemployees.ColumnHeaders.Add , , "Salary"
lvwemployees.View = lvwReport
...
End Sub
Private Sub ConnectToLansa(ByVal username As String, ByVal password As String, ByVal txtlocation As String)
On Error GoTo ErrorHandler
Set Session = New LANSA_ACTIVEX_LIB.Session
' Set the session configuration file
Session.ConfigFile = txtlocation
Call Session.SetConnectParam("USER", username)
Call Session.SetConnectParam("PSPW", password)
Call Session.Connect
Exit Sub ' Exit to avoid handler.
ErrorHandler: ' Error-handling routine.
MsgBox ("Error :" + Err.Description)
End Sub