lotusexport/EmailExport.bas

525 lines
14 KiB
QBasic
Raw Normal View History

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<65>hlt", MB_OK, "Ausgabeverzeichnis ausw<73>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 <20>berpr<70>fen Sie das Logfile: " & errorFileName$
Else
Msgbox Cstr(errorCount) & " Email konnte nicht exportiert werden. Bitte <20>berpr<70>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<6E>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