treeview
Please find below the code for treeview application. When I am entering the form details in treeview- data is updated in database but on child node I am getting error - key is not unique in collection. How to solve this problem. Database - contactID is primarykey and unique. AT Child node - data is not updated. Please help me to solve this.
Thanks
Gorti
Option Explicit
Dim contactNode As Node
Dim rsNotesTable As Recordset
Dim rsSupplyType As Recordset
Dim icurrentstate As Integer
Dim lcurrentContactKey As Long
Dim scurrentContactName As String
Dim bFieldsPopulated As Boolean ' flag to see if the fields have data
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdIssuedstock_Click ()
Load Issuedstock
End Sub
Private Sub cmdOpeningstock_Click ()
Load Openingstock
End Sub
Private Sub cmdReceivedstock_Click ()
Load Receivedstock
End Sub
Private Sub cmdTotalstock_Click ()
Load TotalStock
End Sub
'Coding the activate procedure
Private Sub Form_Activate ()
Static bLoadedAlready As Boolean
sbStatus.Panels.Item(2).Text = "Loading....."
If (Not bLoadedAlready) Then
Call initializeform
bLoadedAlready = True
End If
sbStatus.Panels.Item(2) = "Ready."
End Sub
'Code for form load, this ensure the database was opened properly.
Private Sub Form_Load ()
If (Not openTheDatabase ()) Then
MsgBox "Sorry - the database could not be opened."
End ' TERMINATE THE PROGRAM UNCONDITIONALLY
End If
'-- REMOVE THE XS IN OUR TEXTBOXES
Call clearFields
bFieldsPopulated = False
icurrentstate = Now_idle
End Sub
'Code for initializes form subroutine
Public Sub initializeform ()
Screen.MousePointer = vbHourglass ' show activity is occuring
icurrentstate = Now_idle ' set the current state of programe
sbStatus.Panels.Item(2).Text = "Loading..."
tbContact. Tab = 0 'make 1st of 4 tabs current
DoEvents
Call clearFields
Call lockFields (True)
Call updateTree
Call updateForm
Call setUpListView
tbContact. Enabled = False
Screen.MousePointer = vbDefault
sbStatus.Panels.Item(2).Text = "Ready."
End Sub
'Code for clearFields Subroutine
Public Sub clearFields()
Dim indx As Integer
Dim tempMask As String
With Me.Controls
For indx = 0 To Count - 1
If Me.Controls (indx). Tag = "1" Then
If (TypeOf Me.Controls(indx) Is TextBox) Then
Me.Controls (indx). Text = ""
ElseIf (TypeOf Me.Controls (indx) Is MaskEdBox) Then
TempMask = Me.Controls (indx).Mask
Me.Controls(indx).Mask = ""
Me.Controls(indx).Text = ""
Me.Controls(indx).Mask = tempMask
Else
Me.Controls(indx).Caption = ""
End If
End If
Next
End With
DoEvents
End Sub
'Code for lockFields subroutine
Public Sub lockFields(bDoLock As Boolean)
Dim indx As Integer
For indx = 0 To Me.Controls.Count - 1
If Me.Controls(indx).Tag = "1" Then
If (TypeOf Me.Controls(indx) Is TextBox) Then
If (bDoLock = True) Then
Me.Controls(indx).Locked = True
Me.Controls(indx).BackColor = vbWhite
Else
Me.Controls(indx).Locked = False
Me.Controls(indx).BackColor = vbYellow
End If
ElseIf (TypeOf Me.Controls(indx) Is MaskEdBox) Then
If (bDoLock = True) Then
Me.Controls(indx).Enabled = False
Me.Controls(indx).BackColor = vbWhite
Else
Me.Controls(indx).Enabled = True
Me.Controls(indx).BackColor = vbYellow
End If
End If
End If
Next
DoEvents
End Sub
'Code for updateTree () subroutine
Public Sub updateTree()
Dim indx As Integer
Dim rsAllNames As Recordset
Dim sqlNames As String
Dim currentAlpha As String
Dim sContactName As String
Dim ContactID As String
Dim FarmName As String
tvContact.Nodes.Clear
sqlNames = "Select ContactID, FarmName FROM Contacts ORDER BY FarmName"
Set rsAllNames = dbEggInventory.OpenRecordset(sqlNames)
If (rsAllNames.RecordCount > 0) Then
rsAllNames.MoveFirst
End If
For indx = Asc("A") To Asc("Z")
currentAlpha = Chr(indx)
Set contactNode = tvContact.Nodes.Add (, , currentAlpha, currentAlpha)
If (Not rsAllNames.EOF) Then
Do While UCase$(Left(rsAllNames!FarmName, 1)) = currentAlpha
With rsAllNames
sContactName = FarmName
If (Not IsNull(FarmName)) Then
sContactName = FarmName
End If
End With
DoEvents
Set contactNode = tvContact.Nodes.Add(currentAlpha, _
tvwChild, "ID" & CStr(rsAllNames!ContactID), ContactName)
rsAllNames.MoveFirst When prog, I am getting If (rsAllNames.EOF) Then error - key is not unique in collection.
In table ContactID is primary key
Exit Do
End If
Loop
End If
Next
sbStatus.Panels.Item(1).Text = "There are " & _
rsAllNames.RecordCount & " Supplier in the database."
rsAllNames.Close
DoEvents
End Sub
'code for updateForm() subroutine
Public Sub updateForm()
Select Case icurrentstate
Case Now_Adding, Now_Editing
If (icurrentstate = Now_Adding) Then
sbStatus.Panels.Item(2).Text = "Adding...."
Call clearFields
Else
sbStatus.Panels.Item(2).Text = "Editing...."
End If
tbContact.Enabled = True
tbContact.Tab = 0 'make 1st tab active and current
tbContact.TabEnabled(1) = False 'make other tab inactive
tbContact.TabEnabled(2) = False 'make other tab inactive
tbContact.TabEnabled(3) = False
tbContact.TabEnabled(4) = False
tvContact.Enabled = False
lockFields (False) 'unlock the field and set the background
txtFarmName.SetFocus 'set focus to first name field
Toolbar1.Buttons(bAdd).Enabled = False
Toolbar1.Buttons(bCancel).Enabled = True
Toolbar1.Buttons(bSave).Enabled = True
Toolbar1.Buttons(bDelete).Enabled = False
Toolbar1.Buttons(bEdit).Enabled = False
Toolbar1.Buttons(bQuit).Enabled = False
Case Now_idle
sbStatus.Panels.Item(2).Text = "Ready."
Toolbar1.Buttons(bAdd).Enabled = True
Toolbar1.Buttons(bCancel).Enabled = False
Toolbar1.Buttons(bSave).Enabled = False
Toolbar1.Buttons(bQuit).Enabled = True
If (Len(txtFarmName)) Then
Toolbar1.Buttons(bDelete).Enabled = True
Toolbar1.Buttons(bEdit).Enabled = True
Else
Toolbar1.Buttons(bDelete).Enabled = False
Toolbar1.Buttons(bEdit).Enabled = False
End If
tvContact.Enabled = True
tbContact.TabEnabled(1) = True
tbContact.TabEnabled(2) = True
tbContact.TabEnabled(3) = True
tbContact.TabEnabled(4) = True
Case Now_Deleting
sbStatus.Panels.Item(2).Text = "Deleting...."
Toolbar1.Buttons(bAdd).Enabled = False
Toolbar1.Buttons(bCancel).Enabled = False
Toolbar1.Buttons(bSave).Enabled = False
Toolbar1.Buttons(bDelete).Enabled = False
Toolbar1.Buttons(bEdit).Enabled = False
Toolbar1.Buttons(bQuit).Enabled = False
Case NOW_SAVING
sbStatus.Panels.Item(2).Text = "Saving...."
tvContact.Enabled = True
Toolbar1.Buttons(bAdd).Enabled = False
Toolbar1.Buttons(bCancel).Enabled = False
Toolbar1.Buttons(bSave).Enabled = False
Toolbar1.Buttons(bDelete).Enabled = False
Toolbar1.Buttons(bEdit).Enabled = False
Toolbar1.Buttons(bQuit).Enabled = False
If (Len(mskDateapproval)) Then
lblapprovaldate = Format$(mskDateapproval, "mmmm dd,yyyy")
End If
End Select
DoEvents
End Sub
'code to set up the listView control() lvERN subroutine
Public Sub setUpListView()
Dim clmHdr As ColumnHeader
Set clmHdr = lvERN.ColumnHeaders. _
Add(, , "DateofSupply", lvERN.Width \ 3)
Set clmHdr = lvERN.ColumnHeaders. _
Add(, , "ApprovalTypeID", lvERN.Width \ 3)
Set clmHdr = lvERN.ColumnHeaders. _
Add(, , "NotesOnSupply", lvERN.Width \ 3)
End Sub
'code to lvERN_Columnclick event
Private Sub lvERN_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
Dim nSortCol As Integer
'when a columnheader object is clicked, the list view control is sorted by the subitems
'of that column. set the sortkey to the index of the columnheader -1
nSortCol = ColumnHeader.index - 1
If (lvERN.SortKey = nSortCol) Then
lvERN.SortOrder = 1 - lvERN.SortOrder
Else
lvERN.SortKey = nSortCol
lvERN.SortOrder = lvwAscending
End If
'--do the sort now
lvERN.Sorted = True
End Sub
'code lvERN_ItemClick event procedure
Private Sub lvERN_ItemClick(ByVal Item As MSComctlLib.ListItem)
If (rsSupplyType.RecordCount > 0) Then
rsSupplyType.MoveFirst
'-- find the record that has the id
rsSupplyType.FindFirst "SupplyCounter = " & _
lvERN.ListItems(Item.index).SubItems(2)
txtNotes = rsSupplyType!NotesOnSupply
End If
End Sub
'code to lvERN_MouseDown event procedure
Private Sub lvERN_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbRightButton Then
If (rsSupplyType.RecordCount < 1) Then
mnuDelete.Enabled = False
Else
mnuDelete.Enabled = True
End If
PopupMenu mnuPopup
End If
End Sub
'code to click event of the mnuAddNew menu
Private Sub mnuAddNew_Click()
frmERN.sContactName = scurrentContactName
frmERN.lContactNumber = lcurrentContactKey
frmERN.Show vbModal
Call populateListView
End Sub
'code to click event of the mnuDelete menu
Private Sub mnuDelete_Click()
Dim index As Integer
Dim rsDeleteCall As Recordset
Dim sDeletecall As String
indx = MsgBox("Are you sure you wish to delete this call from" & _
lvERN.ListItems(lvERN.SelectedItem.index) & "??", _
vbYesNo + vbQuestion, progname)
If (indx <> vbYes) Then Exit Sub
sDeletecall = "Delete * from Notes where callcounter =" & _
lvERN.ListItems(lvERN.SelectedItem.index).SubItems (2)
dbEggInventory.Execute (sDeletecall)
Call populateListView
End Sub
'Code to Toolbar1-ButtonClick event procedure
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.index
Case bAdd '-add new
icurrentstate = Now_Adding
Call updateForm
Case bCancel '-cancel the action
If (bFieldsPopulated = True) Then
Call populateFields
End If
Call lockFields(True)
icurrentstate = Now_idle
Call updateForm
Case bSave 'saving the current record
'here are we are saving either a new record or editing entry
If (Not validateEntry()) Then
Exit Sub
End If
PostContact
Case bDelete ' deleting the current record
Dim indx As Integer
Dim sMsg As String
Dim sDeleteSQL As String
sMsg = "Delete " & tvContact.SelectedItem & _
"and all related Supply logs?"
indx = MsgBox(sMsg, vbYesNo + vbCritical, progname)
If (indx <> vbYes) Then Exit Sub
sDeleteSQL = "Delete * from Contacts WHERE ContactID = " _
& lcurrentContactKey
dbEggInventory.Execute (sDeleteSQL)
Call initializeform
Case bEdit ' editing
icurrentstate = Now_Editing
updateForm
Case bQuit ' quitting
rsContacts.Close
dbEggInventory.Close
Set rsContacts = Nothing
Set dbEggInventory = Nothing
Unload Me
End Select
End Sub
'Code for dat entry validation subroutine
Public Function validateEntry() As Boolean
Dim indx As Integer
validateEntry = True
sbStatus.Panels.Item(2).Text = "Validating..."
If (Len(txtFarmName) < 1) Then
tbContact.Tab = 0
indx = MsgBox("Please enter the Farm Name of the contact.", _
vbInformation + vbOKOnly, progname)
txtFarmName.SetFocus
validateEntry = False
Exit Function
End If
mskDateapproval.PromptInclude = False
If (Len(mskDateapproval.Text) > 0) Then
mskDateapproval.PromptInclude = True
If (Not IsDate(mskDateapproval)) Then
tbContact.Tab = 0
indx = MsgBox("please enter the valid date of approval mm/dd/yyyy.", _
vbInformation + vbOKOnly, progname)
mskDateapproval.SetFocus
validateEntry = False
Exit Function
End If
mskDateapproval.PromptInclude = False
End If
End Function
'code to tvContact_NodeClick event procedure
Private Sub tvContact_NodeClick(ByVal Node As MSComctlLib.Node)
'here we retrieve the contact details of poultryfarm the user clicked on--
lcurrentContactKey = CLng(Mid$(Node.Key, 3, Len(Node.Key)))
With rsContact
.index = "PrimaryKey"
.Seek "=", lcurrentContactKey
If Not .NoMatch Then
bFieldsPopulated = True
scurrentContactName = tvContact.SelectedItem
Call populatedFields
Call populateListView
tbContact.Enabled = True
Else
MsgBox ("good")
End If
End With
End Sub
'code to display the fields in our database to the user.
Public Sub populateFields()
Dim approvaldate As String
'here we retrieve teh field from the database and populate teh field
'in the user interface
Call clearFields
With rsContacts
If (Not IsNull(!FarmName)) Then
txtFarmName = !FarmName
If (Not IsNull(!Officeaddress)) Then
txtOfficeaddress = !Officeaddress
End If
If (Not IsNull(!OfficeCity)) Then
txtOfficeCity = !OfficeCity
End If
If (Not IsNull(!OfficeState)) Then
txtOfficeState = !OfficeState
End If
If (Not IsNull(!OfficeZip)) Then
mskOfficeZip = !OfficeZip
End If
If (Not IsNull(!OfficePhone)) Then
mskOfficePhone = !OfficePhone
End If
If (Not IsNull(!OfficeFax)) Then
mskOfficeFax = !OfficeFax
End If
If (Not IsNull(!OfficeMobile)) Then
mskOfficemobile = !OfficeMobile
End If
If (Not IsNull(!Email)) Then
txtEmail = !Email
End If
If (Not IsNull(!approvaldate)) Then
approvaldate = !approvaldate
convertDate approvaldate
mskDateapproval = approvaldate
lblapprovaldate = Format$(!approvaldate, "dddd mmmmm dd,yyyy")
End If
DoEvents
Call updateForm
End With
End Sub
'code for converting dates correctly
Public Sub convertDate(approvaldate As String)
Dim sYear As String
If Len(approvaldate) = 8 Then
sYear = Mid$(approvaldate, 7, 2)
If sYear >= 30 Then
approvaldate = Mid$(approvaldate, 1, 6) & "19" & sYear
Else
approvaldate = Mid$(approvaldate, 1, 6) & "20" & sYear
End If
End If
End Sub
'code construct and invoke SQL query to retrieve any ERN records
Public Sub populateListView()
Dim itemToAdd As ListItem
Dim notesql As String
lvERN.ListItems.Clear
txtNotes = ""
txtNotes.Locked = True
notesql = "SELECT DISTINCTROW Notes.DateofSupply,"
notesql = notesql & "Notes.ApprovalTypeID, Notes.NotesOnSupply,"
notesql = notesql & "Notes.SupplyCounter,SupplyType.SupplyDescription, "
notesql = notesql & "Notes.ContactID"
notesql = notesql & "INNER JOIN SupplyType ON Notes.ApprovalTypeID="
notesql = notesql & "SupplyType.ApprovalTypeID"
notesql = notesql & "WHERE Notes.ContactID =" & _
lcurrentContactKey
notesql = notesql & "ORDER BY Notes.DateofSupply DESC"
Set rsSupplyType = dbEggInventory.OpenRecordset(notesql)
If (rsSupplyType.RecordCount > 0) Then
rsSupplyType.MoveFirst
While Not rsSupplyType.EOF
Set itemToAdd = lvERN.ListItems.Add(, , _
Format$(rsSupplyType!DateofSupply, "dddd mmmm dd,yyyy"))
itemToAdd.SubItems(1) = rsSupplyType!SupplyDesciption
itemToAdd.SubItems(2) = CStr(rsSupplyType!SupplyCounter)
rsSupplyType.MoveNext
Wend
sbStatus.Panels.Item(1).Text = "There are" & _
rsSupplyType.RecordCount & "Lots are supplied by" _
& scurrentContactName
Else
Set itemToAdd = lvERN.ListItems.Add(, , "No of lots supplied")
sbStatus.Panels.Item(2).Text = "No Lots are supplied by" _
& scurrentContactName
End If
lvERN.SelectedItem = lvERN.ListItems(1)
Call lvERN_ItemClick(lvCalls.SelectedItem)
DoEvents
End Sub
'code to update the database with any new ERN or Edit the user makes on existing ERN.
Public Sub PostContact()
Dim txtEmail As String
Dim rsMaxIDNumber As Recordset
Dim sqlMaxID As String
Dim lNewContactID As Long
Screen.MousePointer = vbHourglass
sbStatus.Panels.Item(2).Text = "Posting contact......."
If (icurrentstate = Now_Adding) Then
rsContacts.AddNew
Else
With rsContacts
.MoveFirst
.index = "PrimaryKey"
.Seek "=", lcurrentContactKey
If Not .NoMatch Then
rsContacts.Edit
Else
MsgBox ("Sorry, data donot exits")
End If
End With
End If
With rsContacts
If (Len(txtFarmName)) Then !FarmName = txtFarmName
If (Len(txtOfficeaddress)) Then !OfficeStreet = txtOfficeaddress
If (Len(txtOfficeCity)) Then !OfficeCity = txtOfficeCity
If (Len(txtOfficeState)) Then !OfficeState = txtOfficeState
If (Len(mskOfficeZip)) Then !OfficeZip = mskOfficeZip
If (Len(mskOfficePhone)) Then !OfficePhone = mskOfficePhone
If (Len(mskOfficeFax)) Then !OfficeFax = mskOfficeFax
If (Len(mskOfficemobile)) Then !OfficeMobile = mskOfficemobile
If (Len(txtEmail)) Then !Email = txtEmail
mskDateapproval.PromptInclude = False
If (Len(mskDateapproval.Text) > 0) Then
mskDateapproval.PromptInclude = True
!DateOfapproval = mskDateapproval
'lblapprovaldate = Format$(!approvaldate, "dddd mmmm dd,yyyy")
End If
mskDateapproval.PromptInclude = True
.Update
End With
DoEvents
If (icurrentstate = Now_Adding) Then
Call initializeform
Else
icurrentstate = Now_idle
Call lockFields(True)
Call updateForm
End If
sbStatus.Panels.Item(2).Text = "Ready."
Screen.MousePointer = vbDefault
End Sub
btgorti
|
