title image

Smiley Re: Pfad in eine Scriptvariable schreiben
Versuchs mal damit !

Ich habs als Agent auf ausgewählte Dokumente in meiner Mail-Box implementiert.

Source ist nicht von mir sondern hab ich bei Wolfgang FLAMME gefunden.


'Anhänge lösen, löschen Datei-Link erstellen:

Option Public

Option Declare

%INCLUDE "lsconst.lss"

%INCLUDE "lserr.lss"


These declarations are in support of the MSWindows APIs that are used by this

agent. This means that this agent will only work on Win32 clients.


Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (Byval hwndOwner As Long, _

Byval nFolder As Long, ppidl As Long) As Long



hwndOwner As Long

pidlRoot As Long

pszDisplayName As String

lpszTitle As String

ulFlags As Long

lpfn As Long

lParam As Long

iImage As Long

End Type

Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _

(lpbi As BROWSEINFO) As Long

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _

(Byval pidl As Long, Byval pszPath As String) As Long

Declare Sub CoTaskMemFree Lib "ole32.dll" (Byval pv As Long)

' Returns a file-path in the older DOS 8.3 notation without spaces

Declare Function GetShortPathNameA Lib "kernel32" (Byval lpszLongPath As String,_

Byval lpszShortPath As String, Byval cchBuffer As Long) As Long


Other global variables


Public Const ENV_FOLDER_LOCATION = "DRL_FolderLocation"

Sub Initialize

Dim session As New NotesSession

Dim ws As New NotesUIWorkspace

Dim view As NotesUIView

Dim doc As NotesDocument

Dim db As NotesDatabase

Dim dc As NotesDocumentCollection

Dim counter As Integer 'attachment counter

Dim iDocsProcessed As Integer 'processed message counter

Dim dupc As Integer 'duplicated filenames counter

Dim strDetachFolder As String 'receives name of temporary file path

Dim strMessage As String

Dim lBoxType As Long

Dim iErr As Integer

Dim iTaskId As Integer

Dim iTotalAttachments As Integer

Dim iNumDocAttachments As Integer

Dim iTotalDocuments As Integer

Dim iPercentCompleted As Integer

' General errors get trapped here

On Error Goto HandleError

' This on error traps the error that results when the agent attempts to

' open the collection from within a document rather than a view

On Error ErrObjectVariableNotSet Goto NoSelected

' Ensure we are using windows 32... if not then say goodbye.

If session.Platform "Windows/32" Then

strMessage = "Leider nur für Windows/32 Betriebssysteme geeignet !"


Messagebox strMessage, lBoxType, "Achtung"

Exit Sub

End If

' Do some initial stuff to make sure we are in a view and at least

' one document is selected before we go to the trouble of asking

' the user anything

Set db = session.CurrentDatabase

Set view = ws.CurrentView

' This statement will produce an error if the user is currently in a document

' rather than the view.

Set dc = view.Documents

'if no document selected

If dc.Count < 1 Then

strMessage = "Sie müssen zumindest ein Dokument wählen !"


Messagebox strMessage, lBoxType, "Achtung"

Exit Sub

End If

' Get the folder to detach attachments into

If Not fGetDetachFolder(session, strDetachFolder) Then

Exit Sub

End If

iTotalDocuments = dc.Count

iDocsProcessed = 0

Set doc = dc.GetFirstDocument

While Not doc Is Nothing

iDocsProcessed = iDocsProcessed + 1

'detach each attachment

iNumDocAttachments = fDetachRemoveAndLink(session, doc, strDetachFolder)

iTotalAttachments = iTotalAttachments + iNumDocAttachments

iPercentCompleted = Int((iDocsProcessed / iTotalDocuments) * 100)

Print Cstr(iDocsProcessed) & " von " & Cstr(iTotalDocuments) & _

" (" & Cstr(iPercentCompleted) & "%)"

Set doc = dc.GetNextDocument(doc)


strMessage = Cstr(iDocsProcessed) & " Dokumente verarbeitet." & Chr(10) & _

"Insgesamt sind " & Cstr(iTotalAttachments) & Chr(10) & _

"Anhänge in folgendes Verzeichnis gelöst worden: " & strDetachFolder

lBoxType = MB_OK

Messagebox strMessage, lBoxType, "Beendet!"

Call ws.ViewRefresh( )

Exit Sub


iErr = Err()

strMessage = "Bitte stellen sicher, das der Ordner: " & strDetachFolder & " angelegt ist."


Messagebox strMessage, lBoxType, "Achtung"

Exit Sub


iErr = Err()

strMessage = "Die Ausführung dieses Agenten ist nur in einer Ansicht möglich!" & _

Chr(13) & "Verwenden Sie Datei Anhang lösen um dies in einem Dokument zu bewerkstelligen!"


Messagebox strMessage, lBoxType, "Achtung"

Exit Sub

