@Axel:
Du hast es nicht anders gewollt
:
Hier ist der Code:
----------------
Option Public
Option Declare
Use "actdb"
Use "Konfig"
Use "administrator"
Use "DocReport"
Sub Initialize
Dim oA As New actdb, oTarget As notesdatabase, otarget2 As notesdatabase,oSource As notesdatabase, oD1 As notesdocument, oD2 As notesdocument, kdoc As notesdocument
Set kdoc = oa.markiert.getfirstdocument
Dim xServer As String
Dim xDB As String
Dim aDa As Variant
Dim session As New notessession
Dim db As notesdatabase
Set db = session.currentdatabase
Dim Vanwendung As notesview
Set Vanwendung = db.getview("Datenbanken")
Call vanwendung.refresh
Dim Adoc As notesdocument
Dim xDbAlt As String
Dim xServerAlt As String
Dim x As Integer
Dim count As Integer
Dim max As Integer
count = oa.markiert.Count
max = count
Do While Not kDoc Is Nothing
count = prot_status(count,max)
If kdoc.form(0) = "_DA_MULTI" Then
Set adoc = vanwendung.GetFirstDocument
x = 1
Else
Set adoc = vanwendung.getdocumentbykey(kdoc.daAnwendung(0))
x = 1
End If
Do While x = 1
If Not adoc Is Nothing Then
xServer = adoc.zserver(0)
xDb = adoc.ZDateiname(0)
If xdbalt <> xdb Or xServerAlt <> xServer Then
Set oTarget = New notesdatabase(xServer, xDb)
xDbAlt = xDb
xServerAlt = xServer
' Print "writing into : ' "+xServerAlt+ "/"+xdbalt+"'"
End If
If xadmin(otarget,1) Then
Call writeback(kDoc, oTarget)
If kdoc.form(0) = "K99" Then ' prüfen ob auch zurückschreiben in Archivzugang
Set otarget2 = New notesdatabase(kdoc.archivAccessServer(0),kdoc.archivAccessPfad(0))
If Not otarget2 Is Nothing Then
If otarget2.isopen Then
Call writeback(kDoc, oTarget2)
End If
End If
End If
Else
Beep
Beep
Beep
' Print "no access to: ' "+xServerAlt+ "/"+xdbalt+"'"
End If
Else
Beep
' Print "Can not locate configuration document for: ' "+Kdoc.daAnwendung(0)+"'"
End If
If kdoc.form(0) = "_DA_MULTI" Then
Set adoc = vanwendung.getnextdocument(aDoc)
If adoc Is Nothing Then
x = 0
End If
Else
x = 0
End If
Loop
Set kdoc = oa.markiert.getnextdocument(kDoc) ' hier popt der Fehler auf 
Loop
End Sub
----------------------------------
Sub writeback(kDoc As notesdocument, oTarget As notesdatabase)
Dim cProfile As String, cUser As String, iPos As Integer, pDoc As notesdocument
Dim xnummer As Variant
Dim was As String
If kDoc.hasitem("$Name") Then
cProfile = Mid$(kDoc.getitemvalue("$Name")(0),13)
iPos = Instr(1,cProfile,"_")
If iPos > 0 Then
If iPos < Len(cProfile) Then
cUser = Mid$(cProfile, iPos+1)
End If
If cuser = "da_multi_" Then
cuser = ""
cprofile = "_DA_MULTI"
Else
cProfile = Left$(cProfile,iPos-1)
If cuser <> "" Then
' Print "User: "+cUser
was = "DA_USER"
Else
' Print "Profile: "+cProfile
was = "DA_PROFILE"
End If
End If
Do While True
If cUser <> "" Then
Set pDoc = oTarget.getprofiledocument(cProfile, cUser)
Else
Set pDoc = oTarget.getprofiledocument(cProfile)
End If
If pDoc.hasitem("Form") Then
If Datatype(pdoc.dvnummer(0) ) <> 8 Then
xnummer = pdoc.DvNummer(0)
Else
xnummer = 0
End If
Forall xitem In pdoc.items
Call xitem.remove
End Forall
Exit Do
Else
Exit Do
End If
Loop
Call kDoc.copyallitems(pDoc,True)
If was = "DA_PROFILE" Then 'Konfigurationsdokument
Call pdoc.replaceitemvalue("dvnummer", xnummer)
End If
Call pDoc.save(True,False)
End If
End If
End Sub
--------------------------------------
Class actDb
Public oSes As notessession
Public oDb As notesdatabase
Public oWork As notesuiworkspace
Public oDoc As notesuidocument
Sub new
Set Me.oSes = New notessession
Set Me.oDb = Me.oSes.currentdatabase
Set Me.oWork = New notesuiworkspace
Set Me.oDoc = Me.oWork.currentdocument
End Sub
Function db As notesdatabase
Set db = Me.oDb
End Function
Function dok As notesuidocument
Set dok = Me.oDoc
End Function
Function markiert As NotesDocumentCollection
Set markiert = oDb.unprocessedDocuments
End Function
Function AktDok As notesdocument
If Me.oDoc Is Nothing Then 'Wenn nicht Dokument geöffnet
REM Achtung, funktioniert nur im View ohne markierte Dokumente
Set AktDok = Me.markiert.getfirstdocument
Else
Set AktDok = Me.oDoc.document
End If
End Function
Function version As String
version = Trim(Mid$(oSes.notesversion,9))
End Function
Function currentname As notesname
Set currentname = New notesname(oSes.username)
End Function
End Class
----------------------
Ich denke das sind alle rellevanten Teile
Gruß
Hitcher
Thema: R4-Script funktioniert nicht in R5 ? (Gelesen 2023 mal)