Thread: treeview
View Single Post
 
Old September 6th, 2005, 09:32 AM
SAIGORTI SAIGORTI is offline
Registered User
 
Join Date: Sep 2005
Location: HYDERABAD, Andhra pradesh, India.
Posts: 1
Thanks: 0
Thanked 0 Times in 0 Posts
Default 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