Import email exporter for Lotus (ca. 2013)
This commit is contained in:
Klaus-Uwe Mitterer
commit
2e09ba3350
BIN
Dokumentation.docx
Executable file
BIN
Dokumentation.docx
Executable file
Binary file not shown.
524
EmailExport.bas
Executable file
524
EmailExport.bas
Executable file
|
|
@ -0,0 +1,524 @@
|
|||
Option Public
|
||||
|
||||
Dim CONVERT_DB_SERVER As String
|
||||
Dim CONVERT_DB_NAME As String
|
||||
Dim CONVERT_FORM As String
|
||||
Dim CONVERT_FIELD As String
|
||||
Dim CONVERT_TOFIELD As String
|
||||
Dim OUTFILENAME As String
|
||||
Dim crlf As String
|
||||
Dim SaveTempDoc As Integer
|
||||
Dim fileNum As Integer
|
||||
|
||||
|
||||
Dim doc As NotesDocument
|
||||
Dim nstream As NotesStream
|
||||
Dim x As String
|
||||
Dim count As Integer
|
||||
Dim b As String
|
||||
|
||||
Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" _
|
||||
(Byval hwnd As Long, Byval operation As String, Byval fileName As String, _
|
||||
Byval parameters As String, Byval directory As String, Byval displayType As Long) As Long
|
||||
|
||||
Declare Function FindExecutable Lib "shell32" Alias "FindExecutableA" _
|
||||
(Byval fileName As String, Byval directory As String, Byval retAssociation As String) As Long
|
||||
|
||||
Const SW_HIDE = 0
|
||||
Const SW_SHOWNORMAL = 1
|
||||
Const SW_NORMAL = 1
|
||||
Const SW_SHOWMINIMIZED = 2
|
||||
Const SW_SHOWMAXIMIZED = 3
|
||||
Const SW_MAXIMIZE = 3
|
||||
Const SW_SHOWNOACTIVATE = 4
|
||||
Const SW_SHOW = 5
|
||||
Const SW_MINIMIZE = 6
|
||||
Const SW_SHOWMINNOACTIVE = 7
|
||||
Const SW_SHOWNA = 8
|
||||
Const SW_RESTORE = 9
|
||||
Const SW_SHOWDEFAULT = 10
|
||||
Const SW_MAX = 10
|
||||
|
||||
Const ERROR_OUT_OF_MEMORY = 0
|
||||
Const ERROR_FILE_NOT_FOUND = 2
|
||||
Const ERROR_PATH_NOT_FOUND = 3
|
||||
Const ERROR_BAD_FORMAT = 11
|
||||
Const SE_ERR_FNF = 2
|
||||
Const SE_ERR_PNF = 3
|
||||
Const SE_ERR_ACCESSDENIED = 5
|
||||
Const SE_ERR_OOM = 8
|
||||
Const SE_ERR_SHARE = 26
|
||||
Const SE_ERR_ASSOCINCOMPLETE = 27
|
||||
Const SE_ERR_DDETIMEOUT = 28
|
||||
Const SE_ERR_DDEFAIL = 29
|
||||
Const SE_ERR_DDEBUSY = 30
|
||||
Const SE_ERR_NOASSOC = 31
|
||||
Const SE_ERR_DLLNOTFOUND = 32
|
||||
|
||||
Declare Function GetActiveWindow Lib "user32.dll" () As Long
|
||||
|
||||
Type BROWSEINFO
|
||||
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
|
||||
|
||||
Const BIF_BROWSEFORCOMPUTER = 1000
|
||||
Const BIF_BROWSEFORPRINTER = 2000
|
||||
Const BIF_DONTGOBELOWDOMAIN = 2
|
||||
Const BIF_RETURNFSANCESTORS = 8
|
||||
Const BIF_RETURNONLYFSDIRS = 1
|
||||
Const BIF_STATUSTEXT = 4
|
||||
|
||||
Const MAX_SIZE = 255
|
||||
|
||||
Declare Function BrowseFolderDlg Lib "shell32.dll" Alias "SHBrowseForFolder" (lpBrowseInfo As BROWSEINFO) As Long
|
||||
|
||||
Declare Function GetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDList" (Byval PointerToIDList As Long, Byval pszPath As String) As Long
|
||||
|
||||
|
||||
|
||||
Sub Initialize
|
||||
Dim s As New NotesSession
|
||||
Dim db As NotesDatabase
|
||||
Dim dc As NotesDocumentCollection
|
||||
Dim body As NotesItem
|
||||
Dim rtitem As NotesRichTextItem
|
||||
Dim mimebits As Variant
|
||||
Dim n As Integer
|
||||
Dim errorCount As Integer
|
||||
|
||||
Dim msgid As Variant
|
||||
|
||||
|
||||
crlf = Chr(13) & Chr(10)
|
||||
|
||||
CONVERT_FORM = "MimeConvert"
|
||||
|
||||
CONVERT_TOFIELD="MimeRichTextField"
|
||||
CONVERT_FIELD = "Body"
|
||||
|
||||
SaveTempDoc = False
|
||||
expdir$=BrowseForFolder()
|
||||
If expdir$="" Then
|
||||
Messagebox "Kein Verzeichnis ausgewählt", MB_OK, "Ausgabeverzeichnis auswählen"
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Dim mime As NotesMIMEEntity
|
||||
Dim subj As String
|
||||
Dim form As String
|
||||
Set nstream=s.CreateStream
|
||||
Set db = s.CurrentDatabase
|
||||
s.ConvertMime = False
|
||||
Set dc = db.UnprocessedDocuments
|
||||
Set doc = dc.GetFirstDocument
|
||||
|
||||
Dim errorFileNum As Integer
|
||||
Dim errorFileName As String
|
||||
Dim errorText As String
|
||||
|
||||
n=0
|
||||
errorCount=0
|
||||
errorFileName=expdir$ & "\error.log"
|
||||
|
||||
|
||||
While Not(doc Is Nothing)
|
||||
If doc.subject(0) ="" Then
|
||||
subj="Kein Betreff"
|
||||
Else
|
||||
subj=validatefilename(doc.subject(0))
|
||||
End If
|
||||
OUTFILENAME=expdir$ & "\" & subj & " - " & doc.NoteID & ".eml"
|
||||
|
||||
Set body = doc.GetFirstItem("Body")
|
||||
fileNum% = Freefile
|
||||
fileName$ = OUTFILENAME
|
||||
Open filename$ For Output As fileNum%
|
||||
|
||||
If body Is Nothing Then
|
||||
If doc.form(0) ="" Then
|
||||
form="Unbekanntes Formular"
|
||||
Else
|
||||
form=doc.form(0)
|
||||
End If
|
||||
|
||||
errorCount=errorCount+1
|
||||
errorFileNum% = Freefile
|
||||
Open errorFileName$ For Append As errorFileNum%
|
||||
errorText = "[" & form & "] """ & subj & """: Kann Body nicht finden - Export fehlgeschlagen"
|
||||
Print #errorFileNum%, errorText
|
||||
Close errorFileNum%
|
||||
|
||||
Close fileNum%
|
||||
Kill filename$
|
||||
Else
|
||||
n=n+1
|
||||
If body.Type = MIME_PART Then
|
||||
Set mime = body.GetMimeEntity
|
||||
mimebits=getmultipartmime(mime)
|
||||
Print #fileNum%, mimebits
|
||||
Else
|
||||
Call GetRichTextAsHtmlFile(doc, CONVERT_FIELD, OUTFILENAME, True)
|
||||
End If
|
||||
|
||||
Close fileNum%
|
||||
End If
|
||||
|
||||
Set doc = dc.GetNextDocument(doc)
|
||||
Wend
|
||||
|
||||
If Cstr(n) = 1 Then
|
||||
Msgbox Cstr(n) & " Email exportiert nach " & expdir$
|
||||
Else
|
||||
Msgbox Cstr(n) & " Emails exportiert nach " & expdir$
|
||||
End If
|
||||
|
||||
If errorCount > 0 Then
|
||||
If errorCount > 1 Then
|
||||
Msgbox Cstr(errorCount) & " Emails konnten nicht exportiert werden. Bitte überprüfen Sie das Logfile: " & errorFileName$
|
||||
Else
|
||||
Msgbox Cstr(errorCount) & " Email konnte nicht exportiert werden. Bitte überprüfen Sie das Logfile: " & errorFileName$
|
||||
End If
|
||||
End Sub
|
||||
|
||||
|
||||
|
||||
Function remsub(substr As String)
|
||||
Dim mystr As String
|
||||
|
||||
For a=1 To Len(substr)
|
||||
y=Asc(Mid$(substr,a,1))
|
||||
If Not ( y="13" Or y="10") Then
|
||||
mystr=mystr+Mid$(substr,a,1)
|
||||
End If
|
||||
Next
|
||||
remsub=mystr
|
||||
End Function
|
||||
Function GetBoundary (header As String) As String
|
||||
|
||||
Dim boundary As String
|
||||
boundary = Strright(header, "boundary=""")
|
||||
|
||||
If (Instr(boundary, """") > 0) Then
|
||||
boundary = Strleft(boundary, """")
|
||||
End If
|
||||
|
||||
If (Len(boundary) > 0) Then
|
||||
boundary = "--" & boundary
|
||||
End If
|
||||
|
||||
GetBoundary = boundary
|
||||
End Function
|
||||
|
||||
Function GetMultipartMime (mime As NotesMIMEEntity) As String
|
||||
|
||||
Dim child As NotesMIMEEntity
|
||||
Dim mText As String
|
||||
Dim boundary As String
|
||||
|
||||
|
||||
count=count+1
|
||||
|
||||
|
||||
boundary = GetBoundary(mime.Headers)
|
||||
|
||||
If mime.ContentType<>"text" Then
|
||||
Call mime.encodecontent(1727)
|
||||
mText = mText & mime.Headers & crlf & crlf
|
||||
mText = mText & mime.ContentAsText & crlf
|
||||
Else
|
||||
mText = mText & mime.Headers & crlf & crlf
|
||||
mText = mText & crlf & mime.ContentAsText & crlf
|
||||
End If
|
||||
|
||||
Set child = mime.GetFirstChildEntity
|
||||
While Not(child Is Nothing)
|
||||
mText = mText & boundary & crlf
|
||||
mText = mText & GetMultipartMime(child)
|
||||
Set child = child.GetNextSibling
|
||||
Wend
|
||||
|
||||
If (Len(boundary) > 0) Then
|
||||
mText = mText & boundary & "--" & crlf & crlf
|
||||
End If
|
||||
|
||||
GetMultipartMime = mText
|
||||
|
||||
End Function
|
||||
|
||||
Function getlist(field As String)
|
||||
|
||||
Dim values As Variant
|
||||
Dim out As String
|
||||
Dim session As New NotesSession
|
||||
Dim nam As NotesName
|
||||
values = doc.GetItemValue( field )
|
||||
Forall v In values
|
||||
c=c+1
|
||||
Set nam=session.CreateName(v)
|
||||
If c>1 Then
|
||||
out = out +"; "+ nam.abbreviated
|
||||
Else
|
||||
out=nam.abbreviated
|
||||
End If
|
||||
|
||||
End Forall
|
||||
getlist=out
|
||||
|
||||
End Function
|
||||
|
||||
Function WriteHtmlStringToFile (htmlBody As String, _
|
||||
|
||||
fileName As String, setFileExtension As Integer, isMultiPart As Integer) As Integer
|
||||
Dim htmlStart As String, htmlEnd As String
|
||||
|
||||
If Not isMultiPart Then
|
||||
htmlStart = "<html><body>"
|
||||
htmlEnd = "</body></html>"
|
||||
End If
|
||||
|
||||
Print #fileNum%,"From: " & getlist("From")
|
||||
Print #fileNum%,"To: " & getlist("SendTo")
|
||||
Print #fileNum%,"Cc: " & getlist("CopyTo")
|
||||
Print #fileNum%, "Bcc: " & getlist("BlindCopyTo")
|
||||
Print #fileNum%,"Subject: " & doc.subject(0)
|
||||
Print #fileNum%, "Date: " & Format(doc.posteddate(0), "dd mmm yyyy hh:mm:ss")
|
||||
msgid=doc.GetItemValue("$MessageID")
|
||||
Print #fileNum, "Message-ID: " & msgid(0)
|
||||
If Not ismultipart Then Print #fileNum%, "MIME-Version: 1.0"
|
||||
If Not ismultipart Then Print #fileNum%,"Content-Type: multipart/alternative;"
|
||||
If Not ismultipart Then Print #fileNum%, Chr(09) & |boundary="| & Cstr(doc.NoteID) & |"|
|
||||
Print #1, "X-Priority: " & doc.importance(0)
|
||||
Forall i In doc.Items
|
||||
If i.text<>"" Then
|
||||
If i.name<>"Body" Then
|
||||
Print #1, "X-Notes-Item: " & i.text & "; name=" & i.name
|
||||
End If
|
||||
End If
|
||||
End Forall
|
||||
If Not ismultipart Then Print #fileNum%, crlf & "--" & Cstr(doc.NoteID)
|
||||
If Not ismultipart Then Print #fileNum%,"Content-Type: text/html;"
|
||||
If Not ismultipart Then Print #fileNum%, Chr(09) & |charset="iso-8859-1"|
|
||||
If Not ismultipart Then Print #fileNum%, "Content-Transfer-Encoding: quoted-printable" & crlf
|
||||
If Not ismultipart Then Print #fileNum%, htmlStart
|
||||
Print #fileNum%, RepairHtmlString(htmlBody)
|
||||
If Not ismultipart Then Print #fileNum%, htmlEnd & crlf
|
||||
If Not ismultpart Then Print #fileNum%, crlf & "--" & Cstr(doc.NoteID) & "--"
|
||||
|
||||
'Close #fileNum
|
||||
WriteHtmlStringToFile = True
|
||||
Exit Function
|
||||
|
||||
processError:
|
||||
Print "Fehler " & Err & ": " & Error$
|
||||
Reset
|
||||
WriteHtmlStringToFile = False
|
||||
Exit Function
|
||||
|
||||
End Function
|
||||
|
||||
Function RefreshDocFields (doc As NotesDocument) As String
|
||||
|
||||
On Error Resume Next
|
||||
|
||||
Dim session As New NotesSession
|
||||
Dim oldWarningVal As String
|
||||
oldWarningVal = session.GetEnvironmentString("MIMEConvertWarning", True)
|
||||
Call session.SetEnvironmentVar("MIMEConvertWarning", "1", True)
|
||||
|
||||
Dim workspace As New NotesUIWorkspace
|
||||
Dim uidoc As NotesUIDocument
|
||||
Set uidoc = workspace.EditDocument(True, doc)
|
||||
Call uidoc.Save
|
||||
RefreshDocFields = uidoc.Document.NoteID
|
||||
Call uidoc.Close(True)
|
||||
|
||||
Call session.SetEnvironmentVar("MIMEConvertWarning", oldWarningVal, True)
|
||||
|
||||
End Function
|
||||
Function GetRichTextAsHtmlFile (doc As NotesDocument, _
|
||||
fieldName As String, fileName As String, setFileExtension As Integer) As Integer
|
||||
Dim isMultiPart As Integer
|
||||
Dim htmlBody As String
|
||||
|
||||
htmlBody = GetRichTextAsHtmlString(doc, fieldName, isMultiPart)
|
||||
GetRichTextAsHtmlFile = WriteHtmlStringToFile(htmlBody, fileName, True, isMultiPart)
|
||||
|
||||
End Function
|
||||
|
||||
|
||||
Function GetRichTextAsHtmlString (doc As NotesDocument, _
|
||||
|
||||
fieldName As String, isMultiPart As Integer) As String
|
||||
Dim session As New NotesSession
|
||||
Dim mText As String
|
||||
Dim db As NotesDatabase
|
||||
Dim newDoc As NotesDocument
|
||||
Dim noteID As String
|
||||
Dim currentSessionMimeSetting As Integer
|
||||
|
||||
Dim rtitem As NotesRichTextItem
|
||||
Dim rtitem2 As NotesRichTextItem
|
||||
Dim mimeItem As NotesItem
|
||||
Dim mime As NotesMIMEEntity
|
||||
Dim MimeFieldName As String
|
||||
|
||||
Dim mimestream As NotesStream
|
||||
|
||||
|
||||
On Error 13 Resume Next
|
||||
Set rtitem = doc.GetFirstItem(fieldName)
|
||||
If (rtitem Is Nothing) Then
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
currentSessionMimeSetting = session.ConvertMime
|
||||
|
||||
session.ConvertMime = True
|
||||
|
||||
Set db =session.CurrentDatabase
|
||||
Set newDoc = New NotesDocument(db)
|
||||
|
||||
newDoc.Form = CONVERT_FORM
|
||||
MimeFieldName = CONVERT_TOFIELD
|
||||
|
||||
Set rtitem2 = New NotesRichTextItem(newDoc, MimeFieldName)
|
||||
Call rtitem2.AppendRTItem(rtitem)
|
||||
Call newDoc.Save(True, True)
|
||||
|
||||
noteID = RefreshDocFields(newDoc)
|
||||
|
||||
Set newDoc = Nothing
|
||||
|
||||
session.ConvertMime = False
|
||||
Set newDoc = db.GetDocumentByID(noteID)
|
||||
Set mimeItem = newDoc.GetFirstItem(MimeFieldName)
|
||||
If Not (mimeItem Is Nothing) Then
|
||||
If (mimeItem.Type = MIME_PART) Then
|
||||
Set mime = mimeItem.GetMimeEntity
|
||||
If Not (mime Is Nothing) Then
|
||||
If (mime.ContentType = "multipart") Then
|
||||
isMultipart = True
|
||||
mText = GetMultipartMime(mime)
|
||||
Else
|
||||
Set mimestream=session.CreateStream()
|
||||
isMultipart = False
|
||||
|
||||
Call mime.GetContentAstext(mimestream,True)
|
||||
mimestream.Position=0
|
||||
mText = mText & mimestream.ReadText()
|
||||
mimestream.Close
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
|
||||
If SaveTempDoc Then
|
||||
Set rtitem2 = New NotesRichTextItem(newDoc, "HTMLText")
|
||||
Call rtitem2.AppendText(mText)
|
||||
Call newDoc.Save(True, True)
|
||||
Else
|
||||
Call newDoc.Remove(True)
|
||||
End If
|
||||
|
||||
session.ConvertMIME = currentSessionMimeSetting
|
||||
GetRichTextAsHtmlString = mText
|
||||
End Function
|
||||
|
||||
|
||||
Function validatefilename(filename As String)
|
||||
Dim l As Integer
|
||||
Dim x As Integer
|
||||
Dim newname As String
|
||||
l=Len(filename)
|
||||
For x = 1 To l
|
||||
If Mid$(filename,x,1) Like "[-@()~^$#[{}=A-Za-z0-9]" Then
|
||||
newname=newname+Mid$(filename,x,1)
|
||||
Else
|
||||
If Mid$(filename,x,1)=" " Or Mid$(filename,x,1)="]" Or Mid$(filename,x,1)="," Or Mid$(filename,x,1)="'" Or Mid$(filename,x,1)="!" Then
|
||||
newname=newname+Mid$(filename,x,1)
|
||||
Else
|
||||
Print Mid$(filename,x,1) " ist ungültig"
|
||||
End If
|
||||
|
||||
End If
|
||||
Next x
|
||||
validatefilename=newname
|
||||
End Function
|
||||
Function isFolder(Byval sFolderPath As String) As Integer
|
||||
Const ATTR_DIRECTORY = 16
|
||||
isFolder = False
|
||||
If Dir$(sFolderPath, ATTR_DIRECTORY) <> "" Then isFolder = True
|
||||
End Function
|
||||
Function isFile(Byval sFileName As String) As Integer
|
||||
On Error Resume Next
|
||||
Dim lFileLength As Long
|
||||
Const ATTR_NORMAL = 0
|
||||
|
||||
isFile = False
|
||||
If Dir$(sFileName, ATTR_NORMAL) <> "" Then
|
||||
lFileLength = Filelen(sFileName)
|
||||
If (lFileLength > 0) Then isFile = True
|
||||
End If
|
||||
End Function
|
||||
Function BrowseForFolder() As String
|
||||
Dim mBrowseInfo As BROWSEINFO
|
||||
Dim lngPointerToIDList As Long
|
||||
Dim lngResult As Long
|
||||
Dim strPathBuffer As String
|
||||
Dim strReturnPath As String
|
||||
Dim vbNullChar As String
|
||||
|
||||
vbNullChar = Chr(0)
|
||||
|
||||
On Error Goto lblErrs
|
||||
|
||||
mBrowseInfo.hwndOwner = GetActiveWindow()
|
||||
|
||||
mBrowseInfo.pidlRoot = 0
|
||||
|
||||
mBrowseInfo.lpszTitle = "Wählen Sie den Ordner, den Sie verwenden möchten:"
|
||||
mBrowseInfo.pszDisplayName = String(MAX_SIZE, Chr(0))
|
||||
mBrowseInfo.ulFlags = BIF_RETURNONLYFSDIRS
|
||||
|
||||
lngPointerToIDList = BrowseFolderDlg(mBrowseInfo)
|
||||
|
||||
If lngPointerToIDList <> 0& Then
|
||||
strPathBuffer = String(MAX_SIZE, Chr(0))
|
||||
|
||||
lngResult = GetPathFromIDList(Byval lngPointerToIDList, Byval strPathBuffer)
|
||||
strReturnPath = Left$(strPathBuffer, Instr(strPathBuffer, vbNullChar) - 1)
|
||||
End If
|
||||
|
||||
BrowseForFolder = strReturnPath
|
||||
|
||||
lblEnd:
|
||||
Exit Function
|
||||
|
||||
lblErrs:
|
||||
Messagebox "Unerwarteter Fehler: " & Error$ & " (" & Cstr(Err) & ").", 0, "Error"
|
||||
Resume lblEnd
|
||||
End Function
|
||||
|
||||
Function RepairHtmlString (fieldName As String) As String
|
||||
Dim mText1 As String
|
||||
Dim mText2 As String
|
||||
|
||||
On Error 13 Resume Next
|
||||
|
||||
mText1 = Replace(fieldName,"<font size=1>","<font size=1 face=""sans-serif"">")
|
||||
mText2 = Replace(mText1,"<font size=2>","<font size=2 face=""sans-serif"">")
|
||||
mText1 = Replace(mText2,"<font size=3>","<font size=3 face=""sans-serif"">")
|
||||
mText2 = Replace(mText1,"<font size=4>","<font size=4 face=""sans-serif"">")
|
||||
mText1 = Replace(mText2,"<font size=5>","<font size=5 face=""sans-serif"">")
|
||||
mText2 = Replace(mText1,"<font size=6>","<font size=6 face=""sans-serif"">")
|
||||
mText1 = Replace(mText2,"<font size=7>","<font size=7 face=""sans-serif"">")
|
||||
|
||||
RepairHtmlString = mText1
|
||||
End Function
|
||||
72
ImportDXL.bas
Executable file
72
ImportDXL.bas
Executable file
|
|
@ -0,0 +1,72 @@
|
|||
Option Public
|
||||
Option Explicit
|
||||
|
||||
Sub Initialize
|
||||
|
||||
On Error Goto ErrorHandler
|
||||
|
||||
Dim session As New NotesSession
|
||||
Dim database As NotesDatabase
|
||||
|
||||
Dim filenames As Variant
|
||||
Dim filename As String
|
||||
Dim importer As NotesDXLImporter
|
||||
Dim ws As New notesuiworkspace
|
||||
Dim errorFileNum As Integer
|
||||
Dim errorFileName As String
|
||||
|
||||
Set database = session.CurrentDatabase
|
||||
|
||||
Dim stream As NotesStream
|
||||
|
||||
Set stream = session.CreateStream
|
||||
|
||||
|
||||
filenames = ws.openfiledialog(False,"DXL-Datei importieren", "DXL/XML Files|*.dxl;*.xml|Textdateien|*.txt|Alle Dokumente|*.*")
|
||||
|
||||
If Isempty(filenames) Then
|
||||
Messagebox "Kein Dateiname angegeben",, "Fehler"
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
filename = Cstr(filenames(0))
|
||||
|
||||
If filename = "" Or Not stream.Open(filename$) Then
|
||||
Messagebox "Kann Datei nicht öffnen: " & filename,, "Error"
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Set importer = session.CreateDXLImporter(stream,database)
|
||||
|
||||
importer.DocumentImportOption = DXLIMPORTOPTION_REPLACE_ELSE_CREATE
|
||||
importer.DesignImportOption = DXLIMPORTOPTION_REPLACE_ELSE_CREATE
|
||||
importer.ReplicaRequiredForReplaceOrUpdate = False
|
||||
' importer.InputValidationOption = VALIDATE_NEVER
|
||||
|
||||
Call importer.Process
|
||||
|
||||
Exit Sub
|
||||
ErrorHandler:
|
||||
|
||||
Const LSI_THREAD_PROC = 1
|
||||
Const LSI_THREAD_CALLPROC=10
|
||||
|
||||
Dim messageString As String
|
||||
messageString = Now & "-" & "Fehler in " & session.CurrentAgent.name & ". " & _
|
||||
Getthreadinfo(LSI_THREAD_CALLPROC) & ", Erl()=" & Cstr(Erl()) & _
|
||||
" ,Err()=" & Cstr(Err()) & " ,Error()=" & Error()
|
||||
|
||||
If Err() = 4522 Then
|
||||
errorFileNum% = Freefile
|
||||
errorFileName$ = filename & ".log"
|
||||
|
||||
Open errorFilename$ For Output As errorFileNum%
|
||||
Print #errorFileNum%, importer.log()
|
||||
Close errorFileNum%
|
||||
|
||||
messageString = messageString & ". Details geloggt nach: " & errorFileName
|
||||
End If
|
||||
|
||||
Msgbox messageString
|
||||
|
||||
End Sub
|
||||
10
MimeConvert.xml
Executable file
10
MimeConvert.xml
Executable file
|
|
@ -0,0 +1,10 @@
|
|||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE form>
|
||||
<form name="MimeConvert" xmlns="http://www.lotus.com/dxl" version="6.5" maintenanceversion="4.0" replicaid="CA2573B6003711EC" publicaccess="false" designerversion="6.5">
|
||||
<body><richtext>
|
||||
<pardef id="1"/>
|
||||
<par def="1">
|
||||
<field type="richtext" kind="editable" name="MimeRichTextField" storageformat="htmlmime"/>
|
||||
<field type="richtext" kind="editable" name="HtmlText"/></par></richtext></body>
|
||||
<item name="OriginalModTime"><datetimelist><datetime dst="true">20130718T092216,41+2</datetime></datetimelist></item>
|
||||
<item name="$$ScriptName" summary="false" sign="true"><textlist><text>MimeConvert</text></textlist></item></form>
|
||||
Loading…
Reference in a new issue