RTF to Mime

HCL Domino Domino Forum
1

The below code will take a Lotus Notes e-mail and convert it to a Mime file. This works very well provided the e-mail came in as a mime e-mailWhat I am need to do is convert any e-mail to a mime file and push it to a URL. So the question is, how do I convert a Rich Text e-mail to a mime e-mail via code

so that I can convert it to a file?

I know how to push the file once I get it.

I have to do exactly this as I am pushing the code to another non-Notes application, so I do not have options.

PLEASE HELP SOMEONE!!!

Dim db As NotesDatabase

Dim dc As NotesDocumentCollection

Dim doc As NotesDocument

Dim tempdoc As NotesDocument

Dim mime As NotesMIMEEntity

Dim stream As notesstream

Dim mimeBoundaryEnd As String

Dim mimeBoundarystart As String

Dim exportFileName As String

Dim directory As String

Dim macro As String

Dim mimeType As String

Dim pathName As String

Dim tmp As Variant

Dim fileNum As Integer

Dim records As Integer

Dim delivdate As NotesDateTime

Dim after As String

Dim bevore As String

Dim fileextention As String

Dim envstring As String

Dim strFilePath As String

Dim strPushURL As String

Dim returnVerticaliPush As String

Dim s As New Notessession

'Set LS variables

Set db = s.CurrentDatabase

s.ConvertMIME = False

Set dc = db.UnprocessedDocuments

Set tempdoc = dc.GetFirstDocument

'Set Java variables

Set jSession = New JavaSession()

Set jClass = jSession.GetClass("Verticali")

Set jObject = jClass.CreateObject("()V")

'Location of where files will be temporary stored

directory$ = "C:\Temp\"

Call CreateFolderOnWindows(directory$, 0)

'File Extention

fileextention = ".tmp"



fileNum% = Freefile()

records% = 0



While Not(tempdoc Is Nothing)

	Set doc = New NotesDocument(db)

	Call tempdoc.CopyAllItems(doc)

	Set doc = removenotesitems( doc )

	macro$ = {@replacesubstring("} + tempdoc.subject(0) + {";":";";")}

	tmp = Evaluate(macro$)

	Set delivdate = New NotesDateTime(tempdoc.DeliveredDate(0))

	exportFileName$ = directory$ + "\" + Cstr(Year(delivdate.LSLocalTime)) + "_" + Cstr(Month(delivdate.LSLocalTime)) + "_" + Cstr(Day(delivdate.LSLocalTime))+ "_at_" + Cstr(Hour(delivdate.LSLocalTime)) +"_" + Cstr(Minute(delivdate.LSLocalTime)) + "_" + Cstr(Second(delivdate.LSLocalTime)) + "__" +	tmp(0) + " -- " + tempdoc.NoteID + fileextention

	

	Set mime = doc.GetMIMEEntity

	pathName$ = doc.subject(0)

	

	If Not(mime Is Nothing) Then

		Set stream = s.Createstream

		

		While Not stream.Open(exportFileName$, mime.Charset)

			pathName$ = Inputbox ("Please choose a valid filename","Error in export",doc.subject(0))

			exportFileName$ = directory$ + doc.UniversalID + " -- " + fileextention

		Wend

		

		Call stream.Close

		macro$ = {@replacesubstring("} + pathName$ + {";":";"-")}

		tmp = Evaluate(macro$)		

		exportFileName$ = directory$ + tempdoc.UniversalID + fileextention

		

		If (Dir$(exportFileName$) <> "") Then

			Kill exportFileName$

		End If

		

		Call stream.Open(exportFileName$, mime.Charset)

		mimeType = mime.ContentType

		mimeBoundarystart = mime.Boundarystart

		mimeBoundaryEnd = mime.BoundaryEnd

		Call mime.GetEntityAsText(stream)

		Set mime=mime.GetNextEntity

		

		While Not (mime Is Nothing)

			Call stream.WriteText("",3)

			Call stream.WriteText(mime.Boundarystart)

			Call mime.DecodeContent()

			

			Select Case mime.Encoding

			Case ENC_BASE64 : 

				m = "1727"

			Case ENC_EXTENSION : 

				m = "1731"

			Case ENC_IDENTITY_7BIT : 

				m = "1728"

			Case ENC_IDENTITY_8BIT : 

				m = "1729"

			Case ENC_IDENTITY_BINARY : 

				m = "1730"

			Case ENC_NONE : 

				m = "1727"

			Case ENC_QUOTED_PRINTABLE : 

				m = "1726"

			End Select

			

			Call mime.EncodeContent( m )

			Call mime.GetEntityAsText(stream)

			Call stream.Writetext(mime.BoundaryEnd)

			Stop

			

			For b = 1 To 10

				envstring = "V_Mail$inlay_bevore" + Cstr(b)

				bevore = s.GetEnvironmentstring(envstring)

				

				If Not (bevore = "") Then

					Call stream.WriteText(bevore, 3)

				End If

			Next

			

			Set mime = mime.GetNextEntity

		Wend

		

		Call stream.Writetext(mimeBoundaryEnd)

		For a = 1 To 10

			after = s.GetEnvironmentstring("V_Mail$inlay_after" + Cstr(a))

			

			If Not (after = "") Then

				Call stream.WriteText(after, 3)

			End If

		Next

		

		Call stream.Close

		records% = records% + 1

	Else

		Messagebox doc.GetItemValue("subject")(0),,"Memo not in MIME format."

	End If

	

	s.ConvertMIME = True

