CreateChangesetAsync - How to checkin an existing file without knowing enconding or file type (just file path) - rest

i tried to follow the example on how to create a changeset with multiple files: [See link][1]
Although i am a bit stuck at the TFVCItem and ItemContent stage where i don't know how to extract the content and enconding of my file.
Im trying to write some code in order to checkin a file given to me by a filePath and check it in at a given location.
Would anyone care to help me out on how to do this?
This is what i came up so far:
Public Function CreateChangeset(ByVal projectName As String,
ByVal files As Dictionary(Of String, String),
ByVal comment As String) As TfvcChangesetRef
Dim c = TFSConnection.GetClient(Of TfvcHttpClient)
Dim newChangetset = New TfvcChangeset
Dim changes = New List(Of TfvcChange)
For Each fKP In files
Dim fileSource = fKP.Key
Dim fileTarget = fKP.Value
Dim newChange = New TfvcChange
newChange.ChangeType = VersionControlChangeType.Add
Dim newItem = New TfvcItem
newItem.Path = $"&/{projectName}/{fileTarget}"
newItem.ContentMetadata = New FileContentMetadata
'' TODO: How to extract the correct encoding, and type?...
'newItem.ContentMetadata.Encoding = GetFileEncoding(fileSource)
'newItem.ContentMetadata.ContentType = "text/plain"
'newChange.Item = newItem
'' TODO: How to extract the correct content, and type?...
'Dim newContent = New ItemContent
'newContent.Content = "Blabla"
'newContent.ContentType = ItemContentType.RawText
'newChange.NewContent = newContent
changes.Add(newChange)
Next
newChangetset.Changes = changes
newChangetset.Comment = comment
Dim changesetRef = c.CreateChangesetAsync(newChangetset).Result
Return changesetRef
End Function
UPDATE:
Ok so i managed to make it work but i still am not sure how to properly set the ContentType.
I have the choice between ItemContentType.RawText and ItemContentType.Base64Encoded but i am not sure when to use one or the other.
Here is the new code which seems to work:
Public Function CreateChangeset(ByVal projectName As String,
ByVal files As Dictionary(Of String, String),
ByVal comment As String) As TfvcChangesetRef
Dim c = TFSConnection.GetClient(Of TfvcHttpClient)
Dim newChangetset = New TfvcChangeset
Dim changes = New List(Of TfvcChange)
For Each fKP In files
' Extract and build our target and source paths.
Dim fileSource = fKP.Key
Dim fileTarget = fKP.Value
Dim fileName = IO.Path.GetFileName(fileSource)
Dim newChange = New TfvcChange
' Create the new TFVC item which will be checked-in.
Dim newItem = New TfvcItem
newItem.Path = $"$/{projectName}/{fileTarget}/{fileName}"
newItem.ContentMetadata = New FileContentMetadata
' Try to extract the item from the server.
Dim serverItem = c.GetItemAsync(newItem.Path).Result
If serverItem Is Nothing Then
' If the file is not on the server, then its a new file.
newChange.ChangeType = VersionControlChangeType.Add
Else
' Indicate that we are dealing with a file modification
' and specify which version we are editing.
newChange.ChangeType = VersionControlChangeType.Edit
newItem.ChangesetVersion = serverItem.ChangesetVersion
End If
' Read the file content to a stream.
Using reader = New StreamReader(fileSource,
Text.Encoding.Default,
True) ' This last parameter allows to extract the correct encoding.
Dim fileContent As String = String.Empty
' Read all the file content to a string so that we can store
' it in the itemcontent.
' NOTE: reading it also allows to retrieve the correct file enconding.
If reader.Peek() >= 0 Then
fileContent = reader.ReadToEnd
End If
' Set the file enconding and MIME Type.
newItem.ContentMetadata.Encoding = reader.CurrentEncoding.WindowsCodePage
newItem.ContentMetadata.ContentType = System.Web.MimeMapping.GetMimeMapping(fileSource)
newChange.Item = newItem
' Set the file content.
Dim newContent = New ItemContent
newContent.Content = fileContent
' TODO: What should be the logic to set the Content Type? Not too sure...
' If newItem.ContentMetadata.ContentType.StartsWith("text/") Then
newContent.ContentType = ItemContentType.RawText
' Else
' newContent.ContentType = ItemContentType.Base64Encoded
' End If
' Store the content to the change.
newChange.NewContent = newContent
End Using
changes.Add(newChange)
Next
newChangetset.Changes = changes
newChangetset.Comment = comment
Dim changesetRef = c.CreateChangesetAsync(newChangetset).Result
Return changesetRef
End Function

