View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
Steve E Steve E is offline
external usenet poster
 
Posts: 62
Default save and email button

Hi,
I've been to Ron DeBruin's site and have borrowed some code from there as
well as some info from other posts here trying t o cobble together the right
set of instructions to do the following in Excel2003:

I have a protected workbook with protected worksheets that is a *.xlt
(template) file.

The only sheet that my 'user' sees is a quote form - they select a set of
criteria and I return a price.

My users are all remote from our offices and I want to have a 'save and
register' macro on that form that saves a copy of the workbook on their c
drive [ c:\quotes\"wb.name" ] and email a copy of the workbook to a monitored
email address ).

Since I want this to be the only way a user can save the quote I also want
to disable the "save" and "save as" File menu options

So based on what I gleaned from these sources I have the following:

In the 'ThisWorkbook' module:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

End Sub
'Removes the save button from the toolbar and removes save from file menu
'User should only save by using save command button

In the Sheet1 code:

Public MySave As Boolean

Sub SaveAndEmailtoRegisterQuote()

MySave = True
Dim iMsg As Object
Dim iConf As Object
Dim wb As Workbook
Dim WBname As String
' Dim sPath As String
' Dim Flds As Variant

Application.ScreenUpdating = False
Set wb = ActiveWorkbook

' It will save a copy of the file in C:\Quotes\ with a Date and Time
stamp
WBname = ActiveSheet.Range("ProjectName") & " " & Format(Now,
"dd-mm-yy h-mm-ss") & ".xls"
wb.SaveCopyAs "C:\Quotes\" & WBname

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
'
..Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'
..Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Fill in
your SMTP server here"
'
..Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' .Update
' End With

With iMsg
Set .Configuration = iConf
.To = " & ";" &
Sheets("Sheet1").Range("SalesRep_EmailAddress").Va lue
.CC = "
.BCC = ""
.From = Sheets("Sheet1").Range("Contact_EmailAddress").Val ue
.Subject = "This is a test"
.TextBody = "This is the body text"
.AddAttachment "C:\Quotes\" & WBname
.Send
End With

'If you not want to delete the file you send delete this line
' Kill "C:\Quotes?" & WBname

Set iMsg = Nothing
Set iConf = Nothing
Set wb = Nothing
Application.ScreenUpdating = True

If Not MySave Then
Cancel = True
Else
MySave = False
End If
End Sub


With the "Sub SaveAndEmailtoRegisterQuote()" assigned to the button on my
worksheet as a macro.

I also set up a c:\quotes\ directory

I followed RdB's hint about setting the reference to Microsoft Outlook 11.0
Object Library (this is the version that matches my Excel version in the
reference list).

When I run the code (click the button) I get the following:

"System Error: &H80040220 (-2147220960)"

Anyone feel like helping this newbie figure out where the heck he's gone
wrong?

Thanks in advance,

Steve