Hi everyone
I was wondering if anyone knows a way around this problem I'm having. Basicallly I designed a treeview control which shows responses from schools in an access form using a treeview control (schools email and fax electronically and it's save on a shared network drive). I've been asked to do the same thing again but in another database and here's where the problem started. In the original form it filtered by the school Id so it only had to find a single schools list of responses. But this new database is searching for duplicate pupil records (where they're registered at more than one school)so the main form in this database is filtered by pupil not school Id. It was ok to begin with because there's a school Id field in a subform so I decided to loop through the recordset and create one large string which I could filter the treeview control to show response only from those schools listed in the subform. But for some strange reason it runs sometimes but other times it flags up a runtime 35602 'key is not unique in collection'. At the start of the code I've put an if statement which should exit the sub routine if the treeview is already filtered using that school Id and I can't think of any other way to get around the problem
(below is the copy of the code I'm using).
Option Compare Database
Option Explicit
Dim cboSearchOnSurnameInSync As Boolean
Public cboSearchByDataCheckNumInSync As Boolean ' Flag to test if the recordset in the search
' combo is in sync with the recordset in the form
Dim tabMainHeight As Long
Dim trvDocsNativeID As String
' Refresh Dcos tree view control
Sub trvDocsRefresh()
Dim initpath As String
Dim trv As MSComctlLib.Treeview
Dim ct As C_Timer
Dim sbf As Subform
Set sbf = [F_Dupe Pupil Pupils]
' Dont refresh if we are already looking at the current native ID on the data page
If trvDocsNativeID = sbf.Form.txtNativeID Then
Exit Sub
End If
DoCmd.Hourglass True
' Note this is case sensitive
initpath = "R:\FAX"
Set trv = Me.trvDocs.Object
With Me.trvDocs
.Nodes.Clear
.ImageList = Me.ImageList1.Object
.Nodes.Add , tvwFirst, initpath, initpath, "Folder"
.Nodes(initpath).Expanded = True
End With
DoEvents
Me.cmdtrvDocsRefresh.SetFocus
Me.trvDocs.Visible = False
Set ct = New C_Timer
ct.StartTimer
CreateFolderNodes (initpath)
CreateFileNodes
ct.StopTimer
Me.txtRefreshTime = Format$(ct.TimeElapsed, "0.000")
Me.trvDocs.Visible = True
trvDocsNativeID = sbf.Form.txtNativeID
DoCmd.Hourglass False
End Sub
' Create the file nodes
Sub CreateFileNodes()
Dim sd As C_StringDelim
Dim i As Long
Dim Filename As String
Dim FullPath As String
Dim IconKey As String
Dim sbf As Subform
Set sd = New C_StringDelim
sd.Delim = Chr$(13) & Chr$(10)
Set sbf = [F_Dupe Pupil Pupils]
Do While Not sbf.Form.Recordset.EOF
sd.SourceString = GetCommandOutput("cmd /c ""dir R:\FAX\*" & sbf.Form.txtNativeID & "* /b/s""", True, False, False)
For i = 1 To sd.SubStrings.Count - 1
Filename = FullPathToFilename(sd.SubStrings(i))
FullPath = Left$(sd.SubStrings(i), InStr(1, sd.SubStrings(i), Filename) - 2)
Select Case LCase$(Right$(Filename, 3))
Case "pdf", "snp", "rtf", "doc", "xls"
IconKey = LCase$(Right$(Filename, 3))
Case Else
IconKey = "Default"
End Select
Me.trvDocs.Nodes.Add FullPath, tvwChild, sd.SubStrings(i), Filename, IconKey
TreeViewExpandUp Me.trvDocs.Object, FullPath
Next i
sbf.Form.Recordset.MoveNext
Loop
End Sub
' Create the folder nodes
Sub CreateFolderNodes(FolderSpec As String)
Dim TopFolder As C_Folder
Dim SubFolder As C_Folder
Set TopFolder = New C_Folder
With TopFolder
.FolderPath = FolderSpec
.MaxPath = 512
.SortMode = cfSortAscending
.ListFiles = False
.Refresh
End With
For Each SubFolder In TopFolder.Folders
Me.trvDocs.Nodes.Add FolderSpec, tvwChild, SubFolder.FolderPath, SubFolder.FolderName, "Folder"
CreateFolderNodes (SubFolder.FolderPath)
Next
End Sub
' Expand treeview folder nodes for just those folders that contain files
Function TreeViewExpandUp(trv As MSComctlLib.Treeview, Key As String)
Dim ParentKey As String
On Error GoTo TreeViewExpandUpErr
trv.Nodes(Key).Expanded = True
ParentKey = trv.Nodes(Key).Parent.Key
Do While trv.Nodes(ParentKey).Index <> 1
trv.Nodes(ParentKey).Expanded = True
ParentKey = trv.Nodes(ParentKey).Parent.Key
Loop
On Error GoTo 0
Exit Function
TreeViewExpandUpErr:
MsgBox Err.Number & Err.Description
End Function
' Handle double click on node
Sub trvDocs_DblClick()
Dim trv As MSComctlLib.Treeview
Dim ChildNode As Object
Dim i As Long
DoCmd.Hourglass True
Set trv = Me.trvDocs.Object
If trv.SelectedItem.Children = 0 Then
ShellExecute vbNull, "", trv.SelectedItem.Key, "", "", SW_SHOWNORMAL
Else
Set ChildNode = trv.SelectedItem.Child
For i = 1 To trv.SelectedItem.Children
ShellExecute vbNull, "", ChildNode.Key, "", "", SW_SHOWNORMAL
Set ChildNode = ChildNode.Next
Next i
End If
trv.SelectedItem.Expanded = True
DoEvents
DoCmd.Hourglass False
End Sub
Sorry for the long post but I can't find an answer anywhere and I really need to get this done
.
I was wondering if anyone knows a way around this problem I'm having. Basicallly I designed a treeview control which shows responses from schools in an access form using a treeview control (schools email and fax electronically and it's save on a shared network drive). I've been asked to do the same thing again but in another database and here's where the problem started. In the original form it filtered by the school Id so it only had to find a single schools list of responses. But this new database is searching for duplicate pupil records (where they're registered at more than one school)so the main form in this database is filtered by pupil not school Id. It was ok to begin with because there's a school Id field in a subform so I decided to loop through the recordset and create one large string which I could filter the treeview control to show response only from those schools listed in the subform. But for some strange reason it runs sometimes but other times it flags up a runtime 35602 'key is not unique in collection'. At the start of the code I've put an if statement which should exit the sub routine if the treeview is already filtered using that school Id and I can't think of any other way to get around the problem
(below is the copy of the code I'm using).Option Compare Database
Option Explicit
Dim cboSearchOnSurnameInSync As Boolean
Public cboSearchByDataCheckNumInSync As Boolean ' Flag to test if the recordset in the search
' combo is in sync with the recordset in the form
Dim tabMainHeight As Long
Dim trvDocsNativeID As String
' Refresh Dcos tree view control
Sub trvDocsRefresh()
Dim initpath As String
Dim trv As MSComctlLib.Treeview
Dim ct As C_Timer
Dim sbf As Subform
Set sbf = [F_Dupe Pupil Pupils]
' Dont refresh if we are already looking at the current native ID on the data page
If trvDocsNativeID = sbf.Form.txtNativeID Then
Exit Sub
End If
DoCmd.Hourglass True
' Note this is case sensitive
initpath = "R:\FAX"
Set trv = Me.trvDocs.Object
With Me.trvDocs
.Nodes.Clear
.ImageList = Me.ImageList1.Object
.Nodes.Add , tvwFirst, initpath, initpath, "Folder"
.Nodes(initpath).Expanded = True
End With
DoEvents
Me.cmdtrvDocsRefresh.SetFocus
Me.trvDocs.Visible = False
Set ct = New C_Timer
ct.StartTimer
CreateFolderNodes (initpath)
CreateFileNodes
ct.StopTimer
Me.txtRefreshTime = Format$(ct.TimeElapsed, "0.000")
Me.trvDocs.Visible = True
trvDocsNativeID = sbf.Form.txtNativeID
DoCmd.Hourglass False
End Sub
' Create the file nodes
Sub CreateFileNodes()
Dim sd As C_StringDelim
Dim i As Long
Dim Filename As String
Dim FullPath As String
Dim IconKey As String
Dim sbf As Subform
Set sd = New C_StringDelim
sd.Delim = Chr$(13) & Chr$(10)
Set sbf = [F_Dupe Pupil Pupils]
Do While Not sbf.Form.Recordset.EOF
sd.SourceString = GetCommandOutput("cmd /c ""dir R:\FAX\*" & sbf.Form.txtNativeID & "* /b/s""", True, False, False)
For i = 1 To sd.SubStrings.Count - 1
Filename = FullPathToFilename(sd.SubStrings(i))
FullPath = Left$(sd.SubStrings(i), InStr(1, sd.SubStrings(i), Filename) - 2)
Select Case LCase$(Right$(Filename, 3))
Case "pdf", "snp", "rtf", "doc", "xls"
IconKey = LCase$(Right$(Filename, 3))
Case Else
IconKey = "Default"
End Select
Me.trvDocs.Nodes.Add FullPath, tvwChild, sd.SubStrings(i), Filename, IconKey
TreeViewExpandUp Me.trvDocs.Object, FullPath
Next i
sbf.Form.Recordset.MoveNext
Loop
End Sub
' Create the folder nodes
Sub CreateFolderNodes(FolderSpec As String)
Dim TopFolder As C_Folder
Dim SubFolder As C_Folder
Set TopFolder = New C_Folder
With TopFolder
.FolderPath = FolderSpec
.MaxPath = 512
.SortMode = cfSortAscending
.ListFiles = False
.Refresh
End With
For Each SubFolder In TopFolder.Folders
Me.trvDocs.Nodes.Add FolderSpec, tvwChild, SubFolder.FolderPath, SubFolder.FolderName, "Folder"
CreateFolderNodes (SubFolder.FolderPath)
Next
End Sub
' Expand treeview folder nodes for just those folders that contain files
Function TreeViewExpandUp(trv As MSComctlLib.Treeview, Key As String)
Dim ParentKey As String
On Error GoTo TreeViewExpandUpErr
trv.Nodes(Key).Expanded = True
ParentKey = trv.Nodes(Key).Parent.Key
Do While trv.Nodes(ParentKey).Index <> 1
trv.Nodes(ParentKey).Expanded = True
ParentKey = trv.Nodes(ParentKey).Parent.Key
Loop
On Error GoTo 0
Exit Function
TreeViewExpandUpErr:
MsgBox Err.Number & Err.Description
End Function
' Handle double click on node
Sub trvDocs_DblClick()
Dim trv As MSComctlLib.Treeview
Dim ChildNode As Object
Dim i As Long
DoCmd.Hourglass True
Set trv = Me.trvDocs.Object
If trv.SelectedItem.Children = 0 Then
ShellExecute vbNull, "", trv.SelectedItem.Key, "", "", SW_SHOWNORMAL
Else
Set ChildNode = trv.SelectedItem.Child
For i = 1 To trv.SelectedItem.Children
ShellExecute vbNull, "", ChildNode.Key, "", "", SW_SHOWNORMAL
Set ChildNode = ChildNode.Next
Next i
End If
trv.SelectedItem.Expanded = True
DoEvents
DoCmd.Hourglass False
End Sub
Sorry for the long post but I can't find an answer anywhere and I really need to get this done
.
