I have been using CDOSys object for email sending in Classic ASP and it's work well with single file attachment but does not work correctly for multiple attachments.It takes the name and file extension of last attachment file for all attachments.Please let me know where is the issue.Below is my code
Function Send_Email_WithAttachments(strFrom,strTo,strSubject,strBody,strCC,strBCC,arrFiles,arrText)
Dim mailObj,I
Set mailObj=CreateObject("CDO.Message")
With mailObj
.Subject=strSubject
.From=strFrom
.To=strTo
If isValidEmail(strCC) = True Then
.CC = strCC
End If
If isValidEmail(strBCC) = True Then
.BCc = strBCC
End If
.HTMLBody = strBody
If IsArray(arrFiles) = True Then
For I=0 To UBound(arrFiles)
.AddAttachment arrFiles(I)
With mailObj.Attachments(1).Fields
.Item(cdoContentDisposition) = "attachment;filename="&arrText(I)
.Update
End With
Next
End If
.Send
End With
Set mailObj=Nothing
End Function
Thanks, Ravi
You address the same attachement (index==1) within the loop here:
With mailObj.Attachments(1).Fields
it should be;
With mailObj.Attachments(I).Fields
Related
On Error Resume Next
Set objSysInfo = CreateObject("ADSystemInfo")
Set WshShell = CreateObject("WScript.Shell")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.FullName
strTitle = objUser.Description
strCred = objUser.Info
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
strFailas1 = "1.jpg"
strFailas2 = "2.jpg"
strFailas3 = "3.jpg"
strFailas4 = "4.jpg"
strSPath1 = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%USERPROFILE%") & "\Appdata\Roaming\Microsoft\Signatures\" & strFailas1
strSPath2 = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%USERPROFILE%") & "\Appdata\Roaming\Microsoft\Signatures\" & strFailas2
strSPath3 = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%USERPROFILE%") & "\Appdata\Roaming\Microsoft\Signatures\" & strFailas3
strSPath4 = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%USERPROFILE%") & "\Appdata\Roaming\Microsoft\Signatures\" & strFailas4
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
If (strCred) Then objSelection.TypeText strName & ", " & strCred Else objSelection.TypeText strName
objSelection.TypeParagraph()
Set adoStream = CreateObject("ADODB.Stream")
adoStream.Open
adoStream.Charset = "UTF-8"
adoStream.LoadFromFile "file.txt"
BodyTEXT = adoStream.ReadText(-1)
adoStream.TypeText BodyTEXT
adoStream.Close
Set adoStream = Nothing
Set objSelection = objDoc.Range()
objSignatureEntries.Add "Full Signature", objSelection
objSignatureObject.NewMessageSignature = "Full Signature"
objDoc.Saved = True
objWord.Quit
I'm trying to create a VBScript to automatically genarate email signature for all users in Active Directory, but I have a problem. I want to insert UTF8 *.txt file as email signature body but it's not displayed after I run this script. Maybe I need to set it as different variable or something?
VBScript troubleshooting 101: remove On Error Resume Next, so you can actually see what goes wrong. Contrary to popular belief the statement doesn't magically make errors disappear. It just prevents the interpreter from telling you about them.
Never ever use globel On Error Resume Next in production code.
*steps off soap box*
With that said, you read the text into the variable BodyTEXT, which works just fine. However, you then try to call adoStream.TypeText with it. Without the global On Error Resume Next that statement would have raised an error
Object doesn't support this property or method.
because ADODB.Stream objects don't have such a method.
You probably intended to write objSelection.TypeText BodyTEXT instead.
So I'm trying to make something that takes emails from a specific folder, and saves the attachments in a specific folder. I've taken this code from a previous post and retooled it for my purposes. It runs without error, but it isn't saving the file in the specified folder, and I can't for the life of me figure it out. Can anyone see my errors?
Sub ExtractFirstUnreadEmailDetails()
Dim oOlAp As Object, oOlns As Object, oOlInb As Object
Dim oOlItm As Object, Br As Object
Dim oOlAtch As Object
Dim eSender As String, dtRecvd As String, dtSent As String
Dim sSubj As String, sMsg As String
'~~> Get Outlook instance
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
Set Br = oOlInb.Folders("Brokers")
'~~> Store the relevant info in the variables
For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")
eSender = oOlItm.SenderEmailAddress
dtRecvd = oOlItm.ReceivedTime
dtSent = oOlItm.CreationTime
sSubj = oOlItm.Subject
sMsg = oOlItm.Body
Exit For
Next
Const AttachmentPath As String = "C:\Desktop\Test"
'~~> New File Name for the attachment
Dim NewFileName As String
NewFileName = AttachmentPath & Format(Date, "DD-MM-YYYY") & "-"
'NewFileName = oOlItm.Subject & Format(Date, "DD-MM-YYYY") & "-"
'~~> Extract the attachment from the 1st unread email
For Each oOlItm In Br.Items
For Each oOlAtch In oOlItm.Attachments
Subject = "Test"
NewFileName = Subject
oOlAtch.SaveAsFile NewFileName & oOlAtch.Filename
Next
Exit For
Next
End Sub
I'd be so appreciative if anyone can point anything out. Thanks!
Picking a path at random is the road to failure.
The file should be saved in a folder named Test you created in C:\Desktop
Option Explicit
Sub ExtractFirstUnreadEmailDetails()
' Set up for Outlook
' not for other applications to use Outlook VBA code
Dim oOlInb As Folder
Dim Br As Folder
Dim oOlItm As Object
Dim oOlAtch As attachment
Dim Subject As String
'~~> Get Inbox of Outlook
Set oOlInb = Session.GetDefaultFolder(olFolderInbox)
Set Br = oOlInb.Folders("Brokers")
Const AttachmentPath As String = "C:\Desktop\Test"
'~~> New File Name for the attachment
Dim NewFileName As String
'~~> Extract the attachment from the 1st unread email
For Each oOlItm In Br.Items
For Each oOlAtch In oOlItm.Attachments
Subject = "Test"
' Note the often forgotten path separator
NewFileName = AttachmentPath & "\" & Subject & Format(Date, "DD-MM-YYYY") & "-" & oOlAtch.fileName
' C:\Desktop\Test\Test17-07-2018-fileName
Debug.Print NewFileName
oOlAtch.SaveAsFile NewFileName
Next
Exit For
Next
End Sub
The result should be a file named: Test17-07-2018-Filename in the folder C:\Desktop\Test
im trying to send an email from a VBScript, it will eventually be added into a currently working script as an else if (if this is possible).
im getting an error at line 23 character 32?
Dim outobj, mailobj
Dim strFileText
Dim objFileToRead
Set outobj = CreateObject("Outlook.Application")
Set mailobj = outobj.CreateItem(0)
strFileText = GetText("C:\test\test 2.txt")
With mailobj
.To = "user#user.com"
.Subject = "Testmail"
.Body = strFileText
.Display
End With
Set outobj = Nothing
Set mailobj = Nothing
End Sub
Function GetText(sFile as String) As String
Dim nSourceFile As Integer, sText As String
nSourceFile = FreeFile
Open sFile For Input As #nSourceFile
sText = Input$(LOF(1), 1)
Close
GetText = sText
End Function
what do i need to add to get line 23 to work and the script to finally do what i need it to, i have copied most of this script from elsewhere due to a sincere lack of VBscripting knowledge?
Take a look at the Using Automation to Send a Microsoft Outlook Message article. It provides a sample code and describes all the required steps for sending emails.
Try this: remove the GetText function entirely, and replace the line
strFileText = GetText("C:\test\test 2.txt")
with
Set fso = CreateObject("Scripting.FileSystemObject")
strFileText = fso.OpenTextFile("C:\test\test 2.txt").ReadAll
I am have the following code for excel vba that will email a range of addresses in my sheet. Howeve, I am looking to maybe use an inputbox to determine what the range is that I would like to email. The trouble i run into is getting the input to become a value that the function mailid understands. any suggestions?
Sub EmailActiveSheetWithOutlook2()
Dim oApp, oMail As Object, _
tWB, cWB As Workbook, _
FileName, FilePath As String
Application.ScreenUpdating = False
'Set email id here, it may be a range in case you have email id on your worksheet
Sheets("Sheet1").Select
mailId = Range("b4:b5").Value
'Write your email message body here , add more lines using & vbLf _ at the end of each line
Body = "Hello, it appears you have not yet filled out the transportation contact information excel sheet. This sheet was emailed to you, please complete this and send to me saved as your firstnamelastname.xls at your earliest convience." & vbLf _
& vbLf _
& "Thanks & Regards" & vbLf _
& vbLf _
& "-Ryan " & vbLf _
'Sending email through outlook
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
.To = mailid
.Subject = "Transportation Committee Notice"
.Body = Body
'.Attachments.Add tWB.FullName
.send
End With
End Sub
To replicate the effect of your current code use
mailid = Application.InputBox(Prompt:="Select Range", Type:=8)
where Type:=8 specifies a return type of Range. This returns the Value property of the selected range into mailid
Alternatively use
Dim rng as Range
Set rng = Application.InputBox(Prompt:="Select Range", Type:=8)
mailid = rng.Value
rng is then set to the selected range, and can be validated before use
Note that you should add error handling to account for, eg user Cancelling the InputBox
Do not set Application.ScreenUpdating = False before issuing InputBox as this will prevent the user interacting with the screen.
As an aside, your code uses Dim incorrectly: Dim'ing a variable without a As clause declares it as `Variant.
eg
Dim oApp, oMail As Object
actually declares oApp as a Variant, use
Dim oApp As Object, oMail As Object
I've got the code below, and I'm trying to set the from field to allow Unicode. Currently in my email client I get "??".
The subject line and any content shows the Unicode correctly. And looking at the MSDN, the property should be "urn:schemas:httpmail:from".
Anyone solved this issue?
Dim AC_EMAIL : AC_EMAIL = "test#test.com"
Dim AC_EMAIL_FROM : AC_EMAIL_FROM = "测试 <test#test.com>"
Dim strSubject : strSubject = """测试"" testing testing"
set oMessage = WScript.CreateObject("CDO.Message")
With oMessage
.BodyPart.charset = "utf-8" 'unicode-1-1-utf-8
.Fields("urn:schemas:httpmail:from") = AC_EMAIL_FROM
.Fields("urn:schemas:httpmail:to") = AC_EMAIL
.Fields("urn:schemas:httpmail:subject") = strSubject
.Fields.Update
.Send
End With
Set oMessage = Nothing
Found a work around. Not the prettiest, but it works. Basically I converted the string to Quoted-Printable.
.Fields("urn:schemas:httpmail:from") = "=?utf-8?Q?=E6=8F?= <test#test.com>"