End Sub

Function fGetShortPathName(longpath As String) As String

Dim s As String

Dim i As Long

i = Len(longpath) + 1

s = String(i, 0)

GetShortPathNameA longpath, s, i

fGetShortPathName = Left$(s, Instr(s, Chr$(0)) - 1)

End Function

Function fGetFolderLocation() As String

Dim bi As BROWSEINFO ' structure passed to the function

Dim pidl As Long ' PIDL to the user's selection

Dim physpath As String ' string used to temporarily hold the physical path

Dim retval As Long ' return value

Dim vbNullChar As String

vbNullChar = Chr(0)

' Initialize the structure to be passed to the function.

' The owner of the dialog box.

bi.hwndOwner = 0

' Specify the My Computer virtual folder as the root.

retval = SHGetSpecialFolderLocation(0, CSIDL_DRIVES, bi.pidlRoot)

' Make room in the buffer to get the [virtual] folder's display name.

bi.pszDisplayName = Space(260)

' Message displayed to the user.

bi.lpszTitle = "Please choose a folder."

' Nothing else needs to be set.

bi.ulFlags = 0

bi.lpfn = 0

bi.lParam = 0

bi.iImage = 0

' Open the Browse for Folder dialog box.

pidl = SHBrowseForFolder(bi)

' If the user selected something, display its display name

' and its physical location on the system.

If pidl 0 Then

'Remove the empty space from the display name variable.

bi.pszDisplayName = Left(bi.pszDisplayName, Instr(bi.pszDisplayName, vbNullChar) - 1)

'Debug.Print "The user selected: "; bi.pszDisplayName

'If the folder is not a virtual folder, display its physical location.

physpath = Space(260)

retval = SHGetPathFromIDList(pidl, physpath)

If retval = 0 Then

'Debug.Print "Physical Location: (virtual folder)"


' Remove the empty space and display the result.

physpath = Left(physpath, Instr(physpath, vbNullChar) - 1)

'Debug.Print "Physical Location: "; physpath

End If

' Free the pidl returned by the function.

CoTaskMemFree pidl

End If

' Whether successful or not, free the PIDL which was used to

' identify the My Computer virtual folder.

CoTaskMemFree bi.pidlRoot

' Return the physpath value

fGetFolderLocation = physpath

End Function

Function fGetDetachFolder(session As NotesSession, strDetachFolder As String) As Variant

On Error Goto HandleError

Dim strMessage As String

Dim lBoxType As Long

Dim lAnswer As Long

fGetDetachFolder = False

'get current saved folder

strDetachFolder = session.GetEnvironmentString( ENV_FOLDER_LOCATION )

'if the folder doesn't exist, show folder location window.

If Isempty(strDetachFolder) Or Len(strDetachFolder) < 2 Then

strDetachFolder = fGetFolderLocation()

If Len(strDetachFolder) < 2 Then

Exit Function

End If

'save strDetachFolder in to .ini

Call session.SetEnvironmentVar( ENV_FOLDER_LOCATION, strDetachFolder )


'check the existance of the current folder, if it doesn't exist, prompt.

If fFileExists(strDetachFolder) Then

strMessage = "Derzeit gewähltes Verzeichnis: "& strDetachFolder & " nicht vorhanden"


Messagebox strMessage, lBoxType, "Verzeichnis für Anhänge"

lAnswer = IDNO


strMessage = "Wollen Sie " & strDetachFolder & " verwenden ?"


lAnswer = Messagebox(strMessage, lBoxType, "Verzeichnis für Anhänge")

End If

'if no current default folder, prompt for folder location window.

If lAnswer = IDNO Then

strDetachFolder = fGetFolderLocation()

'if the input string less than 2-character, stop

If Len(strDetachFolder) < 2 Then

Exit Function

End If

'save strDetachFolder in to .ini

Call session.SetEnvironmentVar( ENV_FOLDER_LOCATION, strDetachFolder )

End If

End If

fGetDetachFolder = True

Exit Function


strMessage = "Error in fGetDetachFolder: (" & Err & ") " & Error & " at line: " & Erl


Messagebox strMessage, lBoxType, "Fehler !"

Exit Function

End Function

Function fDetachRemoveAndLink(session As NotesSession, doc As NotesDocument, _

strDetachFolder As String) As Integer

On Error Goto HandleError

Dim objAttachment As NotesEmbeddedObject

Dim rtStyleText As NotesRichTextStyle

Dim rtStyleSep As NotesRichTextStyle

Dim rtStyleLink As NotesRichTextStyle

Dim rtitem As Variant

Dim iCounter As Integer

Dim strExtractName As String

Dim strPath As String

Dim lAnswer As Long

Dim iFilenum As Integer

Dim lBoxTYpe As Long

Dim strMessage As String

Dim strNewLink As String

Dim strNamePart As String

Dim strExtPart As String

