I have a LotusScript script library that formats an HTML mail document that it works fine unless the SendTo name contains an accented character.
-- Edit --
Sub Initialize
Dim s As New NotesSession
Dim mailName As String
Dim body As NotesMIMEEntity
Dim header As NotesMIMEHeader
Dim stream As NotesStream
Dim thisDB As NotesDatabase
Dim MailDoc As NotesDocument
Set thisDB = s.currentDatabase
Set mailDoc = thisDB.Createdocument()
mailName = "BØRG#WFSSystems.ca"
Set stream = s.CreateStream
s.ConvertMIME = False ' Do not convert MIME to rich text
Set body = mailDoc.CreateMIMEEntity
Set header = body.CreateHeader("To")
Call header.SetHeaderValAndParams("charset=UTF-16")
Call header.SetHeaderVal("MIME multipart message")
Call header.SetHeaderVal(mailName)
Call stream.writetext(|</body>|)
Call stream.writetext(|</html>|)
'Convert stream then send
Call body.SetContentFromText(stream, "text/HTML;charset=UTF-16", ENC_IDENTITY_7BIT)
Call mailDoc.Send(False)
s.ConvertMIME = True ' Restore conversion - very important
End Sub
Above is the whole sub that I set as a test. It looks like the accented character is maintained through the whole process and the email is actually sent. I'm working with a local copy of my mail file so I can see what ends up in mail.box. The Mail.box shows the recipient to be "BRG#WFSSystems.ca". So now I'm wondering if the issue is my code or is it my settings or preferences somewhere?
Related
I want to view the source of an outlook mail and save it as an HTML file. But the mailItem.HTMLBody is not giving me full source, it is truncated in the mid.
Set app = CreateObject("Outlook.Application")
Set nameSpace = app.GetNamespace("MAPI")
Set MyFolders = nameSpace.GetDefaultFolder(6)
'Read unread items in Inbox
Set cols = MyFolders.Items
dim a
For each mail In cols
If mail.unread Then
a = mail.HTMLbody
msgbox a
End If
Next
'MSgbox a doesn't show full html source*
The .HTMLbody property is complete. It's MsgBox() that truncates the string.
Save it to file, just as you originally intended.
Set FSO = CreateObject("Scripting.FileSystemObject")
' ...
For Each mail In cols
If mail.unread Then
With FSO.CreateTextFile("C:\Temp\messagebody.html", True, True)
.Write mail.HTMLbody
.Close
End With
End If
Next
If you plan on using the message subject as the filename, make sure that you replace all characters that are invalid in filenames and that you the check overall path length limit (~255 characters).
The FileSystemObject is documented here: https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/createtextfile-method
Edit: Problem is solved. For some reason the Base64Encode function was putting a line break in the output string, something I didn't notice until I response.write the output and looked at the source code of the page instead of the compiled page.
I'm trying to send JSON to a remote server in order to get back a JSON response (Basically I send them data, they perform calculations based on my data and send back different data). However instead of getting data back the server tells me the request failed authentication.
The Authentication involves sending a base64 encoded string, username, and password combined. These values can change so I'm using variables to pass the information on. This does not work, however if I enter the fully encoded value as a string it does work.
Function GetAPdataPost(sSendHTML, sURL)
dim apHTTP
dim sHTTPResponse
dim API_KEY
dim API_PWD
dim auth
API_KEY = "fred"
API_PWD = "barney"
auth = Base64Encode(API_KEY & ":" & API_PWD)
Set apHTTP = Server.CreateObject("MSXML2.ServerXMLHTTP")
apHTTP.Open "POST", sURL, false
apHTTP.setRequestHeader "Content-Type", "application/json; charset=UTF-8"
apHTTP.setRequestHeader "Authorization","Basic ZnJlZDpiYXJuZXk=" '<-- works
apHTTP.setRequestHeader "Authorization", "Basic " & auth '<-- doesn't work
apHTTP.setRequestHeader "Content-Length", len(sSendHTML)
apHTTP.setRequestHeader "Accept", "*/*"
apHTTP.setRequestHeader "Account-Number", "00000004"
apHTTP.setRequestHeader "Cache-Control", "no-cache"
apHTTP.setRequestHeader "Connection", "close"
On Error Resume Next
apHTTP.send sSendHTML
sHTTPResponse = apHTTP.responseText
If Err.Number = 0 Then
GetAPdataPost = sHTTPResponse
Else
GetAPdataPost = "Something went wrong: " & Err.Number
End If
On Error Goto 0
Set apHTTP = Nothing
End Function
Using the first line result in a proper response form the server, a valid JSON string with all the required data. The second line results in a JSON string saying "The request failed authentication".
So aside from typing out the Base64 encoded string how do I get a variable to be recognised as a valid string?
I should just note that I have tried surrounding auth with double quotes ("") and Chr(34) to no avail.
Edit: Base64 Encode function.
Function Base64Encode(sText)
Dim oXML, oNode
Set oXML = CreateObject("Msxml2.DOMDocument.3.0")
Set oNode = oXML.CreateElement("base64")
oNode.dataType = "bin.base64"
oNode.nodeTypedValue =Stream_StringToBinary(sText)
Base64Encode = oNode.text
Set oNode = Nothing
Set oXML = Nothing
End Function
Function Stream_StringToBinary(Text)
Const adTypeText = 2
Const adTypeBinary = 1
'Create Stream object
Dim BinaryStream 'As New Stream
Set BinaryStream = CreateObject("ADODB.Stream")
'Specify stream type - we want To save text/string data.
BinaryStream.Type = adTypeText
'Specify charset For the source text (unicode) data.
BinaryStream.CharSet = "us-ascii"
'Open the stream And write text/string data To the object
BinaryStream.Open
BinaryStream.WriteText Text
'Change stream type To binary
BinaryStream.Position = 0
BinaryStream.Type = adTypeBinary
'Ignore first two bytes - sign of
BinaryStream.Position = 0
'Open the stream And get binary data from the object
Stream_StringToBinary = BinaryStream.Read
Set BinaryStream = Nothing
End Function
The Base64Encode function was putting a line break in the output string, something I didn't notice until I response.write the output and looked at the source code of the page instead of the compiled page.
Always remember to look at the raw data, not just the displayed data (i.e. not like me)
I am trying to run a VBScript that searches all the Incoming messages for a specific string on the subject field and replaces it with something else but keeping the rest of the subject content. So far, this is my code but im not getting any results.
Incoming mails subject: [EXTERNAL] abcdfed ghijk lmno
What i need: [*] abcdfed ghijk lmno
Sub RunAScriptRuleRoutine(MyMail As MailItem)
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim msg As Outlook.MailItem
Dim rply As Outlook.MailItem
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set msg = olNS.GetItemFromID(strID)
' do stuff with msg, e.g.
msg.Subject = Replace(msg.Subject, "[EXTERNAL]", "[*]")
msg.Save
Set msg = Nothing
Set olNS = Nothing
End Sub
I will appreciate your help
Changes to the subject for received messages will only be reflected in the header UI. You also have to change the MailItem.ConversationTopic value, but it is read-only. However, you can use PropertyAccessor.SetProperty("http://schemas.microsoft.com/mapi/proptag/0x0070001F", "New subject") to update it.
I need source code for reading the .txt content from a URL.
My text file content sample and then load in Visual Basic 6.0:
My source code:
Dim data As String
data = Inet1.OpenURL("http://test.com/sample.txt")
Text1.Text = data
There is nothing that will only "download" a line at a time as it can't tell where the line breaks are until it's downloaded it.
If you only want to read/process a line at a time, you can split on the line breaks after downloading it:
Dim Data As String
Dim DataLines() As String
Data = Inet1.OpenURL("http://test.com/sample.txt")
DataLines = Split(Data, vbCrLf)
For Index = LBound(DataLines) to UBound(DataLines)
MsgBox DataLines(Index)
Next
You will need to be careful to make sure you have the correct line break for the data being read.
When dealing with HTTP you have to consider both line separators and character encoding. If you can make assumptions after testing then you can bypass some checking and just hard-code to fit your needs.
However the creay old Internet Transfer Control ("Inet") is usually not the best choice available and more modern alternatives are shipped as part of Windows since at least the advent of IE 5.5, and installed with IE 5.5 on more ancient versions of Windows. Thus they'll even be available and work on nearly any Win95 system still running today.
'References to MSXML 3.0 or later,
' ADO 2.5 or later.
Private Function GetHttpText(ByVal URL As String) As ADODB.Stream
Dim Req As MSXML2.XMLHTTP
Dim CharSet As String
Dim CharsetPos As Long
Dim LineSeparator As LineSeparatorEnum
Set Req = New MSXML2.XMLHTTP
Set GetHttpText = New ADODB.Stream
With GetHttpText
.Open
.Type = adTypeBinary
With Req
.Open "GET", URL, False
.send
CharSet = LCase$(.getResponseHeader("CONTENT-TYPE"))
End With
.Write Req.responseBody
CharsetPos = InStr(CharSet, "charset")
If CharsetPos Then
CharSet = Split(Mid$(CharSet, CharsetPos), "=")(1)
Else
'UTF-8 is a reasonable "default" these days:
CharSet = "utf-8"
End If
If CharSet = "utf-8" Then
LineSeparator = adLF
Else
'Your milage may vary here, since there is no line-end
'header defined for HTTP:
LineSeparator = adCRLF
End If
.Position = 0
.Type = adTypeText
.CharSet = CharSet
.LineSeparator = LineSeparator
End With
End Function
Private Sub DumpTextLineByLine()
With GetHttpText("http://textfiles.com/art/simpsons.txt")
'Read text line by line to populate a multiline TextBox
'just as a demonstration:
Do Until .EOS
Text1.SelText = .ReadText(adReadLine)
Text1.SelText = vbNewLine
Loop
.Close
End With
End Sub
I get the error "cannot encrypt notesdocument when instantiated by notesuidocument" at the line cjDoc.Encrypt. Can someone tell me how to fix/why it is happening.
Dim currDb as NotesDatabase
Set currDb=session.CurrentDatabase
Set cjDoc = currDb.GetDocumentByUNID(Trim(Source.Document.CJ_UNID(0)))
If Not cjDoc Is Nothing Then
Dim parleyRtItem As NotesRichTextItem
Set parleyRtItem = New NotesRichTextItem(cjDoc,CJ_PARLEY_LINK)
Call parleyRtItem.AppendDocLink(parleyDoc,"Credit Jacket Parley")
cjDoc.ParleyUNID = Source.Document.parleyUNID
'cjDoc.parleyCreation = "Parley document created " & Cstr(Today) & " : "
cjDoc.parleyCreation = "Parley document created " & Cstr(Today) & " "
cjDoc.Encrypt
Call cjDoc.Save(True,True)
End If
The error suggests that you cannot encrypt it while your uidocument is open.
Dit you try closing the uidocument before encrypting?
I have seen similar issues worked around by closing the UI doc, and putting the encrypt code in the Terminate event on the UI doc. Saves working out how to fire the agent.
by the time Terminate runs, the ui doc handle is dropped from memory (which is exactly what you need to happen, so Notes doenst give you the same error) so you have to do the 'make note of UNID and get the backed document afresh" bit that tvdpol suggests.
In queryClose of UI doc, set a temp var with the UNID ..
Dim s as new notessession
s.setEnvironmentVar("TempUNID",source.document.universalID)
In Terminate event of uidoc, get the UNID and get the original doc, meaning just the backend doc- UI doc is no longer in memory ..
Dim s as new notessession
Dim doc as notesdocument
Dim sUNID as string
sUNID = s.getEnviromnentString"TempUNID"
set doc=ds.currentdatabase.getDocumentByUNID(sUNID)
' do encryption
'
doc.save(false,false)