I am trying to post a forum topic with attached image file to IBM Connections 5.0 using Excel VBA.
According to IBM Connections API description a multipart request will be required here.
What I already managed is to post a forum topic without attachment and also attaching a text or image file to an existing wiki page. Therefore I assume that the problem is not related with these aspects but rather with the correct formatting of the multipart request. API description is not very clear to me here and I tried several things I found about multipart requests in other help forums. But all I get is a response "400 bad request".
Maybe some of you experts can give me a hint about my code:
Public Sub CreateForumPost()
Const sBoundary As String = "2588eb82-2e1c-4aec-9f4f-d65a3ecf8fab"
Dim oHttp As MSXML2.xmlhttp
Dim sUrl As String
Dim sBody As String
'create XMLHTTP object and URL
Set oHttp = CreateObject("MSXML2.XMLHTTP")
sUrl = "https://my-connect-server/forums/atom/topics?forumUuid=9e51cbfb-4b1d-405d-9835-dbd087c49a65"
'create forum post
sBody = "--" & sBoundary & vbCrLf
sBody = sBody & "<?xml version=""1.0"" encoding=""UTF-8""?>"
sBody = sBody & "<entry xmlns=""http://www.w3.org/2005/Atom"" xmlns:app=""http://www.w3.org/2007/app"" xmlns:snx=""http://www.ibm.com/xmlns/prod/sn"">"
sBody = sBody & "<category scheme=""http://www.ibm.com/xmlns/prod/sn/type"" term=""forum-topic""/>"
sBody = sBody & "<title type=""text""> " & "My Title" & " </title>"
sBody = sBody & "<category term=""question"" scheme=""http://www.ibm.com/xmlns/prod/sn/flags""/>"
sBody = sBody & "<category term=""" & "my-tag" & """/>"
sBody = sBody & "<content type=""html""> " & "My post content" & " </content>"
sBody = sBody & "</entry>" & vbCrLf
sBody = sBody & "--" & sBoundary & vbCrLf
sBody = sBody & "Content-Disposition: attachment; filename=""dummy.txt""" & vbCrLf & vbCrLf
sBody = sBody & sGetFile("c:\temp\dummy.txt") & vbCrLf
sBody = sBody & "--" & sBoundary & "--" & vbCrLf
Call oHttp.Open("POST", sUrl, False)
Call oHttp.setRequestHeader("Content-Type", "multipart/related;boundary=" & sBoundary & ";type=""application/atom+xml""")
Call oHttp.send(pvToByteArray(sBody))
If oHttp.Status = 201 Then
Call MsgBox("success")
Else
Call MsgBox("error")
Stop
End If
End Sub
Private Function sGetFile(sName As String) As String
Dim abyContent() As Byte
Dim iNumber As Integer
Dim lLen As Long
lLen = FileLen(sName)
If lLen > 0 Then
ReDim abyContent(lLen - 1)
iNumber = FreeFile
Open sName For Binary Access Read As iNumber
Get iNumber, , abyContent
Close iNumber
sGetFile = StrConv(abyContent, vbUnicode)
Else
sGetFile = ""
End If
End Function
Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbFromUnicode)
End Function
We found out what the problem was. It was indeed about the formatting of the multipart request. You need to be very careful with the CrLf characters ...
Public Sub CreateForumPost()
'...
'create forum post
sBody = vbCrLf & "--" & sBoundary & vbCrLf & vbCrLf
'...
sBody = sBody & sGetFile("c:\temp\dummy.txt") & vbCrLf
sBody = sBody & "--" & sBoundary & "--"
'...
End Sub
Now it works. Nevertheless many thanks for your support!
Related
Using VBA (Visual Basic for Applications), I am attempting to send a local document via the Telegram Bot API.
I have been able to send a Photo successfully and attempted to modify the code in order to send a document.
I am attempting to use the multipart/form-data method of loading the file.
When running the code, I get the following response from the Telegram server:
{"ok":false,"error_code":400,"description":"Bad Request: there is no document in the request"}
Here is a solution for sending a photograph and I have used this successfully:
Exel VBA send image using Telegram bot api
However, I now want to send a PDF document rather than an image and this is where I am stuck.
Below is the code adapted from the sending of an image in an attempt to send a PDF document.
#CDP1802 - perhaps you are able to assist?
Sub Telegram_PDF()
Const URL = "https://api.telegram.org/bot"
Const TOKEN = "**Token**"
Const METHOD_NAME = "/sendDocument?"
Const CHAT_ID = "**Chat ID**"
Const FOLDER = "C:\Users\rk\Downloads\"
Const JPG_FILE = "babok-30-poster.pdf"
Dim data As Object, key
Set data = CreateObject("Scripting.Dictionary")
data.Add "chat_id", CHAT_ID
' generate boundary
Dim BOUNDARY, s As String, n As Integer
For n = 1 To 16: s = s & Chr(65 + Int(Rnd * 25)): Next
BOUNDARY = s & CDbl(Now)
Dim part As String, ado As Object
For Each key In data.keys
part = part & "--" & BOUNDARY & vbCrLf
part = part & "Content-Disposition: form-data; name=""" & key & """" & vbCrLf & vbCrLf
part = part & data(key) & vbCrLf
Next
' filename
part = part & "--" & BOUNDARY & vbCrLf
part = part & "Content-Disposition: form-data; name=""Document""; filename=""" & JPG_FILE & """" & vbCrLf & vbCrLf
' read jpg file as binary
Dim jpg
Set ado = CreateObject("ADODB.Stream")
ado.Type = 1 'binary
ado.Open
ado.LoadFromFile FOLDER & JPG_FILE
ado.Position = 0
jpg = ado.read
ado.Close
' combine part, jpg , end
ado.Open
ado.Position = 0
ado.Type = 1 ' binary
ado.Write ToBytes(part)
ado.Write jpg
ado.Write ToBytes(vbCrLf & "--" & BOUNDARY & "---")
ado.Position = 0
Dim req As Object, reqURL As String
Set req = CreateObject("MSXML2.ServerXMLHTTP.6.0")
reqURL = URL & TOKEN & METHOD_NAME
With req
.Open "POST", reqURL, False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY
.send ado.read
Debug.Print .responseText
End With
End Sub
Try this.
P.S: Thanks to #CDP1802
Code:
Sub send_Document()
Const URL = "https://api.telegram.org/bot"
Const TOKEN = "*TOKEN*"
Const METHOD_NAME = "/sendDocument?"
Const CHAT_ID = "*CHAT_ID*"
Const FOLDER = "*PATH_TO_FILE*"
Const DOCUMENT_FILE = "*FILENAME*"
Dim data As Object, key
Set data = CreateObject("Scripting.Dictionary")
data.Add "chat_id", CHAT_ID
' generate boundary
Dim BOUNDARY, s As String, n As Integer
For n = 1 To 16: s = s & Chr(65 + Int(Rnd * 25)): Next
BOUNDARY = s & CDbl(Now)
Dim part As String, ado As Object
For Each key In data.keys
part = part & "--" & BOUNDARY & vbCrLf
part = part & "Content-Disposition: form-data; name=""" & key & """" & vbCrLf & vbCrLf
part = part & data(key) & vbCrLf
Next
' filename
part = part & "--" & BOUNDARY & vbCrLf
part = part & "Content-Disposition: form-data; name=""document""; filename=""" & DOCUMENT_FILE & """" & vbCrLf & vbCrLf
' read document file as binary
Dim doc
Set ado = CreateObject("ADODB.Stream")
ado.Type = 1 'binary
ado.Open
ado.LoadFromFile FOLDER & DOCUMENT_FILE
ado.Position = 0
doc = ado.read
ado.Close
' combine part, document, end
ado.Open
ado.Position = 0
ado.Type = 1 ' binary
ado.Write ToBytes(part)
ado.Write doc
ado.Write ToBytes(vbCrLf & "--" & BOUNDARY & "--")
ado.Position = 0
Dim req As Object, reqURL As String
Set req = CreateObject("MSXML2.XMLHTTP")
reqURL = URL & TOKEN & METHOD_NAME
With req
.Open "POST", reqURL, False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY
.send ado.read
MsgBox .responseText
End With
End Sub
Function ToBytes(str As String) As Variant
Dim ado As Object
Set ado = CreateObject("ADODB.Stream")
ado.Open
ado.Type = 2 ' text
ado.Charset = "_autodetect"
ado.WriteText str
ado.Position = 0
ado.Type = 1
ToBytes = ado.read
ado.Close
End Function
Change the key variables!
I need to send a image from my pc in a text message using Twilio and Microsoft Access.
I was able to successfully send a text message via Microsoft Access. However, the image wasn't sent. I found a parameter called "mediaURL". I am trying to have mediaURL refer to a image on my pc ("d:\imagefolder").
Has anyone been able to do this. Here is my code to send the text message.
Dim MessageUrl As String
Dim FromURLEncode As String
Dim ToURLEncode As String
Dim imageURL As String
On Error GoTo Error_Handler
' setup the URL
MessageUrl = BASEURL & "/2010-04-01/Accounts/" & ACCOUNTSID & "/Messages"
imageURL = "d:\imagefolder\mypicture.png"
' setup the request and authorization
Dim http As MSXML2.XMLHTTP60
Set http = New MSXML2.XMLHTTP60
http.Open "POST", MessageUrl, False, ACCOUNTSID, AUTHTOKEN
http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
Dim postData As String
postData = "From=" & fromNumber _
& "&To=" & toNumber _
& "&Body=" & body _
& "&MediaURL=" & imageURL
Debug.Print postData
' send the POST data
http.send postData
' optionally write out the response if you need to check if it worked
Debug.Print http.responseText
If http.Status = 201 Then
ElseIf http.Status = 400 Then
MsgBox "Failed with error# " & _
http.Status & _
" " & http.statusText & vbCrLf & vbCrLf & _
http.responseText
ElseIf http.Status = 401 Then
MsgBox "Failed with error# " & http.Status & _
" " & http.statusText & vbCrLf & vbCrLf
Else
MsgBox "Failed with error# " & http.Status & _
" " & http.statusText
End If
Exit_Procedure:
On Error Resume Next
' clean up
Set http = Nothing
Exit Function
Error_Handler:
Select Case Err.Number
Case NOINTERNETAVAILABLE
MsgBox "Connection to the internet cannot be made or " & _
"Twilio website address is wrong"
Case Else
MsgBox "Error: " & Err.Number & "; Description: " & Err.Description
Resume Exit_Procedure
Resume
End Select
I was finally able to send text messages with images by using MediaUrl. My Code was using MediaURL. It has to be exactly "MediaUrl". Once, I figured that out, I have been able to send text messages with images.
Twilio developer evangelist here.
As Thomas G answered in a comment, your problem is that the image is on your computer. The URL needs to be available to Twilio.
You will need to upload the image to a server, either your own or a public service, and then using the for that server.
Check out the documentation on sending MMS with Twilio for more details.
i'm coding a makro in MS Word to execute a command in cmd and send it to the remote server via POST. I have no expirience in VB so the error could be easy to solve, but i have no idea what i'm doing wrong
Sub Run_Cmd(command, visibility, wait_on_execute)
Dim WshShell As Variant
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run "%COMSPEC% /c " & command, visibility, wait_on_execute
End Sub
Sub Run_Program(program, arguments, visibility, wait_on_execute)
Dim WshShell As Variant
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run program & " " & arguments & " ", visibility, wait_on_execute
End Sub
Const INVISIBLE = 0
Const WAIT = True
Private Sub pvPostFile(sUrl As String, sFileName As String, sPath As String, Optional ByVal bAsync As Boolean)
Const STR_BOUNDARY As String = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String
'--- read file
nFile = FreeFile
Open sPath For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbUnicode)
MsgBox sPostData
End If
Close nFile
'--- prepare body
sPostData = "--" & STR_BOUNDARY & vbCrLf & _
"Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
sPostData & vbCrLf & _
"--" & STR_BOUNDARY & "--"
'--- post
With CreateObject("Microsoft.XMLHTTP")
.Open "POST", sUrl, bAsync
.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & STR_BOUNDARY
.Send pvToByteArray(sPostData)
End With
End Sub
Private Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbFromUnicode)
End Function
Sub Workbook_Open()
Run_Cmd "systeminfo > %USERPROFILE%\temp.txt", INVISIBLE, WAIT
Dim envstring As String
envstring = Environ$("USERPROFILE")
envstring = envstring & "\temp.txt"
pvPostFile "http://testujemywordpressa.pl/index.php", "temp.txt", envstring
End Sub
debugger says that "The system can not locate the specified resource"
The reason you are receiving that error message is because the server you are trying to reach doesn't exist. Check the URL that you are passing to pvPostFile(). I have received this error many times because of bad URLs in the past few months. Let me know if this works out for you.
Anybody out there that can help convert this small chunk of VB.NET to VBScript, I didn't realise when I was writing my tester app that the application I was going to use it in is all VBScript =(
The code gets a table from the database, then writes a couple of lines and then the table to a tab delimited file. I understand I may have to rewrite the part with Lambda completely? I may have to start again but if anyone can do this I would be appreciative!
Private dataTable As New DataTable()
Protected Sub Page_Load(sender As Object, e As EventArgs)
PullData()
End Sub
Public Sub PullData()
'Get data from DB into a DataTable
Using conn As New SqlConnection("Server=.\sqlexpress;Database=DB;User Id=User;Password=Password;")
Using cmd As New SqlCommand("SELECT areaID as 'Pond Number', storageDescription + SPACE(1) + areaID as 'Pond Name', " & vbCr & vbLf & "case when fishWeight = 0 then 0 else 1 end as 'Pondis Used', 1 as 'Volume', " & vbCr & vbLf & "FeedDensity AS 'Feed Density',round(cast(FeedDensity * revolution as float(25)),2)/*cast as float for correct rounding*/ AS 'Feed Multiplier'," & vbCr & vbLf & "feedType as 'Feed Type', feedName as 'Feed Name', batchID AS 'FishBatchCode'" & vbCr & vbLf & vbCr & vbLf & "FROM dbo.vwStorageMASTER" & vbCr & vbLf & vbCr & vbLf & "WHERE fkLocationID = 1 AND fkStorageIndicator <> 3 ORDER BY sequenceNumber ASC", conn)
conn.Open()
Dim da As New SqlDataAdapter(cmd)
da.Fill(dataTable)
End Using
End Using
'Output tab-delimited
Dim delim As String = vbTab
Dim sb = New StringBuilder()
sb.AppendLine("Trafalgar Master File" & vbCr & vbLf & vbCr & vbLf)
sb.AppendLine(String.Join(delim, "Number of Ponds: ", dataTable.Rows.Count.ToString() & vbCr & vbLf & vbCr & vbLf))
sb.AppendLine(String.Join(delim, dataTable.Columns.Cast(Of DataColumn)().[Select](Function(arg) arg.ColumnName)))
For Each dataRow As DataRow In dataTable.Rows
sb.AppendLine(String.Join(delim, dataRow.ItemArray.[Select](Function(arg) arg.ToString())))
Next
'Prompt user to download tab-delimited file
Dim FileName As String = "test.xls"
Dim response As System.Web.HttpResponse = System.Web.HttpContext.Current.Response
response.ClearContent()
response.Clear()
response.ContentType = "text/plain"
response.AddHeader("Content-Disposition", "attachment; filename=" & FileName & ";")
response.Write(sb.ToString())
response.Flush()
response.[End]()
End Sub
While VB.Net and VBScript share a similar syntax, the objects that they use are entirely different animals. Vbscript has no knowledge of System.Web, System.Data, StringBuilder, etc. Instead, you might want to look into the VB6 syntax and the late bound CreateObject syntax to create AdoDb objects.
This was how I rewrote it for my application. In the end I basically started again but it's result is pretty much the same;
<%#LANGUAGE="VBSCRIPT" CODEPAGE="1252"%>
<%Response.Buffer = True%>
<!--#include file="Conn/conn.asp" -->
<%
Call DownloadFile()
Private Sub DownloadFile()
Dim Comm
Dim rst
Dim delim
delim = vbTab
response.Clear
set rst = Server.CreateObject("ADODB.Recordset")
rst.ActiveConnection = MM_Conn_STRING
rst.Open "Select COUNT(*) from vwTrafalgarMasterFile"
'Write titles
Response.Write("Trafalgar Master File" & vbcrlf & vbcrlf)
Response.Write("Number of Ponds: " & rst.Fields(0).Value & vbcrlf & vbcrlf)
If rst.State = 1 Then rst.Close 'Used 1 instead of AdStateOpen as this seemed to cause an error
rst.Open "Select * from vwTrafalgarMasterFile"
'Write headers
If Not rst.EOF Then
For Each fld In rst.Fields
Response.Write(fld.Name & delim)
Next
Response.Write vbcrlf
Else
Response.Write("There was a problem retrieving data or no data could be retrieved")
Response.End
Exit sub
End if
'Write rows
With rst
.MoveFirst
Do Until .EOF
For Each fld In rst.Fields
Response.Write(fld.Value & delim)
Next
Response.Write vbcrlf
.Movenext
Loop
End With
Dim FileName
FileName = "TrafalgarMasterFile.xls"
response.ContentType = "text/plain"
response.AddHeader "Content-Disposition", "attachment; filename=" + FileName + ";"
response.Flush
response.End
'Clean up
adoCMD.Close
Set Comm = Nothing
Set rst = Nothing
Set fld = Nothing
End Sub
%>
I put together some VBA code for Outlook 2007 which has been working predominantly fine.
Its basically designed to check incoming messages and store the subject, body etc into a database and the attachment into a folder. In general, it works fine, but out of 100 messages or so, it drops the odd email.
I previously had a problem where some emails were not being processed and stored in the database, but then discovered there was an issue with illegal characters, which i have solved now, so that cant be it. I've compared the emails being dropped to the one's that arent, in terms of message header, content to and from fields and i cant see any difference between the two emails at all, so am completely perplexed as to why they're being dropped. When i copy the content of the email and forward it back to the system again, the VBA code processes it fine.
I am pasting the code below (the code links to some modules which are used for checking illegal characters or concatenating strings)
Sub SaveIncomingEmails(Items As Outlook.MailItem) ' enable this to run macro inbound emails
Dim cnn As ADODB.Connection
Set cnn = New ADODB.Connection
' ================================================================
' Open a Connection using an ODBC DSN named "Delphi".
' ================================================================
cnn.Open "MyDB", "MyUsername", "MyPassword"
' ================================================================
' Constants declaration
' ================================================================
Const olFolderInbox = 6
Const olTxt = 0
' ================================================================
' variable declaration
' ================================================================
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim SenderName As String
Dim i As Integer
Dim strSQLquery As String
Dim strSQLquery1 As String
Dim strSQLGTDResourceQuery As String
Dim MessageHeader As String
Dim strCommandQuery As String
Dim strGTDIdQuery As String
Dim AttachmentStr As String
Dim strFailedRcp As String
Dim strSubject As String
Dim hasattachment As String
Dim AttachmentType As String
Dim SenderAuthorised As String
Dim strToEmail As String
Dim strFromEmail As String
Dim strBody As String
Dim strSentDate As String
Dim strReceivedDate As String
Dim StrUniqueID As String
Dim strCommandDate As String
Dim strDomain As String
Dim strBodyStripped As String
Dim strSubjectStripped As String
Dim rs As Object
Dim strGoalId As String
Dim strFile As String
Dim strSenderAccountDescription As String
Dim strContentType As String
Dim strMimeVersion As String
Dim strReceived As String
' ================================================================
' Intializing variables
' ================================================================
i = 0
Set objItem = Items
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set colMailItems = objFolder.Items
Set Item = objItem
strToEmail = Items.To
strFromEmail = Items.SenderEmailAddress
strSubject = Items.Subject
strBody = Items.Body
strSentDate = Items.SentOn
strReceivedDate = Items.ReceivedTime
'Initialize variables in a given format
StrUniqueID = Format(Items.ReceivedTime, "ddmmyyyyhhnnss") & Items.SenderEmailAddress
strCommandDate = Format(Items.ReceivedTime, "mm/dd/yyyy_hh:nn:ss")
' Grab the sender domain by stripping the last portion of the email address using the getdomain function
strDomain = Module2.GetDomain(Items.SenderEmailAddress)
' Strip the body of illegal characters and replace with legal characters for insertion into SQL
strBodyStripped = Module3.RemoveIllegalCharacters(Items.Body)
strSubjectStripped = Module4.RemoveIllegalCharacters(Items.Subject)
AttachmentStr = "images/no_attachment.png"
' ================================================================
' ================================================================
' ================================================================
' =====================================================
' Check list of authorised senders for xsCRM commands.
' Populate email addresses here
' =====================================================
If (InStr(strFromEmail, "AuthorisedSender1#email.com") > 0) Or (InStr(strFromEmail, "AuthorisedSender2#email.com") > 0) Or (InStr(strFromEmail, "AuthorisedSender3#email.com") > 0) Then
SenderAuthorised = "true"
End If
' ======================================================
' ======================================================
' ======================================================
' ================================================================
' check if subject holds a command
' ================================================================
'check to see if email sender is authorised
If SenderAuthorised = "true" Then
' Check if the subject line contains the string xs4crm is true
If InStr(strSubject, "xs4crm") > 0 Then
'If its true then do this
strCommandQuery = "INSERT INTO XSCRMEMAILCOMMAND (" & vbCrLf & _
"FromEmail," & vbCrLf & _
"command," & vbCrLf & _
"date," & vbCrLf & _
"Body" & vbCrLf & _
") VALUES ('" & strFromEmail & "','" & strSubject & "',GETDATE(),'" & strBody & "')"
Set rs = cnn.Execute(strCommandQuery)
'Look for a GTDID string so that we can save data to resources table
If InStr(strSubject, "gtdid=") > 0 Then
'Set the hasattachment variable to zero since we only want to run this loop if there are no attachments
hasattachment = "0"
'Set the variable to 1 so that we that our next if statement can only run if there are no attachments
For Each Atmt In Item.Attachments
hasattachment = "1"
Next Atmt
If hasattachment = "0" Then
'Grab the GTDId so we know which goal this resource belongs too.
strGoalId = Module5.GetHeaderProperty(strSubject, "gtdid=", ";", 5)
'Save data to table
strGTDIdQuery = "INSERT INTO XSCRMGTDRESOURCES (" & vbCrLf & _
"GoalId," & vbCrLf & _
"insertdatetime" & vbCrLf & _
") VALUES ('" & strGoalId & "',GETDATE())"
Set rs = cnn.Execute(strGTDIdQuery)
End If
End If
End If
End If
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' Create folders for atttachments
' ================================================================
' Save any attachments found
For Each Atmt In Item.Attachments
AttachmentStr = "images/attachment.png" 'because it has gone into attachment loop the icon is now required.
'Create the subfolder for the attachment if it doesnt exist based on sender domain
Dim fso
Dim fol As String
fol = "c:\OLAttachments\" & strDomain
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(fol) Then
fso.CreateFolder (fol)
End If
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' save attachments
' ================================================================
FileName = "C:\OLAttachments\" & strDomain & "\" & _
Format(Item.CreationTime, "ddmmyyyy-") & Items.SenderEmailAddress & "-" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
strFile = Atmt.FileName
strSQLquery1 = "INSERT INTO XSCRMEMAILSATTACHMENTS (" & vbCrLf & _
"FileSavedIn," & vbCrLf & _
"ActualFileName," & vbCrLf & _
"UniqueIdentifier," & vbCrLf & _
"SendersEmail" & vbCrLf & _
") VALUES ('" & FileName & "','" & StrUniqueID & "','" & strFile & "','" & strFromEmail & "')"
Set rs = cnn.Execute(strSQLquery1)
'If there is a GTDCommand, then grab the GTDId so we know which goal this resource belongs too.
If InStr(strSubject, "gtdid=") > 0 Then
strGoalId = Module5.GetHeaderProperty(strSubject, "gtdid=", ";", 5)
End If
AttachmentType = ""
'If the attachment is png or jpg set attachment type string to image
If (InStr(Atmt.FileName, ".png") > 0) Or (InStr(Atmt.FileName, ".jpg") > 0) Then
AttachmentType = "image"
End If
'If attachment is .mov set attachment type string to video
If InStr(Atmt.FileName, ".mov") > 0 Then
AttachmentType = "video"
End If
'If the attachment is mp3 or m4a set attachment type string to audio
If (InStr(Atmt.FileName, ".mp3") > 0) Or (InStr(Atmt.FileName, ".m4a") > 0) Then
AttachmentType = "audio"
End If
'check to see if email sender is authorised
If SenderAuthorised = "true" Then
'If attachment type is an image, audio or video as per extensions above then populate the xscrmgtdresource table with following fields
If (InStr(Atmt.FileName, ".png") > 0) Or (InStr(Atmt.FileName, ".jpg") > 0) Or (InStr(Atmt.FileName, ".mov") > 0) Or (InStr(Atmt.FileName, ".m4a") > 0) Or (InStr(Atmt.FileName, ".mp3") > 0) Then
strSQLGTDResourceQuery = "INSERT INTO XSCRMGTDRESOURCES (" & vbCrLf & _
"GoalId," & vbCrLf & _
"Title," & vbCrLf & _
"Type," & vbCrLf & _
"insertdatetime," & vbCrLf & _
"ResourcePath," & vbCrLf & _
"UniqueIdentifier" & vbCrLf & _
") VALUES ('" & strGoalId & "','" & Atmt.FileName & "','" & AttachmentType & "',GETDATE(),'" & FileName & "','" & StrUniqueID & "')"
End If
Set rs = cnn.Execute(strSQLGTDResourceQuery)
End If
Next Atmt
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' Setting up to work with the Email Message Header
' ================================================================
'This accesses the message header property and sets the variable MessageHeader
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
MessageHeader = objItem.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
If MessageHeader <> "" Then
End If
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' Accessing the message header and collecting specific info for database tables
' ================================================================
strSenderAccountDescription = Module5.GetHeaderProperty(MessageHeader, "From:", "<", 5)
strContentType = Module5.GetHeaderProperty(MessageHeader, "Content-Type:", ";", 13)
strMimeVersion = Module5.GetHeaderProperty(MessageHeader, "MIME-Version:", vbNewLine, 13)
strReceived = Module5.GetHeaderProperty(MessageHeader, "Received:", "(", 9)
'As the x-failed-recipients property does not appear in ALL messageheaders, we have to first check if it is present
If InStr(MessageHeader, "X-Failed-Recipients:") > 0 Then
'Get the MessageHeader Property value
strFailedRcp = Module5.GetHeaderProperty(MessageHeader, "X-Failed-Recipients:", vbNewLine, 20)
'Else set the variable value to blank so that we still have something to supply to the SQL query
Else
strFailedRcp = ""
End If
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' Save Email into the database DeplphiDude and table xsCRMEmails for attachment based emails and without attachments
' ================================================================
If InStr(strSubject, "xs4crm") = 0 Then 'only insert if the emails is not a command
strSQLquery = "INSERT INTO XSCRMEMAILS (" & vbCrLf & _
"XFailedRecipients," & vbCrLf & _
"Received," & vbCrLf & _
"MimeVersion," & vbCrLf & _
"ContentType," & vbCrLf & _
"SendersAccountDescription," & vbCrLf & _
"FromEmail," & vbCrLf & _
"ToEmail," & vbCrLf & _
"Subject," & vbCrLf & _
"Body," & vbCrLf & _
"SentDate," & vbCrLf & _
"ReceivedDate," & vbCrLf & _
"UniqueIdentifier," & vbCrLf & _
"Status," & vbCrLf & _
"AttachmentIcon," & vbCrLf & _
"AssignedToUser," & vbCrLf & _
"EmailHeader" & vbCrLf & _
") VALUES ('" & strFailedRcp & "','" & strReceived & "','" & strMimeVersion & "','" & strContentType & "','" & strSenderAccountDescription & "', '" & strFromEmail & "','" & strToEmail & "','" & strSubjectStripped & "','" & strBodyStripped & "','" & strSentDate & "','" & strReceivedDate & "','" & StrUniqueID & "','EmailStatus_New','" & AttachmentStr & "','','" & Module4.RemoveIllegalCharacters(MessageHeader) & "')"
Set rs = cnn.Execute(strSQLquery)
End If
' ================================================================
' final steps
' ================================================================
'Delete email
objItem.Delete
Set objItem = Nothing
Set Atmt = Nothing
' ================================================================
' close connection to the sql server and end the program
' ================================================================
cnn.Close
End Sub
You should add some logging to help track down the problem.
I haven't used this personally, but maybe give it a go: Log4VBA
Also, you should add error handling:
Error Handling and Debugging Tips for Access 2007, VB, and VBA
Error Handling In VBA
First you do not say which part of your process is not working. You have showed a routine that does not fire by itself, it must be called by something else. This something else must have some conditions attached to it to call your routine. What are they? Can you show the workings of this.
If you are using a rule then could you show the conditions of the rule. Further what about if instead of a rule we code for the event in the VBEditor so that you can maybe see this event happening as well? Here is what I am talking about and there is example code there on how to do it MSDN Application_New_MAIL
Next I agree with everyone else that you need some logging, there is so much going on and it is impossible to tell where you cod is falling over. If I were you I would get an email that does not work and send it to yourself and have a break point right at the beginning of your code so that you can see a. That your code is actually being called and then where it is failing.