Source Code ActiveX Example 3 - Visual LANSA Source
Reusable Part AXOBJECTA
Reusable Part AXOBJECTB
Source Code ActiveX Example 3 - Reusable Part AXOBJECTA
* Reusable Part AXOBJECTA
Function Options(*DIRECT)
Begin_Com Role(*EXTENDS #PRIM_OBJT)
Attribute Class(#PRIM_ATTR.AX_TYPELIB) Guid('{F86172A5-3FF2-4864-869A-8B1A435C65CA}') TypeLibName('LANSA_AXOBJECTA_LIB')
Attribute Class(#PRIM_ATTR.AX_CLASS) Guid('{4FD69BDC-F4F5-4AB2-8869-9708CA6AE921}') ProgId('LANSA.AXOBJECTA')
Attribute Class(#PRIM_ATTR.AX_IN_INTERFACE) Guid('{BA8C64E0-5654-472F-92DA-255D6DC8B999}') BaseDispId(0)
Attribute Class(#PRIM_ATTR.AX_EVT_INTERFACE) Guid('{AEC6E7D2-D3C9-48B0-8056-C96B7BCE13B5}') BaseDispId(0)
*
Define_Com Class(#prim_lcol<#skilcode>) Name(#SkillsCollection) Help('collection of skills for employee')
DEFINE_COM CLASS(#skilcode) NAME(#tmpSkill) reference(*dynamic)
Define_Com Class(#AXOBJECTB) Name(#AXOBJECTB)
Define_Pty Name(uSkills) Get(*COLLECTION #SkillsCollection)
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(0) Name('uSkills')
* Property Messages
DEFINE_PTY NAME(uMessages) GET(*Collection #vMessages) HELP('Message Accessor')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(1) Name('uMessages')
Define_Com Class(#prim_lcol<#STD_TEXTL>) Name(#vMessages)
*Property LastMessage
Define_Pty Name(uLastMessage) Get(*auto #vLastMessage)
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(2) Name('uLastMessage')
DEFINE_COM CLASS(#STD_TEXTL) NAME(#vLastMessage) reference(*dynamic)
* Property LastStaus
Define_Pty Name(uLastStatus) Get(*auto #vLastStatus)
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(3) Name('uLastStatus')
Define_Com Class(#STD_TEXT) Name(#vLastStatus)
*
* Personal Details
Define_Pty Name(uGiveName) Get(*auto #givename) Set(*auto #givename) Help('Given (first) name')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(4) Name('uGiveName')
Define_Pty Name(uSurname) Get(*auto #surname) Set(*auto #surname) Help('Surname')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(5) Name('uSurname')
* Address Details
Define_Pty Name(uAddress1) Get(*auto #Address1) Set(*auto #Address1) Help('Number and Street')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(6) Name('uAddress1')
Define_Pty Name(uAddress2) Get(*auto #Address2) Set(*auto #Address2) Help('Suburb')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(7) Name('uAddress2')
Define_Pty Name(uAddress3) Get(*auto #Address3) Set(*auto #Address3) Help('City')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(8) Name('uAddress3')
Define_Pty Name(uPostCode) Get(*auto #PostCode) Set(*auto #PostCode) Help('Postcode')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(9) Name('uPostCode')
* contact numbers
Define_Pty Name(uBusinessPhone) Get(*auto #PhoneBus) Set(*auto #PhoneBus) Help('Business Phone')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(10) Name('uBusinessPhone')
Define_Pty Name(uHomePhone) Get(*auto #PhoneHme) Set(*auto #PhoneHme) Help('Home phone')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(11) Name('uHomePhone')
* General
Define_Pty Name(uDepartment) Get(*auto #deptment) Set(*auto #deptment) Help('Department Number')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(12) Name('uDepartment')
Define_Pty Name(uSection) Get(*auto #Section) Set(*auto #Section) Help('Section Code')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(13) Name('uSection')
Define_Pty Name(uSalary) Get(*auto #Salary) Set(*auto #Salary) Help('Yearly Salary')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(14) Name('uSalary')
Define_Pty Name(uNumber) Get(*auto #empno) Set(*auto #empno) Help('Number')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(15) Name('uNumber')
*
Mthroutine Name(uLoadEmployee)
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(17) Name('uLoadEmployee')
Define_Map For(*input) Class(#empno) Name(#uEmpno)
Change Field(#EMPNO) To(#uEMPNO)
Fetch Fields(*ALL) From_File(PSLMST) With_Key(#EMPNO)
If_Status Is(*OKAY)
Invoke Method(#com_owner.uLoadSkills) Uempno(#empno)
Endif
Endroutine
Mthroutine Name(uSaveEmployee)
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(18) Name('uSaveEmployee')
Define_Map For(*RESULT) Class(#io$sts) Name(#O_STATUS)
UPDATE FIELDS(*ALL *excluding #empno) IN_FILE(PSLMST) WITH_KEY(#EMPNO) IO_ERROR(*NEXT) VAL_ERROR(*NEXT)
Set Com(#O_STATUS) Value(#io$sts)
Execute Subroutine(SETLASTMSG)
Endroutine
Mthroutine Name(uLoadSkills)
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(19) Name('uLoadSkills')
Define_Map For(*input) Class(#empno) Name(#UEmpno)
Change Field(#EMPNO) To(#uEMPNO)
Invoke Method(#SkillsCollection.RemoveAll)
Select Fields(#SKILCODE) From_File(PSLSKL) With_Key(#EMPNO)
Set_Ref #tmpskill to(*create_As #skilcode)
Set Com(#tmpSkill) Value(#skilcode)
Invoke Method(#SkillsCollection.Insert) Item(#tmpSkill)
Endselect
Endroutine
* SETLMSG Saves the last message.
*
* Get the Message using Built In Function : GET_MESSAGE
*
* This must be invoked in a Subroutine, as the messages will be cleared after
* leaving or entering any MthRoutine.
*
* This is a temporary error mechanism, a better one is coming soon!
Subroutine Name(SETLASTMSG)
Define Field(#LASTMSG) Type(*CHAR) Length(80)
Define Field(#RETCODE) Type(*CHAR) Length(2)
Invoke Method(#vMessages.RemoveAll)
Set Com(#vLastStatus) Value(IO$STS)
If_Status Is_Not(*OKAY)
Use Builtin(GET_MESSAGE) To_Get(#RETCODE #LASTMSG)
DoWhile Cond('#RETCODE = OK')
set_Ref #vlastmessage to(*create_as #std_textl)
Set Com(#vLastMessage) Value(#LASTMSG)
Invoke Method(#vMessages.Insert) Item(#vLastMessage)
Use Builtin(GET_MESSAGE) To_Get(#RETCODE #LASTMSG)
Endwhile
Endif
Endroutine
End_Com
Source Code ActiveX Example 3- Reusable Part AXOBJECTB
* Reusable Part AXOBJECTB
Function Options(*DIRECT)
Begin_Com Role(*EXTENDS #PRIM_OBJT)
Attribute Class(#PRIM_ATTR.AX_TYPELIB) Guid('{9606E0AB-DCC2-426D-8ABE-EEFFB05F5F07}') Typelibname('LANSA_AXOBJECTB_LIB')
Attribute Class(#PRIM_ATTR.AX_CLASS) Guid('{4261A3BF-BD23-4955-997F-FE4E0EA19999}') Progid('LANSA.AXOBJECTB')
Attribute Class(#PRIM_ATTR.AX_IN_INTERFACE) Guid('{972B0B94-0740-46D7-AD6F-9BC2142F2A01}') Basedispid(0)
Attribute Class(#PRIM_ATTR.AX_EVT_INTERFACE) Guid('{A61429A8-0B19-4788-BF8F-8D075B505EE5}') Basedispid(0)
* employee object
Define_Com Class(#axobjecta) Name(#Employee) Reference(*dynamic)
* Collection of employees
Define_Com Class(#prim_lcol<#axobjecta>) Name(#Employees)
* Collection Iterator
Define_Com Class(#prim_lcit<#axobjecta>) Name(#itrEmployees) Reference(*dynamic)
Define_Com Class(#AXOBJECTA) Name(#AXOBJECTA)
Define_Pty Name(uEmployees) Get(*COLLECTION #employees)
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(0) Name('uEmployees')
Define_Pty Name(uCurrentEmployee) Get(*reference #employee)
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(6) Name('uCurrentEmployee')
Mthroutine Name(uSetCurrentEmployee)
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(4) Name('uSetCurrentEmployee')
Define_Map For(*input) Class(#std_num) Name(#index)
Define_Map For(*RESULT) Class(#prim_boln) Name(#uDirty)
Set Com(#uDirty) Value(#com_false)
Set_Ref Com(#employee) To(#employees.item<#index.value>)
If_Ref Com(#employee) Is(*null)
Set Com(#uDirty) Value(#com_true)
Endif
Endroutine
Mthroutine Name(uGetNextEmployee)
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(8) Name('uGetNextEmployee')
Define_Map For(*RESULT) Class(#prim_boln) Name(#uDirty)
Define_Com Class(#prim_boln) Name(#EmployeeExists)
Set Com(#udirty) Value(#com_false)
If_Ref Com(#itremployees) Is_Not(*null)
Invoke Method(#itrEmployees.MoveNext) Result(#employeeexists)
If Cond('#employeeexists = #com_true')
Set_Ref Com(#Employee) To(#itremployees.Current)
If_Ref Com(#Employee) Is(*null)
Set Com(#uDirty) Value(#com_true)
Endif
Else
Set Com(#udirty) Value(#com_true)
Endif
Else
Set Com(#udirty) Value(#com_true)
Endif
If Cond('#uDirty = #com_true')
Set_Ref Com(#Employee) To(*null)
Endif
Endroutine
Mthroutine Name(uGetAllEmployees) Help('Get all employees')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(1) Name('uGetAllEmployees')
Define_Map For(*output) Class(#prim_boln) Name(#uDirty)
Invoke Method(#employees.RemoveAll)
Select Fields(#EMPNO) From_File(PSLMST2)
Set_Ref Com(#employee) To(*create_as #axobjecta)
Invoke Method(#Employee.uLoadEmployee) Uempno(#empno)
Invoke Method(#Employees.Insert) Item(#employee)
Endselect
Invoke Method(#Employees.CreateIterator) Result(#itrEmployees)
If Cond('#employees.itemcount > 0')
Set Com(#uDirty) Value(#com_false)
Else
Set Com(#uDirty) Value(#com_true)
Endif
Endroutine
Mthroutine Name(uGetDepartEmployees) Help('Get an individual employee')
Attribute Class(#PRIM_ATTR.AX_IN_MEMBER) Dispid(2) Name('uGetDepartEmployees')
Define_Map For(*input) Class(#deptment) Name(#uDepartment)
Define_Map For(*output) Class(#prim_boln) Name(#uDirty)
Change Field(#DEPTMENT) To(#uDepartment)
Invoke Method(#employees.RemoveAll)
Select Fields(#EMPNO) From_File(PSLMST1) With_Key(#DEPTMENT)
Set_Ref Com(#employee) To(*create_as #axobjecta)
Invoke Method(#Employee.uLoadEmployee) Uempno(#empno)
Invoke Method(#Employees.Insert) Item(#employee)
Endselect
Invoke Method(#Employees.CreateIterator) Result(#itrEmployees)
If Cond('#employees.itemcount > 0')
Set Com(#uDirty) Value(#com_false)
Else
Set Com(#uDirty) Value(#com_true)
Endif
Endroutine
End_Com
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
