Функция обхода документов-ответов, ответов на ответы и т.д.

[Darker]

В общем код такой, правда там нет проверки на валидность дока:


....

Set col=document.ParentDatabase.GetProfileDocCollection("ProfileNameWitchGiveMeAnEmptyCollection") 'Мне нужна пустая коллекция
GetFamily document, document.Responses ,col 'Собираем "семейку"

Sub GetFamily(d As NotesDocument,c As NotesDocumentCollection, mcol As NotesDocumentCollection)
If mcol.GetDocument(d) Is Nothing Then mcol.AddDocument d
If Cstr(d.~$REF(0))=d.UniversalID Then Exit Sub
If c Is Nothing Then Exit Sub
If c.Count=0 Then Exit Sub
Dim rd As NotesDocument
Set rd=c.GetFirstDocument
For i=1 To c.Count
GetFamily rd,rd.Responses,mcol,form
Set rd=c.GetNextDocument(rd)
Next
End Sub

 

[hosm]

поправьте в рекурсивном вызове GetFamily rd,rd.Responses,mcol,form
или описание ф-ции и ее нерекурсивный вызов выше

 

[TIA]

Darker
Проверку
If Cstr(d.~$REF(0))=d.UniversalID Then Exit Sub
надо делать до
If mcol.GetDocument(d) Is Nothing Then mcol.AddDocument d

