I'm creating two Forms in Access to use as data entry forms. Both are unbound. The data is on assessment "measures" that are part of a standard my company follows. "Measures" is in quotes because a "measure" is often (thought not always) made up of multiple reportable values (called "submeasures" in the specs). That being the case my intent is to use one form is to enter in the portion of data that is related to the "measure", while the other captures the "submeasure" data when needed.
The plan is use a CommandButton to open the Submeasure Form when I need to capture data for a submeasure related to the parent measure. In trying to get that "Add Submeasure" button to work though I keep getting the error mentioned in the title.
Since A) the forms are unbound & B) there's not any data in any of the tables anyway I don't believe that corruption is the issue (which is what this article linked to in another question on RT Error 2501 discusses).
I'm also certain that it's nothing wrong in the Submeasure Form's Form_Load code, since I put a break point on the first line but didn't hit it before getting the error prompt.
The code for the Add Submeasure button follows:
Private Sub New_Sub_Click()
'
'Ensure we have a Key for this measure already NOTE: This Key is associated to each
submeasure so a ListBox can query for it in a table that holds the submeasure data
while I'm doing the data entry
If Me.Msr_Key.Value = "" Then
'notify
MsgBox "New submeasures cannot be created until a Key has been provided for the parent measure.", vbOKOnly, "Unable to Create Submeasures"
Else
'Open the form
DoCmd.OpenForm "New_SubMsr_Form" 'THIS IS THE LINE THAT ERRORS
'Set the form mode & Parent_Key values
Forms![New_SubMsr_Form]![Form_Mode].Value = "New"
Forms![New_SubMsr_Form]![Parent_Key].Value = Me.Msr_Key.Value
'Hide the Msr Form
Me.Visible = False
End If
End Sub
The full code for the New_Msr_Form is below:
Option Compare Database
Private Sub Cancel_Btn_Click()
'
'Clear everything and hide form
Me.Msr_Key.Value = Me.Msr_Key.DefaultValue
Me.Measure_Name.Value = Me.Measure_Name.DefaultValue
Me.Spec_Section.Value = Me.Spec_Section.DefaultValue
Me.Spec_Year_Created.Value = Me.Spec_Year_Created.DefaultValue
Me.Complexity.Value = Me.Complexity.DefaultValue
Me.Inc_Amb.Value = Me.Inc_Amb.DefaultValue
Me.Inc_Medicaid.Value = Me.Inc_Medicaid.DefaultValue
Me.Inc_Medicare.Value = Me.Inc_Medicare.DefaultValue
DoCmd.Close acForm, Me.Name
End Sub
Private Sub Form_Load()
'
'Restore defaults
Me.Msr_Key.Value = Me.Msr_Key.DefaultValue
Me.Measure_Name.Value = Me.Measure_Name.DefaultValue
Me.Spec_Section.Value = Me.Spec_Section.DefaultValue
Me.Spec_Year_Created.Value = Me.Spec_Year_Created.DefaultValue
Me.Complexity.Value = Me.Complexity.DefaultValue
Me.Inc_Amb.Value = Me.Inc_Amb.DefaultValue
Me.Inc_Medicaid.Value = Me.Inc_Medicaid.DefaultValue
Me.Inc_Medicare.Value = Me.Inc_Medicare.DefaultValue
End Sub
Private Sub Inc_Amb_Click()
'Update the "CheckBox" value correctly
Call Module1.Check_Uncheck(Me.Inc_Amb)
End Sub
Private Sub Inc_Medicaid_Click()
'Update the "CheckBox" value correctly
Call Module1.Check_Uncheck(Me.Inc_Medicaid)
End Sub
Private Sub Inc_Medicare_Click()
'Update the "CheckBox" value correctly
Call Module1.Check_Uncheck(Me.Inc_Medicare)
End Sub
Private Sub Denom_Only_Click()
'
'Update the "CheckBox" value correctly
Call Module1.Check_Uncheck(Me.Denom_Only)
End Sub
Private Sub Msr_Key_AfterUpdate()
'
Dim RowSrc_Str As String
'Is the field empty?
If Me.Msr_Key.Value = "" Or IsNull(Me.Msr_Key.Value) Then
'Make sure the row source is empty
RowSrc_Str = vbNullString
Else
'Populate the Row source string
RowSrc_Str = "SELECT Temp_SubMsrs.ID" & _
" , Temp_SubMsrs.Submeasure Name" & _
" , Temp_SubMsrs.Key" & _
" , Temp_SubMsrs.Complexity" & _
" , Temp_SubMsrs.Denom_Only" & _
"FROM Temp_SubMsrs" & _
"WHERE Temp_SubMsrs.Parent = " & Me.Msr_Key.Value & _
"ORDER BY Temp_SubMsrs.Submeasure Name;"
End If
'User RowSrc_Str to update the Submeasures field appropriately
Me.Submsrs.RowSource = RowSrc_Str
Me.Submsrs.Requery
End Sub
Private Sub New_Sub_Click()
'
'Ensure we have a Key for this measure already
If Me.Msr_Key.Value = "" Then
'notify
MsgBox "New submeasures cannot be created until a Key has been provided for the parent measure.", vbOKOnly, "Unable to Create Submeasures"
Else
'Open the form
DoCmd.OpenForm "New_SubMsr_Form"
'Set the form mode & Parent_Key values
Forms![New_SubMsr_Form]![Form_Mode].Value = "New"
Forms![New_SubMsr_Form]![Parent_Key].Value = Me.Msr_Key.Value
'Hide the Msr Form
Me.Visible = False
End If
End Sub
And the full VBA from the New_SubMsr_Form is here:
Option Compare Database
Private Sub Cancel_Btn_Click()
'
'Clear the form
Me.SubMsr_Name.Value = Me.SubMsr_Name.DefaultValue
Me.SubMsr_Key.Value = Me.SubMsr_Key.DefaultValue
Me.Complexity.Value = Me.Complexity.DefaultValue
Me.Denom_Only.Value = Me.Denom_Only.DefaultValue
'Hide the form
Me.Visible = False
'Unhide the Msr Form (if there is one)
If Not (Me.Parent_Key.Value = "" Or IsNull(Me.Parent_Key.Value)) Then
'Make the form visible
'Forms![New_Msr_Form].Visible
End If 'else there is no form to make visible
End Sub
Private Sub Denom_Only_Click()
'
'Update the "CheckBox" value correctly
Call Module1.Check_Uncheck(Me.Denom_Only)
End Sub
Private Sub Form_Load()
'
'Make sure the fields start on the correct values
If Me.Form_Mode.Value = "" Or IsNull(Me.Form_Mode.Value) Then
'First creation, use default values
Me.SubMsr_Name.Value = Me.SubMsr_Name.DefaultValue
Me.SubMsr_Key.Value = Me.SubMsr_Key.DefaultValue
Me.Complexity.Value = Me.Complexity.DefaultValue
Me.Denom_Only.Value = Me.Denom_Only.DefaultValue
ElseIf Me.Form_Mode.Value = "New" Then
'Default values
Me.SubMsr_Name.Value = Me.SubMsr_Name.DefaultValue
Me.SubMsr_Key.Value = Me.SubMsr_Key.DefaultValue
Me.Complexity.Value = Me.Complexity.DefaultValue
Me.Denom_Only.Value = Me.Denom_Only.DefaultValue
Else
'Update, get correct values
'Me.SubMsr_Name.Value = access.
'Me.SubMsr_Key.Value = Me.SubMsr_Key.DefaultValue
'Me.Complexity.Value = Me.Complexity.DefaultValue
'Me.Denom_Only.Value =
End If
'Set focus on name
Me.SubMsr_Name.SetFocus
End Sub
Private Sub Save_Btn_Click()
'
Dim Valid_Sub As Boolean
Valid_Sub = False
'Validate that the submeasure is unique
If Valid_Sub Then
'Create the Temp_SubMsrs record
DoCmd.OpenQuery Temp_SubMsr_Create
'Short cut to clearing & exiting SubMsr form is to now invoke Cancel_Click
'Me.Cancel_Btn.Click
Else
'Notify user
MsgBox "temp prompt text", vbOKOnly
End If
End Sub
Check_Uncheck is a function that basically turns a TextBox into a scalable CheckBox (since the native ones are entirely too small). It's code for context:
Public Sub Check_Uncheck(ByRef TBox As TextBox)
'
'Determine current value
If TBox.Value = "X" Then
TBox.Value = " "
Else
TBox.Value = "X"
End If
'Deselect
TBox.SelLength = 0
End Sub
Related
I need to send a very simple email with only text to a few recipients, but I'm getting an error.
I don't have an SMTP server to send emails through, but I do have an outlook and I'm logged in through the desktop app.
Here's the script so far:
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
objMail.Display
objMail.to = "recipient#whatever.com"
objMail.Subject = "Test"
objMail.Body = "test"
objMail.Send
objOutlook.Quit
Set objMail = Nothing
Set objOutlook = Nothing
When the script is run, WSH gives the error
line: 10
char: 1
error: Operation Aborted
source: (null)
This is the objMail.Send line.
And my outlook pops up with the proper recipient/subject/body, but it doesn't send.
I can't find anything related to this issue or a work around besides using an SMTP server which as far as I know I can't do.
I have a function defined and in daily use which accepts the various items for creating and sending the email. Remember if you have to create your Outlook instance, you need to log on with the appropriate mail profile in order to send anything. The profile we use here is just called "Outlook". Check what yours is called and include the Namespace stuff I have in mine.
Dim sComputer : sComputer = "." ' selects local machine
Dim oWMIService : Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")
Dim colItems : Set colItems = oWMIService.ExecQuery ("Select * from Win32_Process Where Name = 'outlook.exe'")
Dim oOutlook : Set oOutlook = CreateObject("Outlook.Application")
Dim oNamespace : Set oNamespace = oOutlook.GetNamespace("MAPI")
If colItems.Count = 0 Then
LOG_Write "Outlook isn't open, logging onto it..."
oNamespace.Logon "Outlook",,False,True ' name of Outlook profile
bOpenedOutlook = True
End If
Dim oFolder : Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox)
oFolder.Display ' Make Outlook visible
Here is basic vbscript simple email
' For Example...
Email_List = "0m3r#Email.com;"
Set App = CreateObject("Outlook.Application")
Set Mail = App.CreateItem(0)
With Mail
.To = Email_List
.CC = ""
.BCC = ""
.Subject = "Hello World"
.HTMLBody = "Bla Bla!!!"
'.Body = strbody
'You can add a file like this
' .Attachments.Add (FilePath)
'use .Send (to send) or .Display (to display the email and edit before sending)
.Display
.send
End With
Set Mail = Nothing
Set App = Nothing
Save is as name.vbs
I am trying to email a submission form based on the click of a command button. I have created the code to filter the form based on the 4 primary keys. But when I run the code the FleetID portion is pulling up as blank in the Immediate Pane. The FleetID portion is provided in a combobox. Can somebody help me?
Thanks
On Error GoTo errhandle
Me.Filter = "CurrentDate= #" & Format(Me!CurrentDate, "yyyy\-mm\-dd") & "# and DiscoverTime= '" & Me!DiscoverTime & "' And TailNumber= '" & Me!TailNumber & "' And FleetID= '" & Me!FleetID & "'"
Debug.Print Me.Filter
Me.FilterOn = True
DoCmd.SendObject acSendForm, "frmETIC", acFormatPDF, "EMAIL", "", "", "Recovery Report", "Attached is the submitted Recovery Report"
exiterr:
Exit Sub
errhandle:
If Err.Number <> 2501 Then
MsgBox ("Email cancelled!")
End If
Resume exiterr
Apart from my suggestions in the comment section. I would personally create a query and a desired report from that query. Reports gives you a very neat and professional look unlike forms with their extra controls.
First create a query same like your forms datasource
Create report out of that query. Design your report with your logo footer and all other stuffs you would like to have also the printing margin.
Generate your report with where condition and use the docmd.sendobject
Alternatively
Generate your report hidden with your where condition
Save the report as PDF file using docmd.outputTo
create new outlook email object and attach the PDF file
both ways have their own advantages. i personally use the second one because its much easier for me to customize the email content/template.
Here is a function to create emails:
Function SEND_EMAIL_MESSAGE(mTo As String, mCC As String, mBC As String, mSubject As String, mBody As String, Optional useOwnSignature As Boolean = False, Optional DisplayMsg As Boolean = False, Optional isHTML As Boolean = False, Optional AttachmentPath = "") As Boolean
' Please check the reference for Microsoft Outlook 14.0 object library for outlook 2010.
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookAttach As Outlook.Attachment
Dim mSignature As String
On Error GoTo ERROR_EMAIL
' Create the Outlook session.
Set objOutlook = New Outlook.Application
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
.To = mTo
.CC = mCC
.BCC = mBC
.Subject = mSubject
If useOwnSignature Then .BodyFormat = olFormatHTML
.Display
If useOwnSignature Then
If isHTML Then
mSignature = .HTMLBody
.HTMLBody = mBody & mSignature
Else
mSignature = .Body
.Body = mBody & mSignature
End If
Else
.Body = mBody
End If
' Add attachments to the message.
If Not IsMissing(AttachmentPath) Then
Dim mFiles() As String
If (VBA.Right(AttachmentPath, 1)) <> ";" Then AttachmentPath = AttachmentPath & ";"
mFiles = VBA.Split(AttachmentPath, ";")
Dim i As Integer
For i = 0 To UBound(mFiles) - 1
If Not mFiles(i) = "" Then Set objOutlookAttach = .Attachments.Add(mFiles(i))
Next i
End If
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Send
End If
End With
SEND_EMAIL_MESSAGE = True
EXIT_ROUTINE:
On Error GoTo 0
Set objOutlook = Nothing
Set objOutlookMsg = Nothing
Exit Function
ERROR_EMAIL:
SEND_EMAIL_MESSAGE = False
GoTo EXIT_ROUTINE
End Function
and you here some code you can generate the report and send to email:
strReportName = "rpt_incident_view_single"
DoCmd.OpenReport strReportName, acViewPreview, , strCriteria, acHidden
Dim tmpPath As String
tmpPath = VBA.Environ("temp")
strMyPath = tmpPath
If VBA.Right(strMyPath, 1) = "\" Then
strMyPath = strMyPath & "_" & incident_id & "_" & VBA.Format(Now, "yyyy-dd-mm") & ".pdf"
Else
strMyPath = strMyPath & "\" & "_" & incident_id & "_" & VBA.Format(Now, "dd-mm-yyyy") & ".pdf"
End If
DoCmd.OutputTo acOutputReport, strReportName, acFormatPDF, strMyPath, False
after saving the report just send it to the email function which will create new email and show it to the user:
SEND_EMAIL_MESSAGE mTo, mCC, mBcc, mSubject, mBody,,,, strMyPath
DoCmd.Close acReport, strReportName
on error resume next
VBA.Kill strMyPath
just modify your code as per your needs. good luck :)
So I just manually split a database following the steps found Here. For some reason the load event is not triggered on one form and on another the unload event is not triggered (but in each case, the opposite one does work). The second form (Unload not working) also refuses to go into design mode until I close it manually and then open it into design mode. I have confirmed that the open and close events are linked properly to their corresponding VBA code so I know that isn't it.
Any help with resolving this issue would be appreciated.
Edit-
Here is the code for the Load:
Private Sub Form_Load()
Dim scr As ScriptControl
Dim SQL As String
CheckConnection
Set scr = New ScriptControl
SQL = "UPDATE [Part Number] SET [Part Number].[Select] = False WHERE ((([Part Number].[Select])=True));"
CurrentDb.Execute SQL
scr.Language = "VBScript"
scr.AddCode "Sub T :Dim ChangeReg: Set ChangeReg = CreateObject(""WScript.Shell""):ChangeReg.regwrite " & _
"""HKCU\Software\Microsoft\Office\12.0\Access\Security\VBAWarnings"", ""1"", ""REG_DWORD"" : " & _
"Set ChangeReg = CreateObject(""WScript.Shell""):ChangeReg.regwrite " & _
"""HKCU\Software\Microsoft\Office\12.0\Excel\Security\VBAWarnings"", ""1"", ""REG_DWORD"": end sub"
scr.Run "T"
Locked = False
CancelBupdate = False
LockOff
USRID = Environ("Username")
TTTCount = 0
Started = True
SourceSelect.Value = 1
DoCmd.SelectObject acTable, , True
DoCmd.RunCommand acCmdWindowHide
DoCmd.ShowToolbar "Ribbon", acToolbarNo
ChgFrmOpen = False
Me.LocationSelect.Visible = False
Me.ClrSupLoc.Visible = False
Me.Label20.Visible = False
PSOn = True
Me.RepSelect.Value = ""
Me.SupplierSelect.Value = ""
Me.SupNumSelect.Value = ""
Me.LocationSelect.Value = ""
Me.Base5Select.Value = ""
Me.FullNbrSelect.Value = ""
Me.Label104.Caption = "Last Updated On: " & DLookup("[Last Updated]", "[Last Updated]")
ChangeCount = 0
CT = ""
CPP = ""
PGNP = ""
UpdateSub '****
InfoGet
RunFilter
Cascade
Me.Requery
Select Case USRID
Case "vn034153"
UsrInfoSt = "Logged in as User"
Case "vn043156"
UsrInfoSt = "Logged in as User"
Blah
Case "vn034157"
UsrInfoSt = "Logged in as Admin"
Me.UpdateButton.Visible = True
Case "vn034160"
UsrInfoSt = "Logged in as User"
Case "vn028040"
UsrInfoSt = "Logged in as User"
Case "vn028033"
UsrInfoSt = "Logged in as Admin"
Me.UpdateButton.Visible = True
Case "vn034931"
UsrInfoSt = "Logged in as User"
Case Else
UsrInfoSt = "Logged in as User"
End Select
Me.UsrInfo.Caption = UsrInfoSt
Application.SetOption "Confirm Action Queries", 0
Application.SetOption "Confirm Document Deletions", 0
Application.SetOption "Confirm Record Changes", 0
DoCmd.SetWarnings False
Application.SetOption "Auto compact", True
End Sub
And here is the code for the unload (using a cmd button and neither sub runs):
Private Sub OpenDatabase_Click()
DoCmd.OpenForm "2BHPartsDatabaseX"
DoCmd.Close acForm, Me.Name
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim TDF As TableDef
Dim QDF As QueryDef
Dim DBS As Database
Set DBS = CurrentDb()
Me.ReportForm.SourceObject = ""
For Each QDF In DBS.QueryDefs
If QDF.Name = "TempQRYX" Or QDF.Name = "DistinctPGNQry" Then
DBS.QueryDefs.Delete QDF.Name
End If
Next
For Each TDF In DBS.TableDefs
If TDF.Name = "ProjectTable" Then
DBS.TableDefs.Delete TDF.Name
Exit For
End If
Next
Application.SetOption "Confirm Action Queries", 1
Application.SetOption "Confirm Document Deletions", 1
Application.SetOption "Confirm Record Changes", 1
DoCmd.SetWarnings True
End Sub
I would comment (rem) out all the code in the Form_Load Event, and put a breakpoint on the
Sub procedure, then open the form to see if the event fires. After I see it fire,
I would begin to "un-rem" each line until the code line affecting the load event
is found.
I would do the same with the "Unload" issue.
Can someone help me.How to send an email with multiples attachments.
I am using cdo and SMTP Send Mail for VB6. Everything works great except I am only able to send one attachment at a time.
here's the code
Public Function SendMail(sTo As String, sSubject As String, sFrom As String, _
sBody As String, sSmtpServer As String, iSmtpPort As Integer, _
sSmtpUser As String, sSmtpPword As String, _
sFilePath As String, bSmtpSSL As Boolean) As String
On Error GoTo SendMail_Error:
Dim lobj_cdomsg As CDO.Message
Set lobj_cdomsg = New CDO.Message
lobj_cdomsg.Configuration.Fields(cdoSMTPServer) = sSmtpServer
lobj_cdomsg.Configuration.Fields(cdoSMTPServerPort) = iSmtpPort
lobj_cdomsg.Configuration.Fields(cdoSMTPUseSSL) = bSmtpSSL
lobj_cdomsg.Configuration.Fields(cdoSMTPAuthenticate) = cdoBasic
lobj_cdomsg.Configuration.Fields(cdoSendUserName) = sSmtpUser
lobj_cdomsg.Configuration.Fields(cdoSendPassword) = sSmtpPword
lobj_cdomsg.Configuration.Fields(cdoSMTPConnectionTimeout) = 30
lobj_cdomsg.Configuration.Fields(cdoSendUsingMethod) = cdoSendUsingPort
lobj_cdomsg.Configuration.Fields.Update
lobj_cdomsg.To = sTo
lobj_cdomsg.From = sFrom
lobj_cdomsg.Subject = sSubject
lobj_cdomsg.TextBody = sBody
If Trim$(sFilePath) <> vbNullString Then
lobj_cdomsg.AddAttachment (sFilePath)
End If
lobj_cdomsg.Send
Set lobj_cdomsg = Nothing
SendMail = "ok"
Exit Function
SendMail_Error:
SendMail = Err.Description
End Function
Private Sub cmdSend_Click()
Dim retVal As String
Dim objControl As Control
For Each objControl In Me.Controls
If TypeOf objControl Is TextBox Then
If Trim$(objControl.Text) = vbNullString And LCase$(objControl.Name) <> "txtAttach" Then
Label2.Caption = "Error: All fields are required!"
Exit Sub
End If
End If
Next
Frame1.Enabled = False
Frame2.Enabled = False
cmdSend.Enabled = False
Label2.Caption = "Sending..."
retVal = SendMail(Trim$(txtTo.Text), _
Trim$(txtSubject.Text), _
Trim$(txtFromName.Text) & "<" & Trim$(txtFromEmail.Text) & ">", _
Trim$(txtMsg.Text), _
Trim$(txtServer.Text), _
CInt(Trim$(txtPort.Text)), _
Trim$(txtUsername.Text), _
Trim$(txtPassword.Text), _
Trim$(txtAttach.Text), _
CBool(chkSSL.Value))
Frame1.Enabled = True
Frame2.Enabled = True
cmdSend.Enabled = True
Label2.Caption = IIf(retVal = "ok", "Message sent!", retVal)
End Sub
Private Sub cmdBrowse_Click()
Dim sFilenames() As String
Dim i As Integer
On Local Error GoTo Err_Cancel
With cmDialog
.FileName = ""
.CancelError = True
.Filter = "All Files (*.*)|*.*|HTML Files (*.htm;*.html;*.shtml)|*.htm;*.html;*.shtml|Images (*.bmp;*.jpg;*.gif)|*.bmp;*.jpg;*.gif"
.FilterIndex = 1
.DialogTitle = "Select File Attachment(s)"
.MaxFileSize = &H7FFF
.Flags = &H4 Or &H800 Or &H40000 Or &H200 Or &H80000
.ShowOpen
' get the selected name(s)
sFilenames = Split(.FileName, vbNullChar)
End With
If UBound(sFilenames) = 0 Then
If txtAttach.Text = "" Then
txtAttach.Text = sFilenames(0)
Else
txtAttach.Text = txtAttach.Text & ";" & sFilenames(0)
End If
ElseIf UBound(sFilenames) > 0 Then
If Right$(sFilenames(0), 1) <> "\" Then sFilenames(0) = sFilenames(0) & "\"
For i = 1 To UBound(sFilenames)
If txtAttach.Text = "" Then
txtAttach.Text = sFilenames(0) & sFilenames(i)
Else
txtAttach.Text = txtAttach.Text & ";" & sFilenames(0) & sFilenames(i)
End If
Next
Else
Exit Sub
End If
Err_Cancel:
End Sub
You are only passing in one file. Try passing in an array of files and loop through the array. Or, since it looks like its semicolon delimiting the list of files selected, try to just split the list...
For Each s As String in sFilePath.Split(";"c)
lobj_cdomsg.AddAttachemt(s)
Next
I have no idea how to run a vb 6 app anymore, but if this helps, please mark it so.
I have a userform that helps different users fill in data into the spreadsheet. As soon as the data is inserted it should also be sent by email to a few recipients, depending on the options filled in the form.
This happens within a corporate environment using Exchange. I would create a new email account for this file to be able to send the email as an entity and not use the user's email account.
Is this possible? How? I have googled for it and all I can find is how to create a mail message that the user sends from his account.
I've used the code below (source) to send e-mails from Excel-VBA. I've only tested it with my own e-mail account, but I assume you could have it send mail from a different account (msgOne.from = ...), as long as the user has permission to send from that account on the Exchange server.
Dim cdoConfig
Dim msgOne
Set cdoConfig = CreateObject("CDO.Configuration")
With cdoConfig.Fields
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServerPort) = 25 '465 ' (your port number) usually is 25
.Item(cdoSMTPServer) = "smtp.mysmtpserver.com" ' your SMTP server goes here
'.Item(cdoSendUserName) = "My Username"
'.Item(cdoSendPassword) = "myPassword"
.Update
End With
Set msgOne = CreateObject("CDO.Message")
Set msgOne.Configuration = cdoConfig
msgOne.To = "someone#somewhere.com"
msgOne.from = "me#here.com"
msgOne.subject = "Test CDO"
msgOne.TextBody = "It works just fine."
msgOne.Send
Unfortunately, I can't test this hypothesis at this time, as I'm only set up to send from one account. Let me know how it works out!
If the excel application is running on a machine with outlook, you can something along the following.
Function SendEmailWithOutlook(er As emailRecord,
recipients As String,
cc As String,
subject As String,
body As String,
attachmentPath As String) As Boolean
Dim errorMsg As String
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error GoTo errHandle
If (er.useTestEmail = True) Then
recipients = er.emailTest
cc = er.emailTest
End If
With OutMail
If er.emailFrom <> "" Then
.sentOnBehalfOfName = er.emailFrom
End If
.To = recipients
.cc = cc
.bcc = er.emailBcc
.subject = subject
.htmlBody = body
If attachmentPath <> "" Then
.Attachments.Add attachmentPath
End If
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
SendEmailWithOutlook = True
Exit Function
errHandle:
errorMsg = "Error sending mail via outlook: " & Err.Description & vbCrLf
errorMsg = errorMsg & "OnBehalfOf:" & er.emailFrom & vbCrLf
errorMsg = errorMsg & "Recipients: " & recipients & vbCrLf
errorMsg = errorMsg & "CC: " & cc & vbCrLf
errorMsg = errorMsg & "BCC: " & er.emailBcc
MsgBox errorMsg
SendEmailWithOutlook = False
End Function
Add a reference to Microsoft Outlook 14.0 Object Library
Why not use the Outlook Object Model?
You can give the current user the right to send on behalf of the specified user, then set MailItem.SentOnBehalfOfName and MailItem.ReplyRecipients (if necessary) properties before callign MailItem.Send.