I have the below code and it will open the email with the relevant details however the workbook is not attaching itself - cannot see why (being a newbie!)
Also is there a way of attaching a signature to the email? I'm using the newest version of the MS applications so not sure if this has any issues
Sub Email_workbook()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "pknight#xxxx.com"
.CC = ""
.BCC = ""
.Subject = "Daily UK Orders Report"
.Body = "Good afternoon, " & vbNewLine & vbNewLine & _
"Please see the attached report for today's UK orders" & vbNewLine & _
"Kind regards"
.Attachments.Add ActiveWorkbook.Daily_UK_Orders_Report.xlsm
.display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Thanks for your help
Phill
Related
Dear StackOverflowers.
I know a few programming languages, but unfortunately VBA is not one of them.
I'm trying to make a script that saves the headers from selected mails in Outlook as .msg-files.
I found a script that opens the headers as new messages, but how to I save them as e.g. [senders domain]_[date recieved].msg instead of opening them as new mails?
The script that I have:
Sub ViewInternetHeader()
Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
Dim strHeader As String
For Each olItem In Application.ActiveExplorer.Selection
strHeader = GetInetHeaders(olItem)
Set olMsg = Application.CreateItem(olMailItem)
With olMsg
.BodyFormat = olFormatPlain
.Body = strHeader
.Display
End With
Next
Set olMsg = Nothing
End Sub
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
' Purpose: Returns the internet headers of a message.'
' Written: 4/28/2009'
' Author: BlueDevilFan'
' //techniclee.wordpress.com/
' Outlook: 2007'
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkMsg.PropertyAccessor
GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
Set olkPA = Nothing
End Function
Use the MailItem.SaveAs method which saves the Microsoft Outlook item to the specified path and in the format of the specified file type. If the file type is not specified, the MSG format (.msg) is used. For example:
Sub SaveAsTXT()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".txt", olTXT
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
So you want an MSG file that has no recipients, attachments, subject, etc, only the MIME headers as the body? Why do you want the MSG format then?
You can create an populate a text file using the Scripting.FileSystemObject and use its CreateTextFile method.
Thank you, Eugene.
I managed to put in your code.
But it doesn't give the file a name, it's only called ".msg", and it doesn't work, when I try to select more than one email.
Also, how do I avoid, that it opens a new mail with the header?
I have this script now:
Sub ViewInternetHeader()
Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
Dim strHeader As String
For Each olItem In Application.ActiveExplorer.Selection
strHeader = GetInetHeaders(olItem)
Set olMsg = Application.CreateItem(olMailItem)
With olMsg
.BodyFormat = olFormatPlain
.Body = strHeader
.Display
End With
Next
Set olMsg = Nothing
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.SenderEmailAddress
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.saveas "C:\temp\" & strname & ".msg", OLTXT
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkMsg.PropertyAccessor
GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
Set olkPA = Nothing
End Function
I worked this code out stitching elements together. It takes worksheets from a workbook, saves them as individual workbooks in a new folder then emails them to the PMs for their action. I wrote it blindly not knowing how the workbook was structured. Then I found out the workbook (it's a restricted access file), has the first 4 worksheets that I need to ignore. I added another if loop to ignore worksheets that contain the string "IGNORE" in cell A2. It was working so fast before I added this if statement now it seems to take a lot longer. I fear it will be unreasonably slow on the workbook where I am going to implement it on (20 worksheets). I am going to watch it as it process in debug mode I guess, but any help would be greatly appreciated. Here's the code:
Sub SplitWorkbook()
'TMP June 5, 2018 Export and save worksheets as new Workbook in a new folder
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
'TMP June 5, 2018 added following dims for auto email generator submodule
Dim oApp As Object
Dim oMail As Object
Dim eAdd As Object
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
xWs.Copy
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
Set eAdd = ActiveSheet.Range("A2")
If eAdd <> "IGNORE" Then
xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
'TMP June 5,2018 Added submodule to create and show the Outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
Set eAdd = ActiveSheet.Range("A1")
With oMail
'selects the to from A1
.to = ActiveSheet.Range("A1")
'Sets the subject
.Subject = "Your hammer sheet is attached"
'Creates the body of the email
.body = ActiveSheet.Range("A2") & vbNewLine & vbNewLine & _
"Here is your hammer sheet to fill out and send back within 2 days" & vbNewLine & vbNewLine & "Thanks a lot," & vbNewLine & vbNewLine & "Mounir Samara"
.Attachments.Add xFile
.Display
End With
Application.ActiveWorkbook.Close False
End If ''IGNORE' if loop
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub
Apologies in advance for any incorrect terminology (I am a PC Tech, not a developer/programmer).
We have a VBScript running in one of our servers to send an email notice to users that their Windows password will expire and they need to change it. The script is as follows:
*******************Begin Code*****
on error resume next
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
Const E_ADS_PROPERTY_NOT_FOUND = &h8000500D
Const ONE_HUNDRED_NANOSECOND = .000000100
Const SECONDS_IN_DAY = 86400
strDomainDN = "DomainNameHere" 'Domain name here - both Netbios and DNS style names should work
ReminderAge = 10 'Days before the reminders start being sent
'strbody - Body of the message being sent
strbody = "This message is a reminder that your password will be expiring soon." & vbcrlf
strbody = strbody & "Please change your network password before the date listed above to avoid being locked out of the system." & vbcrlf
strbody = strbody & "If you need instructions on how to change your password please contact:" & vbcrlf
strbody = strbody & "the IT Department" & vbcrlf
strbody = strbody & vbcrlf & "Thank you," & vbcrlf
strbody = strbody & "IT Department"
'create logfile
Set objFSO = CreateObject("Scripting.FileSystemObject")
strScriptPath = objfso.GetParentFolderName(WScript.ScriptFullName)
strLogName = TwoDigits(Year(now)) & TwoDigits(Month(now)) & TwoDigits(Day(now)) & TwoDigits(Hour(now)) & TwoDigits(Minute(now)) &
TwoDigits(Second(now)) & ".txt"
strLogFile = strScriptPath & "Logs\" & StrLogName
Set objLogFile = objFSO.CreateTextFile(strLogFile,1)
objLogfile.Writeline "Email Password Check Script started: " & Now
Dim rootDSE,domainObject
Set rootDSE = GetObject("LDAP://RootDSE")
Set oDomain = GetObject("LDAP://" & strDomainDN)
Set maxPwdAge = oDomain.Get("maxPwdAge")
DomainContainer = rootDSE.Get("defaultNamingContext")
Set fs = CreateObject ("Scripting.FileSystemObject")
Set conn = CreateObject("ADODB.Connection")
conn.Provider = "ADSDSOObject"
conn.Open "ADs Provider"
numDays = CCur((maxPwdAge.HighPart * 2 ^ 32) + maxPwdAge.LowPart) / CCur(-864000000000)
'LDAP string to only find user accounts with mailboxes
ldapStr = "<LDAP://" & DomainContainer & ">;(& (mailnickname=*) (|
(&(objectCategory=person)(objectClass=user)(!(homeMDB=*))(!(msExchHomeServerName=*)))(&(objectCategory=person)(objectClass=user)(|(homeMDB=*)(msExchHomeServerName=*))) ));adspath;subtree"
Set rs = conn.Execute(ldapStr)
While Not rs.EOF
Set oUser = GetObject (rs.Fields(0).Value)
dtmValue = oUser.PasswordLastChanged
If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then
whenpasswordexpires = "The password has never been set."
else
whenPasswordExpires = DateAdd("d", numDays, oUser.PasswordLastChanged)
end if
daysb4expire = Int(whenPasswordExpires - Now)
'write user info to logfile
objLogfile.Writeline "-----------------------------------------"
objLogfile.Writeline "SAM Acct: " & oUser.SamAccountName
objLogfile.Writeline "Disp Name: " & oUser.displayName
objLogfile.Writeline "UPN: " & oUser.userprincipalname
objLogfile.Writeline "PW Changed: " & oUser.PasswordLastChanged
objLogfile.Writeline "PW Expires: " & whenPasswordExpires
dblMaxPwdNano = Abs(MaxPwdAge.HighPart * 2^32 + MaxPwdAge.LowPart)
dblMaxPwdSecs = dblMaxPwdNano * ONE_HUNDRED_NANOSECOND
dblMaxPwdDays = Int(dblMaxPwdSecs / SECONDS_IN_DAY)
objLogfile.Writeline "The password will expire on " & _
DateValue(dtmValue + dblMaxPwdDays) & " (" & _
Int((dtmValue + dblMaxPwdDays) - Now) & " days from today)."
if daysb4expire < ReminderAge and daysb4expire > 0 then
objLogfile.Writeline "Expiring soon - sending eMail"
objLogfile.Writeline "*****************************"
strNoteMessage = "Dear " & oUser.displayName & "," & vbcrlf & vbcrlf
strNoteMessage = strNoteMessage & "Your Network password will expire on " & _
DateValue(dtmValue + dblMaxPwdDays) & " (" & _
Int((dtmValue + dblMaxPwdDays) - Now) & " days from today)." & vbcrlf & vbcrlf
Set objEmail = CreateObject("CDO.Message")
objEmail.From = "me#myCompany.com" 'Your From Address
objEmail.To = oUser.userprincipalname
objEmail.Subject = "Network Password Expiration Notice" 'Message subject
objEmail.TextBody = strNoteMessage & strBody
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"YOUREXCHANGE.SERVER.DomainName.COM" ' Your mailserver here
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Update
'objEmail.Send 'commented out right now---so you won't send out the email.
End If
set whenpasswordexpires = nothing
err.clear
rs.MoveNext
Wend
Set oUser = Nothing
Set maxPwdAge = Nothing
Set oDomain = Nothing
Logfile.Close
Function TwoDigits(t)
TwoDigits = Right("00" & t,2)
End Function
WScript.quit
Obviously I removed our info from the script for this post.
The errors are that:
It does not send an email everyday if the user does not change their password for a few days. It sends them randomly.
A few random users, if they have not changed their password, around the 5th or 6th day will start getting hundreds of thousands of emails in just a few seconds, completely locking down Outlook on their computer. If they change the password they stop getting them (obviously).
Is there something I'm missing or need to remove from this script to get it to at least stop sending so many emails at once?
Thank you.
A couple of ideas to help you track down the problem.
Only have on error resume next before the command that needs it oUser.PasswordLastChanged, after that line on error goto 0 Then run the script manually and you'll have a better chance of finding some statement that is failing. update - should store the value in a variable and use
Get consistent with what variables are for. whenpasswordexpires is set to text in one part of the if err.number and a date in the other. It's then used as a date to calculate days and finally set whenpasswordexpires = nothing treats it like an object. This could mean some of your if statements are erroring and just going to the next line, instead of skipping the if - so people might be getting mailed when they shouldn't.
Consider calculating a date to pass to the LDAP query and only return people to be emailed - instead of going through all users all the time
(without ever having much to do with LDAP queries) I think your current query simplifies down to ldapStr = "<LDAP://" & DomainContainer & ">;(& (mailnickname=*)(objectCategory=person)(objectClass=user));adspath;subtree" all the ors and ands with homeMDB and msExchHomeServerName would seem to mean any combination is included. It's probably worth running your query in an LDAP explorer tool to check you're really getting what you want.
LDAP often has a limit of the number of records returned, so you might be erroring all the time because you get more than 1000 (typical) records returned. This can be worked around by getting data in smaller pages (say 250).
Logging to a new file each time may hide issues from you, e.g if the task is restarted by scheduler. Much easier to diagnose if there is just one log per day. You also don't close the log file correctly - should be objLogFile.Close (not logfile.Close). You aren't putting the log in a subdirectory of the scripts folder (e.g. scripts & scripts\logs) but at the same level (e.g. scripts & scriptsLogs)
The logfile not objLogFile issue highlights why it is best to put Option Explicit at the top of your code. This means you have to dim every variable that you use, which can be a pain to do, but ensures that you don't have typos in your variable names which can cause you massive headaches.
The WScript.Quit is the very last line, so won't do anything - the codes about to finish anyway. If you ever want to abort the execution of script, the WScript.Quit needs to where you want to abort from - normally within some if statement.
There are a number of repeated calculations... days, dtmValue + dblMaxPwdDays, etc. I just mention this as it makes the code harder to read and therefore harder to understand what might be wrong.
All that said, I've probably made too many comments now for you to really comprehend without me just making the changes and posting updated script for you to try.
See if this version runs error free for you...
option explicit
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
Const E_ADS_PROPERTY_NOT_FOUND = &h8000500D
Const ONE_HUNDRED_NANOSECOND = .000000100
Const SECONDS_IN_DAY = 86400
Dim strDomainDN, strBody, strNoteMessage
Dim objFSO, objLogFile, objEmail
Dim strScriptPath, strLogName, strLogFile
strDomainDN = "DomainNameHere" 'Domain name here - both Netbios and DNS style names should work
Const ReminderAge = 10 'Days before the reminders start being sent
'strbody - Body of the message being sent
strbody = "This message is a reminder that your password will be expiring soon." & vbcrlf
strbody = strbody & "Please change your network password before the date listed above to avoid being locked out of the system." & vbcrlf
strbody = strbody & "If you need instructions on how to change your password please contact:" & vbcrlf
strbody = strbody & "the IT Department" & vbcrlf
strbody = strbody & vbcrlf & "Thank you," & vbcrlf
strbody = strbody & "IT Department"
'create logfile
Set objFSO = CreateObject("Scripting.FileSystemObject")
strScriptPath = objfso.GetParentFolderName(WScript.ScriptFullName)
strLogName = TwoDigits(Year(now)) & TwoDigits(Month(now)) & TwoDigits(Day(now)) & ".txt"
strLogFile = strScriptPath & "Logs\" & StrLogName
Set objLogFile = objFSO.OpenTextFile(strLogFile, 8, True)
objLogFile.Writeline "Email Password Check Script started: " & Now
Dim rootDSE, oDomain, DomainContainer
Dim maxPwdAge, numDays
Dim conn, command
Dim ldapStr
Dim rs, oUser, passwordChanged, whenPasswordExpires, daysb4expire
Set rootDSE = GetObject("LDAP://RootDSE")
Set oDomain = GetObject("LDAP://" & strDomainDN)
Set maxPwdAge = oDomain.Get("maxPwdAge")
DomainContainer = rootDSE.Get("defaultNamingContext")
Set conn = CreateObject("ADODB.Connection")
Set command = CreateObject("ADODB.Command")
conn.Provider = "ADSDSOObject"
conn.Open "ADs Provider"
Set command.ActiveConnection = conn
command.Properties("Page Size") = 250
numDays = ABS(CCur((maxPwdAge.HighPart * 2 ^ 32) + maxPwdAge.LowPart) / CCur(864000000000))
'LDAP string to only find user accounts with mailboxes
Dim dteCnv, sec1601, strExpireDate, strRemindDate
dteCnv = DateAdd("d", -numDays, Now)
sec1601 = DateDiff("s","1/1/1601",dteCnv)
strExpireDate = CStr(sec1601) & "0000000"
dteCnv = DateAdd("d", ReminderAge - numDays, Now)
sec1601 = DateDiff("s","1/1/1601",dteCnv)
strRemindDate = CStr(sec1601) & "0000000"
ldapStr = "<LDAP://" & DomainContainer & ">;(& (mailnickname=*)(objectCategory=person)(objectClass=user)(pwdLastSet>=" & strExpireDate & ")(pwdLastSet<=" & strRemindDate & "));adspath;subtree"
command.CommandText = ldapStr
Set rs = command.Execute
While Not rs.EOF
Set oUser = GetObject (rs.Fields(0).Value)
on error resume next
passwordChanged = oUser.PasswordLastChanged
If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then
passwordChanged = "Never"
whenPasswordExpires = Now
elseIf Err.Number <> 0 Then
passwordChanged = "Unknown - " & Err.Description
whenPasswordExpires = Now
else
whenPasswordExpires = DateAdd("d", numDays, passwordChanged)
end if
on error goto 0
daysb4expire = Int(whenPasswordExpires - Now)
'write user info to logfile
objLogFile.Writeline "-----------------------------------------"
objLogFile.Writeline "SAM Acct: " & oUser.SamAccountName
objLogFile.Writeline "Disp Name: " & oUser.displayName
objLogFile.Writeline "UPN: " & oUser.userprincipalname
objLogFile.Writeline "PW Changed: " & passwordChanged
objLogFile.Writeline "PW Expires: " & whenPasswordExpires
objLogFile.Writeline "The password will expire on " & whenPasswordExpires & " (" & daysb4expire & " days from today)."
if daysb4expire <= ReminderAge and daysb4expire > 0 then
objLogFile.Writeline "Expiring soon - sending eMail"
objLogFile.Writeline "*****************************"
strNoteMessage = "Dear " & oUser.displayName & "," & vbcrlf & vbcrlf
strNoteMessage = strNoteMessage & "Your Network password will expire on " & whenPasswordExpires & " (" & daysb4expire & " days from today)." & vbcrlf & vbcrlf
Set objEmail = CreateObject("CDO.Message")
objEmail.From = "me#myCompany.com" 'Your From Address
objEmail.To = oUser.userprincipalname
objEmail.Subject = "Network Password Expiration Notice" 'Message subject
objEmail.TextBody = strNoteMessage & strBody
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "YOUREXCHANGE.SERVER.DomainName.COM" ' Your mailserver here
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Update
'objEmail.Send 'commented out right now---so you won't send out the email.
End If
err.clear
rs.MoveNext
Wend
Set oUser = Nothing
Set maxPwdAge = Nothing
Set oDomain = Nothing
objLogFile.Writeline "Email Password Check completed: " & Now & vbcrlf & vbcrlf
objLogFile.Close
Function TwoDigits(t)
TwoDigits = Right("00" & t,2)
End Function
I want to write a VBS macro to auto generate an email in outlook and attach a word document. I currently have a macro that does this for excel, but I can't get it to work for Word. I can't figure out for the life of me what my "FName= " should be. Any suggestions or help would be greatly appreciated. Here is what I have:
Sub AutoEmail()
On Error GoTo Cancel
Dim Resp As Integer
Resp = MsgBox(prompt:=vbCr & "Yes = Review Email" & vbCr & "No = Immediately Send" & vbCr & "Cancel = Cancel" & vbCr, _
Title:="Review email before sending?", _
Buttons:=3 + 32)
Select Case Resp
'Yes was clicked, user wants to review email first
Case Is = 6
Dim myOutlook As Object
Dim myMailItem As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWord & "\" & ActiveWord.Name
With otlNewMail
.To = ""
.CC = ""
.Subject = ""
.Body = "Good Morning," & vbCr & vbCr & "" & Format(Date, "MM/DD") & "."
.Attachments.Add FName
.Display
End With
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If no is clicked
Case Is = 7
Dim myOutlok As Object
Dim myMailItm As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With otlNewMail
.To = ""
.CC = ""
.Subject = ""
.Body = "Good Morning," & vbCr & vbCr & " " & Format(Date, "MM/DD") & "."
.Attachments.Add FName
.Send
'.Display
'Application.Wait (Now + TimeValue("0:00:01"))
'Application.SendKeys "%s"
End With
'otlApp.Quit
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If Cancel is clicked
Case Is = 2
Cancel:
MsgBox prompt:="No Email has been sent.", _
Title:="EMAIL CANCELLED", _
Buttons:=64
End Select
End Sub
May it is a bit late, but I want to solve it for future use.
You want to have the active document as your file name (FName).
FName = Application.ActiveDocument.Path + "\" + Application.ActiveDocument.Name
' .Path returns only the Path where the file is saved without the file name like "C:\Test"
' .Name returns only the Name of the file, including the current type like "example.doc"
' Backslash is needed because of the missing backslash from .Path
otlNewMail.Attachements.Add FName
May you also want to save your current document before sending it via outlook, otherwise you will send the document without the changes made.
Function SaveDoc()
ActiveDocument.Save
End Function
I hope that this will help others, because the code from the question helped me a lot while scripting a similar script.
I found code online for something I wanted to do.
As usual, I fired it up in Visual Studio and it works no problem.
The problem occurs in that, when I try to port it over to Excel, it ceases to work.
As I understand, VBA is a watered down version of VB. (Based on reading this article:
Difference between Visual Basic 6.0 and VBA)
Therefore, how to I find out what is lost between going between the two programming environments?
To give a bit more detail:
I wrote a program in Visual Studio that sends me an email when I press a button.
I then tried to port it into Excel as a Macro, but that didn't work.
EDIT: Adeed additional problem information
Here is what I have in Visual Studio
Public Class Form1
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
CDO_Mail_Small_Text()
End Sub
Sub CDO_Mail_Small_Text()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Object
iMsg = CreateObject("CDO.Message")
iConf = CreateObject("CDO.Configuration")
iConf.Load(-1) ' CDO Source Defaults
Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
= "morgan"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update()
End With
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
With iMsg
.Configuration = iConf
.To = "Jeremiah.Tantongco#Powerex.com"
.CC = ""
.BCC = ""
.From = """Ron"" <ron#something.nl>"
.Subject = "Important message"
.TextBody = strbody
.Send()
End With
End Sub
End Class
Here is what I have running in Excel:
Sub Button1_Click()
CDO_Mail_Small_Text
End Sub
Sub CDO_Mail_Small_Text()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Object
iMsg = CreateObject("CDO.Message")
iConf = CreateObject("CDO.Configuration")
iConf.Load (-1)
Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
= "morgan"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
With iMsg
.Configuration = iConf
.To = "Jeremiah.Tantongco#Powerex.com"
.CC = ""
.BCC = ""
.From = """Ron"" <ron#something.nl>"
.Subject = "Important message"
.TextBody = strbody
.Send
End With
End Sub
The not working is a:
"Run-time error '91':
Object variable or With block variable not set"
When I debug it takes me to the following line:
"iMsg = CreateObject("CDO.Message")"
Cheers,
-Jeremiah Tantongco
VBA is a compile-on-the-fly version of Classic VB. I always thought of it as sorta halfway between Full VB 6.0 and vb script. The key is you only have access to the basic VB 6.0 libraries and other COM libraries. Because many good com libraries are almost always available (like Scripting, ADO 2.6, the Office libraries like Excel and Word, etc.) this was actually very powerful.
However this is not .NET, and you have no access to .NET libraries whatsoever. When you say Visual Studio, do you mean Visual Studio 6.0? If you're copying code from VS.NET to Excel, that has no chance of working. But if you're copying code from VS6 (or earlier) to Excel VBA, you should be able to get that working. You probably just need to reference a library you were referencing in VS. We would need more information and of course the error.
In VB6/VBA you need to use the SET statement when working with objects
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Can't attest to the differences in code, but the following link has great examples of sending email in VBA. Might help you figure out what is going wrong.
http://www.rondebruin.nl/sendmail.htm