Related

AWS SDK .NET 4.5 "Error unmarshalling response back from AWS. HTTP Status Code: 200 OK" on ListObjectsV2

I am getting this error trying to list objects in a directory on a bucket. I cannot list from the root of the bucket as it has more than 1000 objects, so I need to drill farther down into the directory list to get what I want. My code works when I display from the root of the bucket, but when I try to add directories at the end of the bucket to list their contents I get this error. "Error unmarshalling response back from AWS. HTTP Status Code: 200 OK", "Root element is missing" on the ListObjectsV2. This is a public S3 bucket so I have included my code below so others can try it. I am using AWS-SDK-NET45.zip and compiling as Visual Basic 2019 for .NET 4.8 within an SSIS Script task. This should work, any ideas on what I am doing wrong? Thanks.
---CODE---
Imports System
Imports System.Data
Imports System.Math
Imports Microsoft.SqlServer.Dts.Runtime
Imports Amazon.S3
Imports Amazon.S3.Model
Imports Amazon.Runtime
Imports Amazon
Imports Amazon.S3.Util
Imports System.Collections.ObjectModel
Imports System.IO
'ScriptMain is the entry point class of the script. Do not change the name, attributes,
'or parent of this class.
<Microsoft.SqlServer.Dts.Tasks.ScriptTask.SSISScriptTaskEntryPointAttribute()>
<System.CLSCompliantAttribute(False)>
Partial Public Class ScriptMain
Inherits Microsoft.SqlServer.Dts.Tasks.ScriptTask.VSTARTScriptObjectModelBase
Public Sub Main()
'
' Add your code here
'
Dim filecol As ObservableCollection(Of String)
Try
'filecol = ListingFiles("/gov-fpac-rma-pubfs-production/pub/References/actuarial_data_master/2023/")
'filecol = ListingFiles("/gov-fpac-rma-pubfs-production/") 'Bucket root
filecol = ListingFiles("/gov-fpac-rma-pubfs-production/pub/")
Dts.TaskResult = ScriptResults.Success
Catch ex As Exception
Console.WriteLine(ex.Message.ToString)
Dts.TaskResult = ScriptResults.Failure
End Try
End Sub
#Region "ScriptResults declaration"
'This enum provides a convenient shorthand within the scope of this class for setting the
'result of the script.
'This code was generated automatically.
Enum ScriptResults
Success = Microsoft.SqlServer.Dts.Runtime.DTSExecResult.Success
Failure = Microsoft.SqlServer.Dts.Runtime.DTSExecResult.Failure
End Enum
#End Region
Private Function ListingFiles(bucketName As String, Optional foldername As String = "/") As ObservableCollection(Of String)
Dim obsv As New ObservableCollection(Of String)
Dim delimiter As String = "/"
Dim AWS_ACCESS_KEY As String = "xxxxxxxxxxxx" 'Add your Access Key here
Dim AWS_SECRET_KEY As String = "xxxxxxxxxxxxxxxxx" ' 'Add your Secret here
Dim s3config As AmazonS3Config = New AmazonS3Config
With s3config
.ForcePathStyle = True
.RegionEndpoint = RegionEndpoint.USEast1
End With
Dim s3Client As AmazonS3Client = New AmazonS3Client(AWS_ACCESS_KEY, AWS_SECRET_KEY, s3config)
If Not foldername.EndsWith(delimiter) Then
foldername = String.Format("{0}{1}", foldername, delimiter)
End If
Try
Try
Dim request As New ListObjectsV2Request()
With request
.BucketName = bucketName
End With
Do
Dim response As New ListObjectsV2Response()
response = s3Client.ListObjectsV2(request)
For i As Integer = 1 To response.S3Objects.Count - 1
Dim entry As S3Object = response.S3Objects(i)
If Not foldername = "/" Then
If entry.Key.ToString.StartsWith(foldername) Then
Dim replacementstring As String = Replace(entry.Key, foldername, "")
If Not replacementstring = "" Then
obsv.Add(replacementstring)
End If
End If
Else
obsv.Add(Replace(entry.Key, foldername, ""))
End If
MessageBox.Show(entry.Key + " " + entry.LastModified.ToString())
'Console.WriteLine("Object - " + entry.Key.ToString())
'Console.WriteLine(" Size - " + entry.Size.ToString())
'Console.WriteLine(" LastModified - " + entry.LastModified.ToString())
'Console.WriteLine(" Storage class - " + entry.StorageClass)
Next
If (response.IsTruncated) Then
request.ContinuationToken = response.NextContinuationToken
Else
request = Nothing
End If
Loop Until IsNothing(request)
Catch ex As AmazonS3Exception
Console.WriteLine(ex.Message.ToString)
Dts.TaskResult = ScriptResults.Failure
End Try
Catch ex As Exception
Console.WriteLine(ex.Message.ToString)
Dts.TaskResult = ScriptResults.Failure
End Try
Return obsv
End Function
End Class
Ok I added the prefix option to the ListObjectsV2Request as follows and it worked. I was able to get list of files from just the directory I wanted. I was side-tracked thinking it worked like the GetObjects function where you have to add the directory to the end of the bucketname and list the file you want in the Entry.Key. Hopefully others will find this of help since I did not find much for examples on this.
Dim request As New ListObjectsV2Request() 'With {.BucketName = bucketName}
With request
.BucketName = "/gov-fpac-rma-pubfs-production"
.Prefix = "pub/References/actuarial_data_master/2023/2023_"
End With