Cstr(d.~$REF(0) полностью эквивалентно штатной d.ParentDocumentUnid

Параметр "C" можно убрать, заменив "C" на d.Responses.

"For i" лучше заменить на "while not rd is nothing"

 

[FixeR]

Всем спасибо за инфу.
Использую простенький код:

Function GetFullTree(doc As NotesDocument, coll As NotesDocumentCollection) As NotesDocumentCollection

Dim childs As NotesDocumentCollection
Dim child As NotesDocument

Set childs = doc.Responses

If childs.Count = 0 Then Exit Function

Set child = childs.GetFirstDocument

While Not child Is Nothing
Call coll.AddDocument(child)
Call GetFullTree(child, coll)
Set child = childs.GetNextDocument(child)
Wend

Set GetFullTree = coll

End Function

 

[Darker]

TIA
Погляди
Set rd=rd.Responses.GetfirstDocument
while not rd is nothing
...
Set rd=rd.Responses.GetNextDocument(rd)
wend

здесь rd.Responses будет вызываться rd.Responses.Count-раз
не разумно ли один раз закинуть rd.Responses в c?

Проверку
If Cstr(d.~$REF(0))=d.UniversalID Then Exit Sub
надо делать до
If mcol.GetDocument(d) Is Nothing Then mcol.AddDocument d

Но, тогда косячный документ не попадет в коллекцию. А он мне нужен для сведения, каким косячным он не был

 

[lmike]

Darker

не разумно ли один раз закинуть rd.Responses в c?

даже если это ф-ция, в скриптовых языках, ВМ оптимизирует код - выигрыша, практически, не будет (или вовсе не будет)
экономию по памяти может дать убиение "старой" ссылки на объект
Set tmp=rd
Set rd=rd.Responses.GetNextDocument(rd)
Delete tmp

 

[TIA]

здесь rd.Responses будет вызываться rd.Responses.Count-раз
не разумно ли один раз закинуть rd.Responses в c?

Не разумно передавать "C" через параметр, именно это я имел в виду. А присвоить локальной переменной очень даже разумно.
Погляди
Set с=rd.Responses
Set rd=с.GetfirstDocument
while not rd is nothing
...
Set rd=rcGetNextDocument(rd)
wend

А он мне нужен для сведения, каким косячным он не был

Прикольно! Ну тогда правильно.

 

[VladSh]

Тут ошибка стала сыпаться 'Out of stack space'. Оказалось что рекурсия выполняется 58 раз, а на 59-м заваливается.
Была местная примитивная функция получения всей иерархии ответов, её и перепилил:

%REM
    Function <b>GetAllResponses</b>
    Description: получение всей иерархии ответов переданного документа
        алгоритм без использования рекурсии
    <br>
    <b>Параметры:</b>
    <b>ndBase</b> - документ
    <b>iErrGen</b> - параметр управления генерацией ошибок; возможные значения:
        • 0 - не генерировать никаких ошибок;
        • 1 - генерировать только критические ошибки, остальные игнорируются одновременно с выходом из функции;
        • 2 - генерировать любые ошибки
    <br>
    <b>Функция возвращает:</b>
    <b>• Nothing - при наличии ошибок при работе функции, но отсутствии их генерации (чтобы извне м.б. понять, что что-то всё-таки не так)
    <b>• NotesDocumentCollection</b> - коллекцию документов в случае отсутствия ошибок
    <b>Критические ошибки:</b>
        • 4189 - документ является ответом к самому себе либо зацикленная иерархия
    <b>Некритические ошибки:</b>
        • 91 - при ndBase = Nothing
        • 4410 - при отсутствии доступа к ndBase
        • 4434 - если ndBase является удалённым
        • 4696 - при ndBase.Responses = Nothing
%END REM
Function GetAllResponses(ndBase As NotesDocument, iErrGen As Integer) As NotesDocumentCollection
    On Error GoTo ErrH
    Const ErrObjectVariableNotSet = 91
    Const lsERR_LSXUI_DOC_OBJ_NOT_VALID = 4410
    Dim ndcResp As NotesDocumentCollection, ndcProc As NotesDocumentCollection
    Dim ndResp As NotesDocument
   
    If ndBase Is Nothing Then
        If iErrGen <> 2 Then Exit Function
        Error ErrObjectVariableNotSet, "В функцию передан неинициализированный объект ndBase!"
    End If
    If Not ndBase.IsValid Then
        If iErrGen <> 2 Then Exit Function
        Error lsERR_LSXUI_DOC_OBJ_NOT_VALID, "Отсутствует доступ к документу " + ndBase.UniversalID
    End If
    If ndBase.IsDeleted Then
        If iErrGen <> 2 Then Exit Function
        Error lsERR_NOTES_DOCUMENT_DELETED, "Документ " + ndBase.UniversalID + " был удалён"
    End If
   
    Dim ndb As NotesDatabase
    Set ndb = ndBase.ParentDatabase
    Dim ndcResult As NotesDocumentCollection
    Set ndcResult = ndb.CreateDocumentCollection()
   
    Set ndcResp = ndBase.Responses
    If ndcResp Is Nothing Then
        If iErrGen <> 2 Then Exit Function
        Error lsERR_NOTES_DOCUMENTCOLLECTION_MISSING, "Документ " + ndBase.UniversalID + " повреждён либо ко всем его ответам у <" + ndb.Parent.UserName + "> нет доступа"
    End If
   
    If ndcResp.Count > 0 Then
        'очередь обработки
        Dim lstQueue List As NotesDocumentCollection
        'счётчик коллекций для обработки
        Dim iQCount As Integer
        'тег (UNID) документа, по которому сохраняются коллекции в очередь, и из которого будут удаляться уже отработанные
        Dim sQTag As String
       
        Set lstQueue(ndBase.UniversalID) = ndcResp
        iQCount = 1
       
        Do
            ForAll ndc In lstQueue
                sQTag = ListTag(ndc)
               
                'обработка единичного документа
                Set ndResp = ndc.GetFirstDocument()
                While Not ndResp Is Nothing
                   
                    'добавляем документ в результирующую коллекцию
                    Call ndcResult.AddDocument(ndResp)
                   
                    'добавляем коллекцию его ответов в очередь обработки
                    Set ndcResp = ndResp.Responses
                    If ndcResp.Count > 0 Then
                        If ndResp.UniversalID = ndcResp.GetFirstDocument().UniversalID Then
                            If iErrGen = 0 Then Exit Function
                            Error lsERR_NOTES_RESPONSE_FAILED, "Документ " + ndResp.UniversalID + " является ответным к самому себе"    'см. $REF
                        End If
                        Set lstQueue(ndResp.UniversalID) = ndcResp
                        iQCount = iQCount + 1
                    End If
                   
                    Set ndResp = ndc.GetNextDocument(ndResp)
                Wend
               
                'убираем текущую коллекцию из очереди обработки
                Erase lstQueue(sQTag)
                iQCount = iQCount - 1
            End ForAll
           
            If iQCount = 0 Then Exit Do
        Loop
    End If
   
    Set GetAllResponses = ndcResult
Quit:
    Exit Function
   
ErrH:
    Select Case Err
        Case lsERR_NOTES_ADDDOC_DUP:
            'Ошибка при повторном добавлении документа в коллекцию
            If iErrGen = 0 Then Resume Quit
            Error lsERR_NOTES_RESPONSE_FAILED, "Зацикленная иерархия! Документ " + ndResp.UniversalID
    End Select
    Error Err, GetThreadInfo(1) & { (} & Erl & {) -> } + Error$
End Function

Как-то так...