commit 2e09ba3350d8d52895b2388e2e7a84b32ff69998 Author: Klaus-Uwe Mitterer Date: Wed May 4 13:26:44 2016 +0200 Import email exporter for Lotus (ca. 2013) diff --git a/Dokumentation.docx b/Dokumentation.docx new file mode 100755 index 0000000..81012c5 Binary files /dev/null and b/Dokumentation.docx differ diff --git a/EmailExport.bas b/EmailExport.bas new file mode 100755 index 0000000..0b03acd --- /dev/null +++ b/EmailExport.bas @@ -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 = "" + htmlEnd = "" + 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,"","") + mText2 = Replace(mText1,"","") + mText1 = Replace(mText2,"","") + mText2 = Replace(mText1,"","") + mText1 = Replace(mText2,"","") + mText2 = Replace(mText1,"","") + mText1 = Replace(mText2,"","") + + RepairHtmlString = mText1 +End Function diff --git a/ImportDXL.bas b/ImportDXL.bas new file mode 100755 index 0000000..e4c5f8d --- /dev/null +++ b/ImportDXL.bas @@ -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 \ No newline at end of file diff --git a/MimeConvert.xml b/MimeConvert.xml new file mode 100755 index 0000000..38970a8 --- /dev/null +++ b/MimeConvert.xml @@ -0,0 +1,10 @@ + + +
+ + + + + +20130718T092216,41+2 +MimeConvert
\ No newline at end of file