Getting Email Addresses for Recipients (Outlook)

I have a code that I was able to string together that logs my sent emails into an excel sheet so i can use that data for other analysis.
In it, I have it resolving the name into an email as outlook shortens it ("Jimenez, Ramon" = email#address.com) as outlook configured this and it works when i send an email to anyone in my company as they are in my address book.
Now, when I email anyone outside it defaults to lastName, firstName so it is not converting this and logging it.
I thought the code I have in here already does this, but I guess not. I have already come this far and I am NOT a software guru at all. Does anyone have insight on how I can also include this as well?? Please see code below:
Private WithEvents Items As Outlook.Items
Const strFile As String = "C:\Users\a0227084\Videos\work\test.xlsx"
Private Sub Application_Startup()
Dim OLApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set OLApp = Outlook.Application
Set objNS = OLApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
' ******************
FullName = Split(Msg.To, ";")
For i = 0 To UBound(FullName)
If i = 0 Then
STRNAME = ResolveDisplayNameToSMTP(FullName(i))
Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
ElseIf ResolveDisplayNameToSMTP(FullName(i)) <> "" Then
STRNAME = ResolveDisplayNameToSMTP(FullName(i))
Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
End If
Next i
'Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Sub tes2t()
End Sub
Function getRecepientEmailAddress(eml As Variant)
Set out = CreateObject("System.Collections.Arraylist") ' a JavaScript-y array
For Each emlAddr In eml.Recipients
If Left(emlAddr.Address, 1) = "/" Then
' it's an Exchange email address... resolve it to an SMTP email address
out.Add ResolveDisplayNameToSMTP(emlAddr)
Else
out.Add emlAddr.Address
End If
Next
getRecepientEmailAddres = Join(out.ToArray(), ";")
End Function
Function ResolveDisplayNameToSMTP(sFromName) As String
' takes a Display Name (i.e. "James Smith") and turns it into an email address (james.smith#myco.com)
' necessary because the Outlook address is a long, convoluted string when the email is going to someone in the organization.
' source: https://stackoverflow.com/questions/31161726/creating-a-check-names-button-in-excel
Dim OLApp As Object 'Outlook.Application
Dim oRecip As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
Dim oEDL As Object 'Outlook.ExchangeDistributionList
Set OLApp = CreateObject("Outlook.Application")
Set oRecip = OLApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
Dim PR_SMTP_ADDRESS As String
PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
ResolveDisplayNameToSMTP = oRecip.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
End Select
End If
End Function
Sub Write_to_excel(str1 As String, str2 As String, str3 As String)
Dim xlApp As Object
Dim sourceWB As Workbook
Dim sourceWH As Worksheet
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = True
.EnableEvents = False
End With
Set sourceWB = Workbooks.Open(strFile, False, False)
Set sourceWH = sourceWB.Worksheets("Sheet1")
sourceWB.Activate
With sourceWH
lastrow = .Cells(.rows.Count, "A").End(xlUp).Row
End With
sourceWH.Cells(lastrow + 1, 1) = str1
sourceWH.Cells(lastrow + 1, 2) = str2
sourceWH.Cells(lastrow + 1, 3) = str3
sourceWB.Save
sourceWB.Close
End Sub
Error message and corrected code
Regards,
Ramon
First of all, there is no need to create a new Application instance in the ResolveDisplayNameToSMTP method:
Set OLApp = CreateObject("Outlook.Application")
Instead, you can use the Application property available in the Outlook VBA editor out of the box.
Second, you need to use the following code to get the SMTP address from the AddressEntry object:
Dim PR_SMTP_ADDRESS As String
Set PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
ResolveDisplayNameToSMTP = oRecip.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
Instead of the following line:
ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
Read more about that in the How to get the SMTP Address of the Sender of a Mail Item using Outlook Object Model? article.

Updated Yahoo Weather API - .NET

I'm trying to implement the newest yahoo weather API in a .NET application (the one we were using was discontinued in favor of this new one): https://developer.yahoo.com/weather/documentation.html#commercial
Their only examples are in PHP and Java. I've done my best to convert the Java example to .NET but I still am getting a "401 - Unauthorized" response. I've gone over my code several times and cannot find any problems so I'm hoping someone else will be able to see where I went wrong. Code is below.
Private Sub _WeatherLoader_DoWork(sender As Object, e As DoWorkEventArgs)
Try
Dim oauth As New OAuth.OAuthBase
Dim forecastRssResponse As query
Dim appId As String = My.Settings.YahooAppID
Dim consumerKey As String = My.Settings.YahooAPIConsumerKey
Dim yahooUri As String = String.Format("{0}?location=billings,mt&format=xml", YAHOO_WEATHER_API_BASE_ENDPOINT)
Dim oAuthTimestamp As Integer = oauth.GenerateTimeStamp()
Dim oAuthNonce As String = oauth.GenerateNonce()
Dim parameters As New List(Of String)
Try
parameters.Add(String.Format("oauth_consumer_key={0}", consumerKey))
parameters.Add(String.Format("oauth_nonce={0}", oAuthNonce))
parameters.Add("oauth_signature_method=HMAC-SHA1")
parameters.Add(String.Format("oauth_timestamp={0}", oAuthTimestamp.ToString()))
parameters.Add("oauth_version=1.0")
' Encode the location
parameters.Add(String.Format("location={0}", HttpUtility.UrlEncode("billings,mt", Encoding.UTF8)))
parameters.Add("format=xml")
' Sort parameters ascending
parameters = parameters.OrderBy(Function(item) item).ToList()
Dim i As Integer = 0
Dim builder As New StringBuilder()
Do While (i < parameters.Count())
builder.Append(String.Format("{0}{1}", If(i > 0, "&", String.Empty), parameters(i)))
i += 1
Loop
Dim signatureString As String = String.Format("GET&{0}&{1}", HttpUtility.UrlEncode(YAHOO_WEATHER_API_BASE_ENDPOINT, Encoding.UTF8), HttpUtility.UrlEncode(builder.ToString(), Encoding.UTF8))
Dim oAuthSignature As String = _CreateOauthSignature(signatureString)
Dim authorizationLine As String = String.Format("OAuth oauth_consumer_key={0}, oauth_nonce={1}, oauth_timestamp={2}, oauth_signature_method=HMAC-SHA1, oauth_signature={3}, oauth_version=1.0", consumerKey, oAuthNonce, oAuthTimestamp, oAuthSignature)
Dim forecastRequest As WebRequest = WebRequest.Create(yahooUri)
forecastRequest.Headers.Add("Authorization", authorizationLine)
forecastRequest.Headers.Add("Yahoo-App-Id", appId)
' Cast to HttpWebRequest to set ContentType through property
CType(forecastRequest, HttpWebRequest).ContentType = "text/xml"
Dim forecastResponse As WebResponse = forecastRequest.GetResponse()
If forecastResponse IsNot Nothing Then
Using responseStream As Stream = forecastResponse.GetResponseStream()
Dim rssDoc As New XmlDocument()
rssDoc.Load(responseStream)
forecastRssResponse = rssDoc.OuterXml().FromXml(Of query)()
End Using
e.Result = forecastRssResponse
End If
Catch ex As Exception
e.Result = Nothing
LoadingManually = False
End Try
Catch ex As Exception
modMain.SendDevErrorEmail(ex, "_WeatherLoader_DoWork in WeatherWidget", "Catch around dowork code in fired from refresh timer event in wether widget")
e.Result = Nothing
LoadingManually = False
End Try
End Sub
Private Function _CreateOauthSignature(baseInfo As String) As String
Dim secretKey As String = String.Format("{0}&", My.Settings.YahooAPIConsumerSecretKey)
Dim encoding As New System.Text.ASCIIEncoding()
Dim keyBytes As Byte() = encoding.GetBytes(secretKey)
Dim messageBytes As Byte() = encoding.GetBytes(baseInfo)
Dim hashMessage As Byte()
Using hmac As New HMACSHA1(keyBytes)
hashMessage = hmac.ComputeHash(messageBytes)
End Using
Return Convert.ToBase64String(hashMessage)
End Function
After painstakingly creating a Java app, pasting in the Java example and stepping through it I found that the issue is in a poorly implemented URL Decode function on the receiving end.
In the Java app, URL Encode uses upper case characters while in .NET HTTPUtility.URLEncode uses lower case characters. This is enough to throw off your signature and cause a 401 - Unauthorized error.
My solution was to create a string extension method that will URL Encode in upper case:
<Extension>
Public Function UppercaseURLEncode(ByVal sourceString As String) As String
Dim temp As Char() = HttpUtility.UrlEncode(sourceString).ToCharArray()
For i As Integer = 0 To temp.Length - 2
If temp(i).ToString().Equals("%", StringComparison.OrdinalIgnoreCase) Then
temp(i + 1) = Char.ToUpper(temp(i + 1))
temp(i + 2) = Char.ToUpper(temp(i + 2))
End If
Next
Return New String(temp)
End Function
Using this extension method my signature gets created exactly like the one in the Java app and I am able to retrieve the response.
Hope this helps other .net programmers with this issue!

Mail merge with Libre Office using .net

I have following code block which is working perfectly for OpenOffice SDK to automate Mail merge functionality.
Public Function runQueryOnDataSource(ByVal nameOfdDtaource As String, ByVal query As String) As Boolean
strLog = strLog + vbCrLf + Now.ToString() + ": runQueryOnDataSource nameOfdDtaource:" + nameOfdDtaource + ",query:" + query + "-Started"
Dim oDB As Object, oBase As Object
Dim oStatement As Object
Dim rSQL As String
Dim oRequete As Object
Dim oServiceManager As Object, CreateUnoService As Object
Try
'Creation instance Open office
oServiceManager = CreateObject("com.sun.star.ServiceManager")
CreateUnoService = oServiceManager.createInstance("com.sun.star.sdb.DatabaseContext")
mxMSFactory = (uno.util.Bootstrap.bootstrap()).getServiceManager()
oDB = CreateUnoService.getByName(nameOfdDtaource) 'oDB=XDataSource
'Connection
oBase = oDB.getConnection("", "") 'oBase=XConnection
oStatement = oBase.createStatement 'XStatement
'rSQL = "SELECT * FROM ""26_MailMergeResult_DEMO"
rSQL = query
oRequete = oStatement.execute(rSQL)
Return True
Catch ex As Exception
strLog = strLog + vbCrLf + Now.ToString() + ": Exception" + ex.ToString()
Throw ex
Finally
oDB = Nothing
oBase.Close()
oBase.Dispose()
End Try
strLog = strLog + vbCrLf + Now.ToString() + ": runQueryOnDataSource-Finished"
Return True
End Function
Above code is used to insert data into the DataSource already registered with libre office.But Now when I try to use it, line oServiceManager = CreateObject("com.sun.star.ServiceManager") generates error "Error Creating ActiveX object".
Do anyone have idea, How do I fix this.
This code does not look right, so I'm surprised it ever worked. In other examples, the bootstrap() line always goes first. Then use that service manager instead of a separate oServiceManager variable.
For example, see the Java code at https://www.openoffice.org/udk/common/man/spec/transparentofficecomponents.html.
EDIT:
You're almost there. The getByName() method returns uno.Any, which has a property called Value that DirectCast can use.
Dim oDB As XDataSource
Dim oBase As XConnection = Nothing
Dim xContext As XComponentContext = uno.util.Bootstrap.bootstrap()
Dim xMSFactory As XMultiServiceFactory = DirectCast(
xContext.getServiceManager(), XMultiServiceFactory)
Dim xNameAccess As XNameAccess = DirectCast(
xMSFactory.createInstance("com.sun.star.sdb.DatabaseContext"), XNameAccess)
oDB = DirectCast(xNameAccess.getByName("Bibliography").Value, XDataSource)
oBase = DirectCast(oDB.getConnection("", ""), XConnection)

File attachment using SMTP in VB6

I am writing an VB6 application in which I'm making use of cdosys.dll in order to send mails. I am able to attach and send the mails but the problem that I'm facing is the attached file icon image is not getting displayed correctly (default icon image is getting displayed). Also I am not able to attach the files between two paragraphs in the body part. I am using IBM Lotus Notes mail system. Please find below the code that I'm using and also the screenshot of issue that I'm facing
Set objEmail = CreateObject("CDO.Message")
objEmail.MimeFormatted = True
objEmail.To = to address
objEmail.From = from address
objEmail.Subject = "Additional Replacement Letters : " & Format(Now, "mm/dd")
objEmail.TextBody = "Hello Team," & vbCrLf & vbCrLf & "find below the attached letters"
Set fld = FSO.GetFolder(path)
For Each fil In fld.Files
Set iBp = objEmail.AddAttachment(fil)
Next
objEmail.TextBody = "Revert to me for any concerns"
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.domain.com"
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Update
objEmail.Send
Please help me how to solve this issue.
First, for the icons of files appearing in the attachments section. If a generic file icon is displayed, it may be because either:
your system doesn't have any/the correct MIME type defined for *.doc files (shouldn't be the case if you have Word installed);
the client cannot match any extension (and thus an icon) to the MIME type included with an attached file; or
if the recipient is viewing the emails through a web-based email system, the provider might not have/provide an image to show as an icon for those types of files.
In most cases it's the client software that is too lazy to display the appropriate icon.
Now, if you want the files to appear amid the email body, this is another story. Here an overview of what needs to be done:
First, you don't add files through IMessage.AddAttachment() but with IMessage.AddRelatedBodyPart();
When called, IMessage.AddRelatedBodyPart() will return an IBodyPart object;
Using the IBodyPart object, you need to assign a unique content ID to the piece – you can use the file name, but whatever the CID it must not contain spaces;
You then need to write your email body in HTML (so you can link to them);
In the message you'll add links to related parts as such:
Link to the file
where %CONTENT_ID_OF_THE_FILE% is the content ID you set for the file. Example:
Link to the file
There are two things you'll have to remember if you insert files this way:
You won't see any icon aside or elsewhere related to the file(s) attached, i.e. they'll appear as you set them through your HTML code. If you want any, you'll have to add images (not icon files) the same way and refer to them using the <img> tag and their content ID.
In many clients, you won't see the files in the attachments section, unless they're not being referred to in the body (or their content ID doesn't match, which is the same thing)
Here is some code. It's pretty complete, as I had to test it because I wasn't sure to remember everything correctly. Also, it is assumed you have among the references for your project Microsoft CDO for Windows 2000 Library and Microsoft Scripting Runtime.
Public Function SendNewLetters(ByVal PathForLetters As String, ByVal FromName As String, ByVal FromEmail As String, ByVal ToName As String, _
ByVal ToEmail As String, ByVal SMTPServer As String, ByVal SMTPPort As Long, ByVal SMTPUser As String, _
ByVal SMTPPassword As String, Optional ByVal UseSSL As Boolean = False, Optional ByRef ErrorCode As Long = 0, _
Optional ErrorDesc As String = vbNullString) As Boolean
On Error GoTo ErrorHandler
Const CdoReferenceTypeName = 1
Dim iMsg As CDO.Message ' Not using CreateObject() because I have the reference added
Dim sFileCID As String, sFileExt As String
Dim sIconImageSrc As String, sIconImageCID As String
Dim iBpAttachment As CDO.IBodyPart ' Will be reused more than once
Dim iBpIconImage As CDO.IBodyPart
Dim oFSO As Scripting.FileSystemObject
Dim oFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim oDictAddedExtIcons As Scripting.Dictionary
Set iMsg = New CDO.Message
' Configure SMTP parameters
With iMsg.Configuration
.Fields(cdoSMTPServer) = SMTPServer
.Fields(cdoSMTPServerPort) = SMTPPort
.Fields(cdoSMTPUseSSL) = UseSSL
.Fields(cdoSMTPAuthenticate) = cdoBasic
.Fields(cdoSendUserName) = SMTPUser
.Fields(cdoSendPassword) = SMTPPassword
.Fields(cdoSMTPConnectionTimeout) = 60
.Fields(cdoSendUsingMethod) = cdoSendUsingPort
.Fields.Update
End With
' Set From and To fields
If Len(FromName) > 0 Then
' Let's say we already QP-encoded any special chars for the name
' and checked the email address
iMsg.From = FromName & " <" & FromEmail & ">"
Else
iMsg.From = FromEmail
End If
If Len(ToName) > 0 Then
' Same thing here
iMsg.To = ToName & " <" & ToEmail & ">"
Else
iMsg.To = ToEmail
End If
' Set subject (would need QP encoding as well)
iMsg.Subject = "Additional Replacement Letters : " & Format(Now, "mm/dd")
' Build the body
iMsg.HTMLBody = "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional //EN""><html><body><p>Hello Team,<br/><br/>" & _
"Please find below the attached letters</p><div style=""display: table"">"
' Will be used to make sure icon images are only added once
Set oDictAddedExtIcons = New Scripting.Dictionary
' Add files here, one new body part for each
Set oFSO = New Scripting.FileSystemObject
If oFSO.FolderExists(PathForLetters) Then
Set oFolder = oFSO.GetFolder(PathForLetters)
For Each oFile In oFolder.Files
' IMPORTANT: Content-IDs should not contain spaces
sFileCID = Replace$(oFile.Name, " ", "_")
Set iBpAttachment = iMsg.AddRelatedBodyPart(oFile.Path, oFile.Name, CdoReferenceTypeName)
iBpAttachment.Fields.Item("urn:schemas:mailheader:content-id") = "<" & sFileCID & ">"
iBpAttachment.Fields.Update ' Dont' forget that line
sFileExt = LCase$(GetFileExtension(oFile.Name))
sIconImageSrc = vbNullString
Select Case sFileExt
Case "doc"
' We provide here the path to a 32x32 image of the doc file icon
sIconImageSrc = "C:\Users\MyUserName\Desktop\DocIcon.png"
' We could also provide images for other extensions, or
' (more involved) query the DefaultIcon for any extension from
' the registry, load the icon from the ico/exe/dll file and
' find the best size/resize if necessary (already have the
' code, but it's a *lot* of code).
Case ".."
' Add support for more
End Select
If Len(sIconImageSrc) > 0 Then
If Not oDictAddedExtIcons.Exists(sFileExt) Then
sIconImageCID = GetFilePart(sIconImageSrc) ' Is the filename for this and the next line
Set iBpIconImage = iMsg.AddRelatedBodyPart(sIconImageSrc, sIconImageCID, CdoReferenceTypeName)
' IMPORTANT: Content-IDs should not contain spaces
sIconImageCID = Replace$(sIconImageCID, " ", "_")
iBpIconImage.Fields.Item("urn:schemas:mailheader:content-id") = "<" & sIconImageCID & ">"
iBpIconImage.Fields.Update ' Dont' forget that line
oDictAddedExtIcons.Add sFileExt, sIconImageCID
sIconImageSrc = "cid:" & sIconImageCID
Else
sIconImageSrc = "cid:" & oDictAddedExtIcons.Item(sFileExt)
End If
End If
iMsg.HTMLBody = iMsg.HTMLBody & "<div style=""display: table-row""><div style=""text-align: left; " & _
"vertical-align: middle; margin-right: 10px;"">"
If Len(sIconImageSrc) > 0 Then
iMsg.HTMLBody = iMsg.HTMLBody & "<img src=""" & sIconImageSrc & """ border=""0"" />"
Else
iMsg.HTMLBody = iMsg.HTMLBody & " "
End If
iMsg.HTMLBody = iMsg.HTMLBody & "</div><div style=""display: table-cell; text-align: left; vertical-align: middle;"">"
iMsg.HTMLBody = iMsg.HTMLBody & "" & oFile.Name & ""
iMsg.HTMLBody = iMsg.HTMLBody & "</div></div>"
Next
End If
iMsg.HTMLBody = iMsg.HTMLBody & "</div><br/>"
iMsg.HTMLBody = iMsg.HTMLBody & "<p>Revert to me for any concerns.</p></body></html>"
' Send away!
iMsg.Send
SendNewLetters = True
Exit Function
ErrorHandler:
ErrorCode = Err.Number
ErrorDesc = Err.Description
SendNewLetters = False
End Function
Public Function GetFilePart(ByVal FilePath As String) As String
Dim lPos As Long
lPos = InStrRev(FilePath, "\")
If lPos > 0 Then
GetFilePart = Right$(FilePath, Len(FilePath) - lPos)
End If
End Function
Public Function GetFileExtension(ByVal FilePath As String, Optional ByVal WithDot As Boolean = False) As String
Dim lPos As Long
lPos = InStrRev(FilePath, ".")
If InStr(1, FilePath, ".") Then
If WithDot Then
GetFileExtension = Right$(FilePath, Len(FilePath) - lPos + 1)
Else
GetFileExtension = Right$(FilePath, Len(FilePath) - lPos)
End If
End If
End Function
Here is the image I used for the *.doc icon:
And this is what it would look like when sent:
I hope it works for you!