D
deeeman
Добрый день!
нужно просканировать все базы на серверах и сделать логи по пользователям кто какие права на базы имеет.
соответсвенно есть настройка серверов
так же есть настройка папок (чтобы определять почтовая это база или нет)
НО! есть базы в которые нет доступа, мне их надо пропускать, но не получается...
какие то базы проскакивает а на каких то все равно валиться с ошибкой 4060
вот код, подскажите что не так?
нужно просканировать все базы на серверах и сделать логи по пользователям кто какие права на базы имеет.
соответсвенно есть настройка серверов
так же есть настройка папок (чтобы определять почтовая это база или нет)
НО! есть базы в которые нет доступа, мне их надо пропускать, но не получается...
какие то базы проскакивает а на каких то все равно валиться с ошибкой 4060
вот код, подскажите что не так?
Код:
Option Public
Option Declare
Dim db As NotesDatabase
Dim keyView As NotesView
Dim ScanDb As NotesDatabase
Sub Initialize
On Error GoTo ErrSub
'On Error Resume next
Dim agentName As String
agentName = "getLogs2"
MsgBox agentName + " Start!"
Dim s As New NotesSession
Dim i As Integer
Dim msg As String
Dim SetView As NotesView
Dim SetDoc As NotesDocument
Dim profDoc As NotesDocument
Dim directory As NotesDbDirectory
Dim flagEx As Boolean
Dim owner As String
Dim level As Integer
Dim StrFormula As String
Dim namesDb As NotesDatabase
Dim namesDC As NotesDocumentCollection
Dim namesDoc As NotesDocument
Dim maildblist() As String
Dim dblist() As String
Dim serverDSP As string
Dim pDoc As NotesDocument
Set db = s.Currentdatabase
Set SetView = db.Getview("Settings")
Set keyView = db.Getview("PersonLogByKey")
Set SetDoc = SetView.Getfirstdocument()
If SetDoc Is Nothing Then
MsgBox "Не найдена настройка!"
GoTo EndSub
End If
Set pDoc = keyView.Getfirstdocument()
While Not pDoc Is Nothing
Call pDoc.Removeitem("MailDBList")
Call pDoc.Removeitem("DBList")
Call pDoc.save(True,true)
Set pDoc = keyView.Getnextdocument(pDoc)
Wend
Set namesDb = s.Getdatabase(db.server,"names.nsf")
StrFormula = {form = "Person" & @LowerCase(CompanyName) = "} & LCase(SetDoc.Getitemvalue("Company")(0)) & {"}
Set namesDC = namesDb.Search(StrFormula,Nothing,0)
If namesDC.Count > 0 Then
Set namesDoc = namesDC.Getfirstdocument()
While Not namesDoc Is Nothing
ReDim maildblist(0)
ReDim dblist(0)
'создаем\обновляем карточку лога сотрудника
Set pDoc = CreatePersonLog(namesDoc.Getitemvalue("Owner")(0))
If pDoc Is Nothing Then GoTo nextP
ForAll server In SetDoc.Getitemvalue("Servers_1")
If InStr(server,"/") > 0 then
serverDSP = StrLeft(server,"/")
Else
serverDSP = server
End if
ForAll folder In SetDoc.Getitemvalue("Folders_1")
Set directory = s.GetDbDirectory(server)
Set ScanDb = directory.GetFirstDatabase(DATABASE)
While Not ScanDb Is Nothing
level = 0
If UCase(StrLeft(Replace(ScanDb.Filepath,"/","\"),"\")) = UCase(folder) Then 'почта
Set ScanDb = s.Getdatabase(server,ScanDb.Filepath)
If Not ScanDb Is Nothing Then
If ScanDb.Filepath = "" Then GoTo nextdb
msg = ScanDb.Filepath
level = ScanDb.QueryAccess(namesDoc.Getitemvalue("Owner")(0))
End If
ReDim Preserve maildblist(UBound(maildblist)+1)
maildblist(UBound(maildblist)) = ScanDb.Title & "~~" & ScanDb.Filepath & " (" & (serverDSP) & ")" & "~~" & CStr(level)
Else 'не почтовая бд
Set ScanDb = s.Getdatabase(server,ScanDb.Filepath)
If Not ScanDb Is Nothing Then
If ScanDb.Filepath = "" Then GoTo nextdb
level = ScanDb.QueryAccess(namesDoc.Getitemvalue("Owner")(0))
msg = ScanDb.Filepath
End If
ReDim Preserve dblist(UBound(dblist)+1)
dblist(UBound(dblist)) = ScanDb.Title & "~~" & ScanDb.Filepath & " (" & (serverDSP) & ")" & "~~" & CStr(level)
End If
nextdb:
Set ScanDb = directory.Getnextdatabase
Wend
End ForAll
End ForAll
nextP:
Call pDoc.Replaceitemvalue("MailDbList", ArrayUnique(FullTrim(maildblist)))
Call pDoc.Replaceitemvalue("DbList", ArrayUnique(FullTrim(dblist)))
Call pDoc.save(True,true)
Set namesDoc = namesDC.Getnextdocument(namesDoc)
Wend
End If
MsgBox agentName + " Finish!"
EndSub:
Exit Sub
ErrSub:
If Err = 4060 Then GoTo nextdb
MsgBox "Error (" & Err() & ") in " & agentName & " at line " & Erl() & ": " & Error()
Resume EndSub
End Sub
Function createPersonLog(lotusName As String) As NotesDocument
On Error GoTo ErrSub
'On Error Resume next
Dim agentName As String
agentName = "getLogs2/createPersonLog"
Dim logDoc As NotesDocument
Set logDoc = keyView.getdocumentbykey(lotusName)
If logDoc Is Nothing Then
Set logDoc = db.Createdocument()
Call logDoc.Replaceitemvalue("Form","PersonLog")
Call logDoc.Replaceitemvalue("NotesName",lotusName)
Call logDoc.Replaceitemvalue("MailDBList","")
Call logDoc.Replaceitemvalue("DBList","")
Call logDoc.save(True,True)
End If
Set createPersonLog = logDoc
EndSub:
Exit Function
ErrSub:
MsgBox "Error (" & Err() & ") in " & agentName & " at line " & Erl() & ": " & Error()
Resume EndSub
End Function