fDetachRemoveAndLink = 0

iCounter = 0

' Look for rich text items in the document. Use the first rich text

' item found for rtitem - unless we find one named "Body" which will

' supercede any rich text item found thus far.

' If we don't find a rich text item then quit out of this document

Set rtitem = Nothing

Forall item In doc.Items

If item.Type = RICHTEXT Then

If rtitem Is Nothing Then

Set rtitem = doc.GetFirstItem(item.Name)

Elseif Strcompare(item.Name, "body", 5) = 0 Then

Set rtitem = doc.GetFirstItem(item.Name)

End If

End If

End Forall

' If we have not found a rich text item to use then scream and quit

' this document

If rtitem Is Nothing Then

strMessage = "Unable to locate any rich text items to hold the links " & _

"to the attachments that may be removed. Cannot process this document " & _

"with NoteId of: " & fFormatNoteId(doc.NoteId)


Messagebox strMessage, lBoxType, "No RichText Item Found"

Exit Function

End If

' Iterate through each of the document's items looking for attachments

Forall item In doc.Items

If item.Type = Attachment Then

' Now that we have an attachment, get the embedded object

' associated with it. The first thing in the Values array

' is the name of the attachment.

Set objAttachment = doc.GetAttachment(item.Values(0))

iCounter = iCounter + 1

'get the attachment filename

strExtractName = objAttachment.Name

'generate a unique path for the file to be detached to - this

'involves checking for the existence of a file with the same name

'and incrementing a counter prepended to the filename until a

'name is found that does not exist in the detach folder.

strPath = strDetachFolder & "\" & strExtractName

iFilenum = 1

While fFileExists(strPath)

strNamePart = Strleftback(strExtractName, ".", 5)

strExtPart = Strrightback(strExtractName, ".", 5)

strPath = strDetachFolder & "\" & strNamePart & "_" & Cstr(iFilenum) & "." & strExtPart

iFilenum = iFilenum + 1


' Detach the attachment to the unique path

Call objAttachment.ExtractFile(strPath)

' Now create the link to the detached file so that we will

' be able to get to it from this document

' The link will be in the format:

' "Removed Attached file: to [file:\\]"

' Get the rich text item in which to append the links

'Set rtitem = doc.GetFirstItem("Body" )

' Create the rich text styles

Set rtStyleText = session.CreateRichTextStyle

Set rtStyleSep = session.CreateRichTextStyle

Set rtStyleLink = session.CreateRichTextStyle

' Initialize the styles for the three pieces of each linked file

rtStyleText.Bold = False

rtStyleText.NotesColor = COLOR_DARK_BLUE

rtStyleText.Underline = False

rtStyleText.NotesFont = FONT_HELV

rtStyleText.FontSize = 8

rtStyleSep.Bold = False

rtStyleSep.NotesColor = COLOR_BLACK

rtStyleSep.Underline = False

rtStyleSep.NotesFont = FONT_HELV

rtStyleSep.FontSize = 8

rtStyleLink.Bold = False

rtStyleLink.NotesColor = COLOR_BLUE

rtStyleLink.Underline = True

rtStyleLink.NotesFont = FONT_HELV

rtStyleLink.FontSize = 8

' Build the string to be used in the link

strNewLink = "file:\\" & fGetShortPathName(strPath)

' Append the link to the rich text field

If iCounter = 1 Then

Call rtitem.AddNewLine( 2 )

End If

Call rtitem.AppendStyle( rtStyleText )

Call rtitem.AppendText( "Anhang " & strExtractName & " entfernt und gelöst nach " )

Call rtitem.AppendStyle( rtStyleSep )

Call rtitem.AppendText( " --> [ " )

Call rtitem.AppendStyle( rtStyleLink )

Call rtitem.AppendText( strNewLink )

Call rtitem.AppendStyle( rtStyleSep )

Call rtitem.AppendText( " ]" )

Call rtitem.AddNewLine( 1 )

' Remove the attachment from the document

Call objAttachment.Remove

End If

End Forall

' Save the document so that the changes we just made will be retained

Call doc.Save(True, False, True)

fDetachRemoveAndLink = iCounter

Exit Function


strMessage = "Error in fDetachRemoveAndLink: (" & Err & ") " & Error & " at line: " & Erl


Messagebox strMessage, lBoxType, "Error!"

Exit Function

End Function

Function fFileExists(strPath As String) As Variant

fFileExists = Not (Dir(strPath) = "")

End Function

Function fFormatNoteId(strN As String) As String

' Format the NoteId so that it is 8 characters with leading 0's

If Len(strN) = 8 Then

fFormatNoteId = strN


fFormatNoteId = String(8-Len(strN), "0") & strN

End If

End Function

Hope it helps. Manfred Alles Gelungene ist eine Form von Gewalt. (Heinz Rudolf Kunze)

geschrieben von




Beitrag anfügen