'Get next selected doc

NextMemo:

	Set tempdoc = dc.GetNextDocument(tempdoc)

Wend

End Sub

Function CreateFolderOnWindows(InputFolder As String, Debug As Integer)

On Error 76 Goto CreateFolder



Dim tempFolder As String

Dim delim As String

Dim CheckFolder As String



delim = "\"

ret = Split(InputFolder, delim)



Forall x In ret		

	If Instr(1,x,":") => 1 Then

’ this is a drivename

		If debug = 1 Then

			Print "Drive: "+ x

		End If

		

		tempFolder = x + "\"

	Else

’ this is a folder

		If debug = 1 Then

			Print "Folder: "+ x

		End If

		tempFolder = tempFolder + x + "\"

		CheckFolder = Dir(tempFolder,16)

'^^^ check if folder exist. If it doesn´t we get a error 76 and we will create the folder

	End If		

End Forall



Goto ENDE

CreateFolder:

Mkdir(tempFolder)

Resume Next

ENDE:

End Function

Function removenotesitems(doc As NotesDocument) As NotesDocument

Dim item As NotesItem

Forall items In doc.Items

	Set item = doc.GetFirstItem(items.name)

	Select Case Lcase(item.name)

	Case Lcase("$NoteHasNativeMIME")

		Call item.Remove

	Case Lcase("SMTPOriginator")

		Call item.Remove

	Case Lcase("Form")

		Call item.Remove

	Case Lcase("RoutingState")

		Call item.Remove

	Case Lcase("NOTES_DEVELOPMENT_MAIL_CHECK")

		Call item.Remove

	Case Lcase("RouteServers")

		Call item.Remove

	Case Lcase("RouteTimes")

		Call item.Remove

	Case Lcase("$Orig")

		Call item.Remove

	Case Lcase("$MailClusterFailover")

		Call item.Remove

	Case Lcase("$UpdatedBy")

		Call item.Remove

	Case Lcase("Categories")

		Call item.Remove

	Case Lcase("$Revisions")

		Call item.Remove

	Case Lcase("$MsgTrackFlags")

		Call item.Remove

	Case Lcase("DeliveredDate")

		Call item.Remove

	Case Lcase("$MiniView")

		Call item.Remove

	Case Lcase("FromDomain")

		Call item.Remove

	Case Lcase("$ExportHeadersConverted")

		Call item.Remove

	Case Else

'Do nothing

	End Select

End Forall

Set removenotesitems = doc

End Function