вторник, 28 февраля 2017 г.

Создание каталога по переданному пути

%REM
Function CreateFolder
Description: Функция создает каталог из параметра, указанного в функции
Каталог создается вне зависимости от того, существует ли папка верхнего уровня или нет.
        То есть, если передается для создания каталог c:\folder\subf1\subf2, то он будет создан вне зависимости от того, существуют ли каталоги subf1 и folder.
Работает только под ОС Windows так как использует возможности Windows Script Host.
Возвращает:
- 0, если произошла ошибка при создании каталога
- 1, если каталог создан
%END REM
Function CreateFolder(pathtodir As string)
CreateFolder=0
Dim FSO
Dim drive As String
Dim relativepath As String
Dim arraypath
Dim i As Integer
Dim bound As Integer

On Error GoTo ErrH

Set FSO = CreateObject("Scripting.FileSystemObject")
arraypath = Split(pathtodir, "\")
bound = UBound(arraypath)
drive = arraypath(0)
relativepath=""
For i%=1 To bound
relativepath = relativepath + arraypath(i)
If FSO.FolderExists(drive + "\" + relativepath)=False Then
Call FSO.CreateFolder(drive + "\" + relativepath)
End If
relativepath = relativepath + "\"
Next
CreateFolder=1
ExitOfSub:
Exit function
ErrH:
Resume ExitOfSub
End Function

пятница, 27 января 2017 г.

Безопасное удаление из коллекции документов в цикле

Sub Initialize
    
    Dim s As New NotesSession
    Dim db As NotesDatabase       
    Dim doc1 As NotesDocument
    Dim doc2 As NotesDocument
    Set db = s.currentdatabase
    Dim col As NotesDocumentCollection   
    Set col = db.AllDocuments
    Set doc1 = col.getfirstdocument
    
    Do Until (doc1 Is Nothing)
         '... Делаем что-то с документом doc1... 
         Set  doc2 =   col.getnextdocument(doc1)         
         Call doc1.remove(True)
         Set doc1 = doc2
    Loop
    
End Sub

среда, 25 января 2017 г.

Копирование документа через копирование полей

Код агента, который сначала создает документ и копирует в него поочередно поля из исходного документа. Копируются все поля кроме полей с типом RichText и SIGNATURE.
:

Sub Initialize
Dim recCol As NotesDocumentCollection
Dim doc As NotesDocument
Dim newDoc As NotesDocument

Dim ErrByName As string
Dim ErrByTypeItem As Long

Dim s As New NotesSession
Dim db As NotesDatabase

Dim ws As NotesUIWorkspace
Dim uivw As NotesUIView

Set db = s.CurrentDatabase

Set ws = New NotesUIWorkspace
Set uivw = ws.CurrentView
Set recCol = uivw.Documents
'<если в представлении нет выделенных документов галкой>
If recCol.Count = 0 Then
If uivw.CaretNoteID <> "0" Then
Set doc = db.GetDocumentByID(uivw.CaretNoteID)
If Not doc Is Nothing Then
Call recCol.AddDocument(doc)
End If
End If
End If
'<если в представлении нет выделенных документов галкой>

If recCol.Count = 0 Then
MsgBox "Не выбран ни один документ!"
Exit Sub
End If

If recCol.Count<>1 Then
MsgBox "Можно выделять только один документ!"
Exit Sub
End If

Set doc = recCol.Getfirstdocument()

Set newDoc = doc.Parentdatabase.Createdocument()

On Error GoTo ErrH

Dim i As Integer
i=0
ForAll ni In doc.Items
i=i+1
If ni.Type<>8 And ni.Type<>1 Then
Call newDoc.Replaceitemvalue(ni.Name, doc.Getitemvalue(ni.Name))

If ni.Type<>1 Then
ErrByName=ni.Name
ErrByTypeItem=ni.Type
End If
End If
End ForAll

Call newDoc.Save(True, False)

MsgBox "Копирование документа завершено!"
EndOfSub:
Exit sub
ErrH:
MsgBox cstr(Err) + " в строке " + CStr(Erl) + Chr(13) + "Ошибка: " + Error$ + Chr(13) + _
"Имя поля: " + ErrByName + Chr(13) + "Количество пройденных итемов=" + CStr(i) + Chr(13) +_
"Тип поля=" + CStr(ErrByTypeItem)
Resume EndOfSub
End Sub