#1
|
|||
|
|||
Making a Command Button that Prints, Saves and Emails
I'm extremly new to Visual Basic, all i know is what i've been picking up online in the past few month. I'm working on a template in word that Prints the document, Saves it then emails it to just one email. I had the code to a point where it worked perfectly on my machine aslong as you didnt click No in any of the message boxes. When you put the document on the network drives the Command Button no longer works even when enabling Macros and such. So then when brainstorming it will probably be easier to put it on our webpage for people to access then the network drive as that can be confusing to some users. The problem i ran across there is that when you open from the website it created opens the document as Read-Only and the code no longer Saves or Emails as i wanted it to but does print fine. I found a code that i've tried that makes it into a temp document and saves but loses formatting and doesnt email as the document thats open stays the same.
If you can point me in the right direction or have suggestions please let me know. Been working on this for abit now and would like some input. EDIT: I should also add maybe the important part. The reason i created the temp file was because the first line of the document is what i want it saved as and the Subject line of the email and when opened as read-only it just keeps that name and doesnt allow it to change. When the template was opened Word by default wants to save the document as whatever is in the first line of the document which is EXACTLY what i'm looking for. Thanks. Code:
Private Sub CommandButton1_Click() 'Save, Print and email documents Dim noSession As Object, noDatabase As Object, noDocument As Object Dim obAttachment As Object, EmbedObject As Object Dim stSubject As Variant, stAttachment As String Dim vaRecipient As Variant 'Print Document Shapes(1).Visible = msoFalse ActiveDocument.PrintOut Background:=False Shapes(1).Visible = msoTrue 'Check if the active Document is saved or not Const EMBED_ATTACHMENT As Long = 1454 Const stTitle As String = "Active Document status" Const stMsg As String = "The active Document must first be saved " & vbCrLf _ & "before it can be sent as an attachment." 'If the active Document has not been saved at all. If Len(ActiveDocument.Path) = 0 Then MsgBox stMsg, vbInformation, stTitle End If 'Ask then create folder if not created Dim rspCreate If Dir("E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\", vbDirectory) = "" Then rspCreate = MsgBox("Directory doesn't exist, do you wish to create it?", vbYesNo) If rspCreate = vbYes Then MkDir "E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\" End If End If 'If the changes in the active Document have been saved or not. If ActiveDocument.Saved = False Then ChangeFileOpenDirectory "E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\" ActiveDocument.Save End If 'Email address where file is sent to. vaRecipient = "myemail@mycompany.com" 'Get the message from the user. stAttachment = ActiveDocument.FullName 'Instantiate the Lotus Notes COM's Objects. Set noSession = CreateObject("Notes.NotesSession") Set noDatabase = noSession.GETDATABASE("", "") 'If Lotus Notes is not open then open the mail-part of it. If noDatabase.IsOpen = False Then noDatabase.OPENMAIL 'Create the e-mail and the attachment. Set noDocument = noDatabase.CreateDocument Set obAttachment = noDocument.CreateRichTextItem("stAttachment") Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment) 'Add values to the created e-mail main properties. With noDocument .Form = "Memo" .SendTo = vaRecipient .Subject = ActiveDocument.Name .Body = "Attached in this email is the EMS forum" .SaveMessageOnSend = True End With 'Send the e-mail instantly. With noDocument .PostedDate = Now() .Send 0, vaRecipient End With 'End message to users saying process was sucessful MsgBox "Document was emailed and printed sucessfully" 'Release objects from the memory. Set EmbedObject = Nothing Set obAttachment = Nothing Set noDocument = Nothing Set noDatabase = Nothing Set noSession = Nothing End Sub Code:
Private Sub CommandButton1_Click() Dim oSection As Section Dim r As Range Dim TempDoc As Document Dim FirstPara As String For Each oSection In ActiveDocument.Sections Set r = oSection.Range r.End = r.End - 1 Set TempDoc = Documents.Add With TempDoc .Range = r FirstPara = r.Paragraphs(1).Range.Text FirstPara = Left(FirstPara, Len(FirstPara) - 1) ChangeFileOpenDirectory "E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\" .SaveAs FileName:=FirstPara & ".docx" .Close End With Set r = Nothing Set TempDoc = Nothing Next End Sub |
#2
|
|||
|
|||
After pluggin away at this for some time i maybe onto something. In the code that creates the TempDoc there is a line
Code:
FirstPara = r.Paragraphs(1).Range.Text Randy Last edited by rmw85; 05-03-2012 at 06:21 AM. |
#3
|
||||
|
||||
hi rwm,
Let's start with the basics: Quote:
Quote:
I also note that you have posted two subs named 'CommandButton1_Click'. You can't have two such subs attached to the one userform. So, how many userforms are we dealing with and on which ones don't the command buttons work? Do you get any error messages? If so, what do they say and what, if any, line is highlighted when you enter the debug mode? Have you added some code to the command button subs to test where they're failing? You could, for example, use something as simple as 'MsgBox "!"' to confirm that the code runs to a certain point. Re: Quote:
Re: Quote:
You say "it worked perfectly on my machine aslong as you didnt click No in any of the message boxes". Obviously, you'll need to fix that. I note, for example, that you have code that asks the user whether a certain folder exists. Even if the user answers no to that prompt, your code then tries to save the file there. It's bound to fall over in that case. You either need to create the folder without asking the user or, if they choose 'no', asking them where to save the filke to and not proceeding until they've nominated a valid destination, to which the file is then saved.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#4
|
|||
|
|||
Thanks for the reply.
I'm pretty sure its a template that i am working on as its a .dotm extension. The reason for the two command codes is because i tried the one it worked great but doesnt when its opened of the website as READ ONLY so i cut that code and pasted it somewhere else and used a new code to try and figure out how to get the document out of the read only but havent had much luck with the smaller second code. Quote:
Quote:
Quote:
I know the basics of word but once i get further into detail with macro's and Visual Basic i'm basically teaching myself as i'm building this document. Thanks, Randy Here is some code i got to come close to what i'm attempting. The formatting is still alittle messed up as in the margins and spacing but it shows the tables in there. I put a note in there which is just a place holder to when i figured out how to acheived what i'm looking for then i was going to add the first code (the longer one) and piece that into there and it should in theory work the way i'd like it to. Code:
Private Sub CommandButton1_Click() Dim oSection As Section Dim r As Range Dim TempDoc As Document Dim FirstPara As String For Each oSection In ActiveDocument.Sections Set r = oSection.Range r.End = r.End - 1 Set TempDoc = Documents.Add With TempDoc ActiveDocument.Paragraphs(1).Range.FormattedText = r FirstPara = r.Paragraphs(1).Range.FormattedText FirstPara = Left(FirstPara, Len(FirstPara) - 1) ChangeFileOpenDirectory "E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\" .SaveAs FileName:=FirstPara & ".docx" 'Dont have this close yet make it print then email and close .Close End With Set r = Nothing Set TempDoc = Nothing Next End Sub Last edited by rmw85; 05-03-2012 at 06:54 AM. Reason: Added code |
#5
|
||||
|
||||
Hi Randy,
OK, if the useform & command button show, the code behind them should be there also. In that case, try adding something like: MsgBox "!" at different points in the code so that you can see where is runs to. Instead of your latest sub, try: Code:
Private Sub CommandButton1_Click() Application.ScreenUpdating = False Dim Scn As Section, Rng As Range, Doc As Document Dim StrPath As String, StrName As String StrPath = "E:\Documents and Settings\" & Environ("UserName") & "\Desktop\EMS\" If Dir(StrPath, vbDirectory) = "" Then MkDir StrPath End If For Each Scn In ActiveDocument.Sections Set Rng = Scn.Range With Rng .End = .End - 1 .Copy End With Set Doc = Documents.Add With Doc .Range.Paste Set Rng = .Range.Paragraphs.First With Rng .End = .End - 1 StrName = .Text End With .SaveAs FileName:=StrPath & StrName & ".docx", AddToRecentFiles:=False .Close End With Next Set Rng = Nothing: Set Doc = Nothing Application.ScreenUpdating = True End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#6
|
|||
|
|||
Thanks Paul. I tried the code out but was getting some errors when trying to run it.
I was messing around with the code below some more and added the other line of code to it to make it the ALL IN ONE that i'm going for. I'm having problems with the email part now. It stops at this line Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment) but i'm getting close with the code i have posted below Thanks very much for the suggestion. I'm still open up to some and even putting code together to make this work. Thats all the code i have no is pieced together and tweaked here and there. Thanks, Randy Code:
Private Sub CommandButton1_Click() Dim oSection As Section Dim r As Range Dim TempDoc As Document Dim FirstPara As String 'Print Document Shapes(1).Visible = msoFalse ActiveDocument.PrintOut Background:=False Shapes(1).Visible = msoTrue 'Change Readonly Doc to a Temp Document For Each oSection In ActiveDocument.Sections Set r = oSection.Range r.End = r.End - 1 Set TempDoc = Documents.Add With TempDoc 'Change Temp Documents Page Layout to match Original With Selection.PageSetup .LineNumbering.Active = False .Orientation = wdOrientPortrait .TopMargin = InchesToPoints(0.5) .BottomMargin = InchesToPoints(0.5) .LeftMargin = InchesToPoints(0.5) .RightMargin = InchesToPoints(0.5) .Gutter = InchesToPoints(0) .HeaderDistance = InchesToPoints(0.5) .FooterDistance = InchesToPoints(0.5) .PageWidth = InchesToPoints(8.5) .PageHeight = InchesToPoints(11) .FirstPageTray = wdPrinterDefaultBin .OtherPagesTray = wdPrinterDefaultBin .SectionStart = wdSectionNewPage .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .VerticalAlignment = wdAlignVerticalTop .SuppressEndnotes = False .MirrorMargins = False .TwoPagesOnOne = False .BookFoldPrinting = False .BookFoldRevPrinting = False .BookFoldPrintingSheets = 1 .GutterPos = wdGutterPosLeft End With 'Ask then create folder if not created Dim rspCreate If Dir("E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\", vbDirectory) = "" Then rspCreate = MsgBox("Directory doesn't exist, do you wish to create it?", vbYesNo) If rspCreate = vbYes Then MkDir "E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\" End If End If 'Set it so that the first paragraph is the name of document ActiveDocument.Paragraphs(1).Range.FormattedText = r FirstPara = r.Paragraphs(1).Range.FormattedText FirstPara = Left(FirstPara, Len(FirstPara) - 1) 'save document ChangeFileOpenDirectory "E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\" .SaveAs FileName:=FirstPara & ".docx" 'Print and email documents Dim noSession As Object, noDatabase As Object, noDocument As Object Dim obAttachment As Object, EmbedObject As Object Dim stSubject As Variant, stAttachment As String Dim vaRecipient As Variant 'Email address where file is sent to. vaRecipient = "email@myemail.com" 'Get the message from the user. stAttachment = ActiveDocument.FullName 'Instantiate the Lotus Notes COM's Objects. Set noSession = CreateObject("Notes.NotesSession") Set noDatabase = noSession.GETDATABASE("", "") 'If Lotus Notes is not open then open the mail-part of it. If noDatabase.IsOpen = False Then noDatabase.OPENMAIL 'Create the e-mail and the attachment. Set noDocument = noDatabase.CreateDocument Set obAttachment = noDocument.CreateRichTextItem("stAttachment") Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment) 'Add values to the created e-mail main properties. With noDocument .Form = "Memo" .SendTo = vaRecipient .Subject = ActiveDocument.Name .Body = "Attached in this email is the EMS forum" .SaveMessageOnSend = True End With 'Send the e-mail instantly. With noDocument .PostedDate = Now() .Send 0, vaRecipient End With 'End message to users saying process was sucessful MsgBox "Document was emailed and printed sucessfully" 'Release objects from the memory. Set EmbedObject = Nothing Set obAttachment = Nothing Set noDocument = Nothing Set noDatabase = Nothing Set noSession = Nothing .Close End With Set r = Nothing Set TempDoc = Nothing Next End Sub Last edited by rmw85; 05-04-2012 at 12:04 PM. Reason: Changed the post. Added newest code. |
#7
|
|||
|
|||
Just to let you know I get the error
Runtime error '13": type mismatch This is highlighted in yellow Set Rng = .Range.Paragraphs.First |
#8
|
|||
|
|||
Well for the bulk of the code the issue is solved. Thanks for the help and suggestions. Been throwing everything at it i can find and came up with this code below. Its not 100% as if you click no or cancel it will error out on you but if someone else is looking for code like this i atleast got a good portion figured out for someone to mess with for their own.
Code:
Private Sub CommandButton1_Click() Dim oSection As Section Dim r As Range Dim TempDoc As Document Dim FirstPara As String 'Print Document Shapes(1).Visible = msoFalse ActiveDocument.PrintOut Background:=False Shapes(1).Visible = msoTrue 'Change Readonly Doc to a Temp Document For Each oSection In ActiveDocument.Sections Set r = oSection.Range r.End = r.End - 1 Set TempDoc = Documents.Add With TempDoc 'Change Temp Documents Page Layout to match Original With Selection.PageSetup .LineNumbering.Active = False .Orientation = wdOrientPortrait .TopMargin = InchesToPoints(0.5) .BottomMargin = InchesToPoints(0.5) .LeftMargin = InchesToPoints(0.5) .RightMargin = InchesToPoints(0.5) .Gutter = InchesToPoints(0) .HeaderDistance = InchesToPoints(0.5) .FooterDistance = InchesToPoints(0.5) .PageWidth = InchesToPoints(8.5) .PageHeight = InchesToPoints(11) .FirstPageTray = wdPrinterDefaultBin .OtherPagesTray = wdPrinterDefaultBin .SectionStart = wdSectionNewPage .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .VerticalAlignment = wdAlignVerticalTop .SuppressEndnotes = False .MirrorMargins = False .TwoPagesOnOne = False .BookFoldPrinting = False .BookFoldRevPrinting = False .BookFoldPrintingSheets = 1 .GutterPos = wdGutterPosLeft End With 'Ask then create folder if not created Dim rspCreate If Dir("E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\", vbDirectory) = "" Then rspCreate = MsgBox("Directory doesn't exist, do you wish to create it?", vbYesNo) If rspCreate = vbYes Then MkDir "E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\" End If End If 'Set it so that the first paragraph is the name of document ActiveDocument.Paragraphs(1).Range.FormattedText = r FirstPara = r.Paragraphs(1).Range.FormattedText FirstPara = Left(FirstPara, Len(FirstPara) - 1) 'save document ChangeFileOpenDirectory "E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\" .SaveAs FileName:=FirstPara & ".docx" 'Print and email documents Dim noSession As Object, noDatabase As Object, noDocument As Object Dim obAttachment As Object, EmbedObject As Object Dim stSubject As Variant, stAttachment As String Dim vaRecipient As Variant 'Email address where file is sent to. vaRecipient = email@myemaildomain.com 'Get the message from the user. stAttachment = ActiveDocument.FullName 'Instantiate the Lotus Notes COM's Objects. Set noSession = CreateObject("Notes.NotesSession") Set noDatabase = noSession.GETDATABASE("", "") 'If Lotus Notes is not open then open the mail-part of it. If noDatabase.IsOpen = False Then noDatabase.OPENMAIL 'Create the e-mail and the attachment. Set noDocument = noDatabase.CreateDocument Set obAttachment = noDocument.CreateRichTextItem("stAttachment") Set EmbedObject = obAttachment.EmbedObject(1454, "", stAttachment) 'Add values to the created e-mail main properties. With noDocument .Form = "Memo" .SendTo = vaRecipient .Subject = ActiveDocument.Name .Body = "Attached in this email is the EMS forum" .SaveMessageOnSend = True End With 'Send the e-mail instantly. With noDocument .PostedDate = Now() .Send 0, vaRecipient End With 'End message to users saying process was sucessful MsgBox "Document was emailed and printed sucessfully" 'Release objects from the memory. Set EmbedObject = Nothing Set obAttachment = Nothing Set noDocument = Nothing Set noDatabase = Nothing Set noSession = Nothing .Close End With Set r = Nothing Set TempDoc = Nothing Next End Sub |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Command Button doesnt work on network | rmw85 | Word VBA | 1 | 04-25-2012 01:02 PM |
VBA Print Command Prints Document Twice | HorizonSC | Word | 2 | 11-15-2011 03:26 AM |
Check Boxes and Command Buttons | Micky P | Word VBA | 0 | 10-27-2011 01:06 AM |
Command Button | cksm4 | Word VBA | 7 | 02-27-2011 08:47 PM |
Making a button to open an Access Dbase | aubreylc | Outlook | 2 | 04-07-2010 12:53 PM |