29. oktober 2009 - 11:08
#1
Hej,
Vi har i Postopen på nogle databaser et kald til en agent som automatisk repliker deres database. Hvis de ikke har gjort det i x antal dage får de en besked om at de skal oprette en ny replika.
Her er koden - håber du kan blive inspireret:
Initialize:
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Dim purgeinterval As Long
Dim msgstr As String, strList As String, sbjstr As String
Dim dspName As String, strAcctUser As String
Dim valuelist As Variant
Dim sName As String
purgeinterval = 10
sName = db.Server
np$ = Space(1024)
' Declaring space for the path of notes
OSPathNetConstruct 0, db.Server, db.FilePath, np$
Dim hDB As Long
Dim dt2 As Long
Dim T As Long
Dim rc%
Dim tod As Long
Dim hS As Long
Dim init As Long
Dim time_delta As Long
Dim repdate As Long
Dim repage As Long
Dim repinfo As RepInfoClass
Dim turnoffrep As Integer
dt2 = 3888000
NSFDbOpen np$, hDB
If hDB = 0 Then Exit Sub
tod = Today()
NSFDbGetReplHistorySummary hDB, 2, hS, nE&
If Not hS = 0 Then
p& = OSLockObject(hS)
For i& = p& To p& Step 30
dt$ = Space(80)
ConvertTIMEDATEToText 0, 0, i&, dt$, 80, nd%
dt$ = Left$(dt$, nd%)
repdate = Cdat(dt$)
Peek a%, i& + 8, 2
Peek f%, i& + 10, 2
Peek d%, i& + 12, 2
Select Case d%
Case 0 : dn$ = "Never"
Case 1 : dn$ = "Send"
Case 2 : dn$ = "Receive"
Case Else : dn$ = "Unknown (" & Cstr(d%) & ")"
End Select
Peek o&, i& + 14, 4
Peek ns%, i& + 18, 2
Peek nf%, i& + 20, 2
sv$ = Space(ns%)
'determine replica age
RepAge = tod-repdate + 1
ConvertTIMEDATEToText 0, 0, i&, dt$, 80, nd%
If repage > purgeinterval Then
' If repage > 1 Then 'for testing purposes ONLY
Set Repinfo = New RepInfoClass(db)
turnoffrep = repinfo.SetDisableReplica(REPLFLG_DISABLE)
Messagebox "You last replicated on " & dt$ & Chr(13)_
& "WARNING! Your local copy has been identified as" & Chr(13)_
& "being out of date and will not replicate back to the server. " &)
Else
Call db.Replicate( sName )
End If
Next
OSUnlockObject hS
OSMemFree hS
End If
NSFDbClose hDB
------------
Declaration:
Const wAPIModule = "NNOTES" ' Windows/32
Const CLASS_ABOUT = &H0002
Const CLASS_USING = &H0100
Const REPLFLG_DISABLE = 4
Const INFO_CLASS = 3
Const CLASS_DEFAULT = &H8000
Type TIMEDATE
Innards1 As Long
Innards2 As Long
End Type
Type dbReplicaInfo
id As timeDate
flags As Integer
cutoffInterval As Integer
cutoff As timeDate
End Type
Declare Function ConvertTIMEDATEToText Lib wAPIModule Alias "ConvertTIMEDATEToText" _
( Byval zI As Long, Byval zT As Long, Byval T As Long, Byval S As String, Byval nS As Integer, nT As Integer) As Integer
Declare Function ConvertTextToTIMEDATE Lib wAPIModule Alias "ConvertTextToTIMEDATE" _
( Byval zI As Long, Byval zT As Long, pS As Long, Byval nS As Integer, Byval T As Long) As Integer
Declare Private Function NSFDbOpen Lib wAPIModule Alias "NSFDbOpen" _
( Byval P As String, hDB As Long) As Integer
Declare Private Function NSFDbClose Lib wAPIModule Alias "NSFDbClose" _
( Byval hDB As Long) As Integer
Declare Private Function NSFDbGetReplHistorySummary Lib wAPIModule Alias "NSFDbGetReplHistorySummary" _
( Byval hDB As Long, Byval F As Long, hS As Long, N As Long) As Integer
Declare Private Function OSMemFree Lib wAPIModule Alias "OSMemFree" _
( Byval hM As Long) As Integer
Declare Private Function OSLockObject Lib wAPIModule Alias "OSLockObject" _
( Byval hM As Long) As Long
Declare Private Sub OSUnlockObject Lib wAPIModule Alias "OSUnlockObject" _
( Byval hM As Long)
Declare Private Function OSPathNetConstruct Lib wAPIModule Alias "OSPathNetConstruct" _
( Byval zP As Long, Byval S As String, Byval F As String, Byval P As String) As Integer
Declare Function NSFDbReplicaInfoGet Lib wAPIModule Alias "NSFDbReplicaInfoGet"_
(Byval hdb As Long, retBuf As dbReplicaInfo) As Integer
Declare Function NSFDbReplicaInfoSet Lib WAPIModule Alias "NSFDbReplicaInfoSet"_
(Byval hdb As Long, inpBuf As dbReplicaInfo) As Integer
Declare Private Sub Peek Lib "MSVCRT" Alias "memcpy" _
( D As Any, Byval P As Long, Byval N As Long)
Declare Private Sub PeekString Lib "MSVCRT" Alias "memcpy" _
( Byval D As String, Byval P As Long, Byval N As Long)
Declare Private Sub PokeString Lib "MSVCRT" Alias "memcpy" _
( Byval D As Long, Byval S As String, Byval N As Long)
Class RepInfoClass
Private hDb As Long
Private retReplicationInfo As DBREPLICAINFO
Private prvdb As NotesDatabase
Private flgDBExist As Integer
Sub Delete
If hDb <> 0 Then Call NSFDbClose(hDb)
End Sub
Sub New (inpNotesDatabase As NotesDatabase)
Dim sDatabase As String
Dim uaesession As New notessession
Dim rc As Integer
Me.flgDBExist = False
'Get a valid NotesDatabase to the specified database
If inpNotesDatabase Is Nothing Then
Error 14104, "NotesUserActivity: Database Object is invalid"
Exit Sub
End If
Set prvdb = New NotesDatabase(inpNotesDatabase.Server, inpNotesDatabase.FilePath)
If (prvdb.Server = "") Or (uaesession.IsOnServer) Then
sdatabase = prvdb.filepath
Else
sdatabase = prvdb.server + "!!" + prvdb.filepath
End If
'Open the target database
rc = NSFDbOpen(sDatabase,Me.hDb)
If rc <> 0 Then
Me.flgDBExist = False
End If
'Set the Replica information
rc = NSFDbReplicaInfoGet(Me.hDb, Me.retReplicationInfo)
If rc <> 0 Then
Me.flgDBExist = False
End If
Me.flgDBExist = True
End Sub 'End of open sub
Public Function DBExist As Integer
DBExist = Me.flgDBExist
End Function
Public Function Parent As NotesDatabase
Set Parent = prvdb
End Function
Public Function SetDisableReplica(sFlag As Integer) As Integer
Dim puActivity As Long
If Not Me.flgDBExist Then
Error 14104, "Notes DB not opened"
SetDisableReplica = False
Exit Function
End If
'*** this is where the replication flag is set to not to replicate
Me.retReplicationInfo.flags = &H4
rc = NSFDbReplicaInfoSet(Me.hDb,Me.retReplicationInfo)
If rc <> 0 Then
Me.flgDBExist = False
End If
End Function
End Class
