|
|
|
|
BossMan
|
|
Feb 18, 2014, 02:01 AM
|
|
Is this possible in ONE button
So the last time I did any coding in Excel was with 2003 and I'm seriously rusty.
What I'm trying to do is create a button that prints to pdf and then mails the output to an e-mail address that's specified on a different sheet.
Or would it make more sense to save as pdf and send ?
Any pointers would be useful..
|
|
|
BossMan
|
|
Mar 26, 2014, 05:08 AM
|
|
Thanks JB, slowly getting there.
I've taken bits from various sources and have this, but could really do with an experts eyes.
Code:
Sub AttachActiveSheetPDF_01()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
' notes dims
Dim x As Integer
Dim UserName As String
Dim MailDbName As String
Dim Recipient As Variant
Dim Maildb As Object
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim stSignature As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
Dim stFileName As String
Dim vaRecipients As Variant
Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim stAttachment As String
Dim Specialfolders As Object
' Define PDF filename
Title = "Quote for " & Range("A1").Value
PdfFile = CreateObject("WScript.Shell").Specialfolders("Desktop") & "\" & Title & ".pdf"
stAttachment = Specialfolders("Desktop") & "\" & Title & ".pdf"
' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard,
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Open and locate current LOTUS NOTES User
' For x = 2 To Cells(Rows.Count, "A").End(xlUp).Row
' If Range("A" & x) = "Overdue" Then
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) &
".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
Else
Maildb.OPENMAIL
End If
' Create New Mail and Address Title Handlers
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)
' Select range of e-mail addresses
Recipient = Worksheets("Customer Info").Range("B" & x).Value
MailDoc.SendTo = Recipient
MailDoc.Subject = "Your Quote"
MailDoc.Body = "As discussed please find attached your quote" & vbCrLf & vbCrLf & stSignature
MailDoc.SaveMessageOnSend = True
MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
'Create the e-mail and the attachment.
Set noAttachment = MailDoc.CreateRichTextItem("stAttachment")
Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
MailDoc.SEND 0, Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
.ScreenUpdating = True
.DisplayAlerts = True
errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
End If
Next x
End With
'Release objects from memory.
Set noEmbedObject = Nothing
Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
MsgBox "The e-mail has successfully been created and distributed", vbInformation
End Sub
I'm currently getting a syntax error on this part:
Code:
' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard,
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
|
|
|
Software Expert
|
|
Mar 26, 2014, 11:41 PM
|
|
When a single command is too long to fit on one line comfortably and you put it on more than one line, you must add a space and an underline as a "linefeed" to indicate the command is continued on the next line:
Code:
' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
In the posted code above there was a second instance of a single command wrapped onto multiple lines that should be one line:
Code:
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
|
|
|
BossMan
|
|
Mar 27, 2014, 07:05 AM
|
|
Cheers JB,
Changes made.
Had it moaning at me about missing End if, End with and End Subs, so added them to the end of the VBA, now getting Run-Time error '91 Object variable or With block variable not set.
Here's the current code
Code:
Sub AttachActiveSheetPDF_01() Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
' notes dims
Dim x As Integer
Dim UserName As String
Dim MailDbName As String
Dim Recipient As Variant
Dim Maildb As Object
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim stSignature As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
Dim stFileName As String
Dim vaRecipients As Variant
Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim stAttachment As String
Dim Specialfolders As Object
' Define PDF filename
Title = "Quote for " & Range("A1").Value
PdfFile = CreateObject("WScript.Shell").Specialfolders("Desktop") & "\" & Title & ".pdf"
stAttachment = Specialfolders("Desktop") & "\" & Title & ".pdf"
' Export activesheet as PDF
If ActiveSheet.Index < Sheets.Count Then
Sheets(ActiveSheet.Index + 1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
' Open and locate current LOTUS NOTES User
' For x = 2 To Cells(Rows.Count, "A").End(xlUp).Row
' If Range("A" & x) = "Overdue" Then
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
Else
Maildb.OPENMAIL
End If
' Create New Mail and Address Title Handlers
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)
' Select range of e-mail addresses
Recipient = Worksheets("Customer Info").Range("B" & x).Value
MailDoc.SendTo = Recipient
MailDoc.Subject = "Your Quote"
MailDoc.Body = "As discussed please find attached your quote" & vbCrLf & vbCrLf & stSignature
MailDoc.SaveMessageOnSend = True
MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
'Create the e-mail and the attachment.
Set noAttachment = MailDoc.CreateRichTextItem("stAttachment")
Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
MailDoc.SEND 0, Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
.ScreenUpdating = True
.DisplayAlerts = True
errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
'Release objects from memory.
Set noEmbedObject = Nothing
Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
MsgBox "The e-mail has successfully been created and distributed", vbInformation
End If
End With
End Sub
|
|
|
Software Expert
|
|
Mar 27, 2014, 09:35 PM
|
|
I try to keep my WITH/END WITH ranges short and easy to spot.
I also am manic about the indentation of code to also make it inordinately easy to see where the IF and END IF parts match up.
I was getting an error on the EMBED_ATTACHMENT, so added that variable as a constant at the top of the macro, remove that if it's unnecessary in your environment:
Code:
Option Explicit
Const EMBED_ATTACHMENT As Long = 1454
Sub AttachActiveSheetPDF_01()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
' notes dims
Dim x As Integer
Dim UserName As String
Dim MailDbName As String
Dim Recipient As Variant
Dim Maildb As Object
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim stSignature As String
Dim stFileName As String
Dim vaRecipients As Variant
Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim stAttachment As String
Dim Specialfolders As Object
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
' Define PDF filename
Title = "Quote for " & Range("A1").Value
PdfFile = CreateObject("WScript.Shell").Specialfolders("Desktop") & "\" & Title & ".pdf"
stAttachment = Specialfolders("Desktop") & "\" & Title & ".pdf"
' Export activesheet as PDF
If ActiveSheet.Index < Sheets.Count Then
Sheets(ActiveSheet.Index + 1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
' Open and locate current LOTUS NOTES User
' For x = 2 To Cells(Rows.Count, "A").End(xlUp).Row
' If Range("A" & x) = "Overdue" Then
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
'do nothing
Else
Maildb.OPENMAIL
End If
' Create New Mail and Address Title Handlers
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)
' Select range of e-mail addresses
Recipient = Worksheets("Customer Info").Range("B" & x).Value
MailDoc.SendTo = Recipient
MailDoc.Subject = "Your Quote"
MailDoc.Body = "As discussed please find attached your quote" & vbCrLf & vbCrLf & stSignature
MailDoc.SaveMessageOnSend = True
MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
'Create the e-mail and the attachment.
Set noAttachment = MailDoc.CreateRichTextItem("stAttachment")
Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
MailDoc.SEND 0, Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
'Release objects from memory.
Set noEmbedObject = Nothing
Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
MsgBox "The e-mail has successfully been created and distributed", vbInformation
End If
End Sub
|
|
|
BossMan
|
|
Mar 28, 2014, 01:44 AM
|
|
Thanks JB.
I replaced my previous code with yours above, but still seeing a "Run-Time error '91 Object variable or With block variable not set."
This is in Excel 2010.
CB.zip
I've attached my sheet.
|
|
|
Software Expert
|
|
Mar 29, 2014, 02:14 AM
|
|
The problem appears to be this code:
Code:
PdfFile = CreateObject("WScript.Shell").Specialfolders("Desktop") & "\" & Title & ".pdf"
stAttachment = Specialfolders("Desktop") & "\" & Title & ".pdf"
The stAttachment looks like it's the same code as PdfFile, except it's missing the CreateObject reference so it's giving an error. If you fix it by adding the CreateObject reference, then it's idential to the PdfFile code, which seems like that would be wrong.
|
|
|
BossMan
|
|
Mar 31, 2014, 06:35 AM
|
|
Changes made.
Now getting weird error now...
|
|
|
Software Expert
|
|
Apr 3, 2014, 08:31 PM
|
|
Ok, your code is hiding the error, so let's reveal it. Change this code at the end of your macro:
Code:
End With
errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
'Release objects from memory.
Set noEmbedObject = Nothing
Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
MsgBox "The e-mail has successfully been created and distributed", vbInformation
End If
End Sub
To this:
Code:
End With
MsgBox "The e-mail has successfully been created and distributed", vbInformation
ExitReset:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
'Release objects from memory.
Set noEmbedObject = Nothing
Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
Exit Sub
End If
ErrorHandler1:
MsgBox Err.Description
Goto ExitReset
End Sub
|
|
|
BossMan
|
|
Apr 8, 2014, 12:52 AM
|
|
Slowly but slowly.
Now seeing ""Run-Time error '1004: Application-Defined or Object defined error"
Not highlighting the problem.
As you already noted I have defined both STattachment and pdffile to do the same thing, in creating the pdf file.
Would this be the cause of the problem ?
It's creating the pdf as expected, but not doing the notes part.
Code:
Option Explicit
Const EMBED_ATTACHMENT As Long = 1454
Sub AttachActiveSheetPDF_01()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
' notes dims
Dim x As Integer
Dim UserName As String
Dim MailDbName As String
Dim Recipient As Variant
Dim Maildb As Object
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim stSignature As String
Dim stFileName As String
Dim vaRecipients As Variant
Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim stAttachment As String
Dim Specialfolders As Object
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
' Define PDF filename
Title = "Quote for " & Range("A1").Value
PdfFile = CreateObject("WScript.Shell").Specialfolders("Desktop") & "\" & Title & ".pdf"
stAttachment = CreateObject("WScript.Shell").Specialfolders("Desktop") & "\" & Title & ".pdf"
' Export activesheet as PDF
If ActiveSheet.Index < Sheets.Count Then
Sheets(ActiveSheet.Index + 1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
' Open and locate current LOTUS NOTES User
' For x = 2 To Cells(Rows.Count, "A").End(xlUp).Row
' If Range("A" & x) = "Overdue" Then
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
'do nothing
Else
Maildb.OPENMAIL
End If
' Create New Mail and Address Title Handlers
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)
' Select range of e-mail addresses
Recipient = Worksheets("Customer Info").Range("B" & x).Value
MailDoc.SendTo = Recipient
MailDoc.Subject = "Your Quote"
MailDoc.Body = "As discussed please find attached your quote" & vbCrLf & vbCrLf & stSignature
MailDoc.SaveMessageOnSend = True
MailDoc.PostedDate = Now()
On Error GoTo ErrorHandler1
'Create the e-mail and the attachment.
Set noAttachment = MailDoc.CreateRichTextItem("stAttachment")
Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
MailDoc.SEND 0, Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox "The e-mail has successfully been created and distributed", vbInformation
ExitReset:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
'Release objects from memory.
Set noEmbedObject = Nothing
Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
Exit Sub
End If
ErrorHandler1:
MsgBox Err.Description
GoTo ExitReset
End Sub
|
|
|
BossMan
|
|
Apr 9, 2014, 02:10 PM
|
|
Well I think I've found that error, the attaching to Lotus Notes was causing the problem.
Taking that out and it produces the pdf fine.
User is ok with this as it wasn't actually all that important a part of this project, typical.
Now I need to get this code to work correctly.
Code:
' Export activesheet as PDF
If ActiveSheet.Index < Sheets.Count Then
Sheets(ActiveSheet.Index + 1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Now it's meant to convert the active sheet AND the following one into the same PDF
Does the following sheet fine, but not the active one.
|
|
|
Software Expert
|
|
Apr 11, 2014, 12:19 AM
|
|
First you have to ADD the next sheet to the "selected sheets". Once both sheets are selected you should get the results you want.
Code:
'Export activesheet and next sheet to PDF
If ActiveSheet.Index < Sheets.Count Then
ActiveWorkbook.Sheets(ActiveSheet.Index + 1).Select False
ActiveSheet.Activate
End If
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
|
|
Question Tools |
Search this Question |
|
|
Add your answer here.
Check out some similar questions!
Dryer button coneccted to washer button
[ 1 Answers ]
~ someone gave me a stackable kenmore washer/dryer #134234500 0405 are the numbers on it. The dryer will not come on unless the washer is running & ~ don't know why? I can't afford repairs so I am trying to get it going myself. Any advice would be great?
Overdrive button
[ 4 Answers ]
I need to know should the overdrive button be pushed off or left alone when you are in city traffic or on the highway? I think I may have this confused.
I thought it was suppose to be pushed in for off for city driving, but my Dakota feels like it is 'holding' back with it on the off position.
...
Press sleep button and switch on/off button to be able to see login screen
[ 1 Answers ]
Friend of mine has got problem with his new desktop (XP SP2) , when he starts the PC it boots normally till it reaches where it shows windows XP logo then the screen gets blank (i.e he can not see the login name for users).
What he used to do: is press the sleep button on the keyboard, then...
The browse button
[ 1 Answers ]
Hello
I am doing an application in VB.NET whereby I have to back up my database.
On the back-up database form I have a prompting label, a textbox(txtLocaction), a browse button(which should call some sort of dialog allowing me to select the location and be able to return it to the txtLocation...
View more questions
Search
|