lotusexport/EmailExport.bas

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