I am looking for a way to add the first paragraph (user's name) as the Filename.pdf.
I have code to save every new page as a .pdf file.
Now I need every .pdf file to be unique with the user's name written in the first paragraph of the page.
Sub SaveAsSeparatePDFs()
'Updated by Extendoffice 20180906
Dim I As Long
Dim xStr As String
Dim xPathStr As Variant
Dim xDictoryStr As String
Dim xFileDlg As FileDialog
Dim xStartPage, xEndPage As Long
Dim xStartPageStr, xEndPageStr As String
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show <> -1 Then
MsgBox "Please chose a valid directory", vbInformation, "Kutools for Word"
Exit Sub
End If
xPathStr = xFileDlg.SelectedItems(1)
xStartPageStr = InputBox("Begin saving PDFs starting with page __? " & vbNewLine & "(ex: 1)", "Kutools for Word")
xEndPageStr = InputBox("Save PDFs until page __?" & vbNewLine & "(ex: 7)", "Kutools for Word")
If Not (IsNumeric(xStartPageStr) And IsNumeric(xEndPageStr)) Then
MsgBox "The enterng start page and end page should be number format", vbInformation, "Kutools for Word"
Exit Sub
End If
xStartPage = CInt(xStartPageStr)
xEndPage = CInt(xEndPageStr)
If xStartPage > xEndPage Then
MsgBox "The start page number can't be larger than end page", vbInformation, "Kutools for Word"
Exit Sub
End If
If xEndPage > ActiveDocument.BuiltInDocumentProperties(wdPropertyPages) Then
xEndPage = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
End If
For I = xStartPage To xEndPage
ActiveDocument.ExportAsFixedFormat xPathStr & "\Page_" & Selection.Paragraphs(1).Range.Select & I & ".pdf", _
wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportFromTo, I, I, wdExportDocumentWithMarkup, _
False, False, wdExportCreateHeadingBookmarks, True, False, False
Next
End Sub
The section of Selection.Paragraphs(1).Range.Select needs to be the first paragraph of every page I am saving to pdf.
If I understood your question correctly you have the username as the first paragraph of each page.
That being the case I would go with something like this:
Dim rg As Range, username As String
For i = xStartPage To xEndPage
Set rg = Activedocument.GoTo(wdGoToPage, wdGoToAbsolute, i)
Set rg = rg.Paragraphs(1).Range
rg.Select #<= select for testing only
username = Replace(rg.Text, vbCr, vbNullString) #<= replacing the paragraph sign at the end with nothing
ActiveDocument.ExportAsFixedFormat xPathStr & "\Page_" & username & i & ".pdf", _
wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportFromTo, i, i, wdExportDocumentWithMarkup, _
False, False, wdExportCreateHeadingBookmarks, True, False, False
Next
See Split Merged Output to Separate Documents or, better still, Send Mailmerge Output to Individual Files in the Mailmerge Tips and Tricks thread at:
https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
PS: Although StackOverflow policy is against simply posting links to other sites as answers, I don't propose to re-write code that has been readily available elsewhere for years every time someone tries to reinvent the wheel.
Related
My code is suppose to check cell j2 for an email address and if found, convert that specific tab to pdf and save it in a file path that the user chooses. It works fine on the original workbook I made the macro in. When I copy the code and try running it, it prints to pdf different sheets that don't even have anything in j2 with the incorrect tab name. I keep getting an Run time error 5 Invalid procedure call or argument when i run the code on the print pdf line.
Sub SaveSheetsAsPDF()
Dim DestFolder As String
Dim PDFFile As String
Dim wb As Worksheet
Dim AlwaysOverwritePDF As Boolean
'Speed up macro
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Prompt for file destination
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
DestFolder = .SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
End With
'Create new PDF file name including path and file extension
For Each wb In ThisWorkbook.Worksheets
'Test j2 for a mail address
If wb.Range("J2").Value Like "?*#?*.?*" Then
PDFFile = DestFolder & Application.PathSeparator & wb.Name & "-" & Format(Date, "mmyy") & ".pdf"
'If the PDF already exists
If Len(Dir(PDFFile)) > 0 Then
If AlwaysOverwritePDF = False Then
OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
'If you want to overwrite the file then delete the current one
If OverwritePDF = vbYes Then
Kill PDFFile
Else
MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
Else
On Error Resume Next
Kill PDFFile
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
End If
'Prints PDF
wb.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next wb
MsgBox "All Files Have Been Converted!"
ResetSettings:
'Resets optimization settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Edit: Also not all worksheets on the workbook will need to converted. So only the sheets that need to be converted will have the email address in J2.
I've got a bit of a tricky one here. Attempting to simplify an existing process.
Existing Process:
Word Document ("Plan Doc Template") is entirely composed of INCLUDETEXT fields that pull Bookmarked sections from another Word Document ("Source Plan Doc" we'll call it) that includes merge-fields in its bookmarked sections which are from an Excel Workbook ("Mail Merge Workbook").
The current process involves the user copying a Plan Doc Template and a Mail Merge Workbook and pasting it into any folder they choose. The user then fills out the Mail Merge Workbook, saves and closes, and runs a Mail Merge through the Plan Doc Template Word Doc. This pulls in bookmarked sections from the Source Plan Doc depending on the Mail Merge Workbook fields selected. The user then removes all INCLUDETEXT fields with CTRL + SHIFT + F9 to turn fields of Plan Doc Template into workable text.
(Hopeful) Future Process:
The user copies a Mail Merge Workbook and pastes it into their
desired folder. Fills out the Mail Merge Workbook. (Manual Step)
Runs VBA Code.
VBA copies the Plan Doc Template and pastes in the Mail Merge Workbook's folder that just ran the VBA code.
VBA renames the Plan Doc Template Word Doc based on fields within the Mail Merge Workbook.
VBA runs a Mail Merge within the Plan Doc Template
VBA highlights entire document and CTRL + SHIFT + F9 to turn Field Codes into workable text.
Is it possible to do all this from an Excel VBA code or would I need a separate code after the Plan Doc has been created to run the mail merge and do the CTRL + SHIFT + F9 steps?
P.S. I use Excel Worksheets via DDE Selection to get the correct formatting from Mail Merge Workbook to Document. Hoping that can be included in the VBA code, as well.
Help would be greatly appreciated on this one, thanks,
Rich
It looks like you can have the whole thing run with one macro from Excel, without the user having to run a second one, using a For loop until wdApp.Documents.Count increases by 1. I did test the following, but with only a very small data set, so it ran very quickly.
Since the user might have more than just the main merge document open, it's important the code can identify and work with the resulting document. Usually, it will have become the ActiveDocument but relying on that is never certain. So I built in a couple of loops to 1) hold the currently open documents in an array then 2) compare those to the currently active document. If the currently active document is not in the array, then the fields are unlinked (that's the equivalent of Ctrl+Shift+F9).
Of course, if you really wanted to identify the new document from all the documents you'd need to loop each document and loop the array, making the comparison. But I've given you the starting point...
Sub MergeWithWord()
Dim wdApp As Object
Dim wdDoc As Object
Dim nrDocs As Long
Dim i As Long, d As Long
Dim aDocs() As Variant
Set wdApp = GetObject(, "Word.Application")
nrDocs = wdApp.documents.Count
'Get all opened documents so can compare whether a new one
ReDim Preserve aDocs(nrDocs - 1)
Set wdDoc = wdApp.activedocument
For i = 0 To nrDocs - 1
Set aDocs(i) = wdApp.documents(i + 1)
Next
If wdDoc.MailMerge.MainDocumentType <> -1 Then
wdDoc.MailMerge.Destination = 0
wdDoc.MailMerge.Execute False
Do Until wdApp.documents.Count > nrDocs Or i > 1000
i = i + 1
Loop
Set wdDoc = wdApp.activedocument
For d = 0 To UBound(aDocs)
If wdDoc Is aDocs(d) Then
Debug.Print "Not a new doc"
Else
Debug.Print wdDoc.FullName
wdDoc.Fields.Unlink
Exit For
End If
Next
End If
Debug.Print nrDocs, i
MsgBox "Done"
End Sub
May not be the most elegant code but here was what I wound up using to solve my question in case it helps anyone else.
Sub ButtonMerge()
Dim str1 As String
Dim PlanDocTemplate As String
Dim EDrive As String
Dim answer1 As Integer
Dim answer2 As Integer
answer1 = MsgBox("Is this IC Plan Workbook saved in the appropriate Client folder?", vbYesNo + vbQuestion)
If answer1 = vbNo Then
MsgBox ("Please save this IC Plan Workbook in the appropriate Client folder then run again.")
Exit Sub
Else
'do nothing
End If
str1 = "Q:\IC\New Structure\IC Toolkit\Templates\01 Plan Doc Template\16 Source\IC Plan Doc Template v1.0.docx"
PlanDocTemplate = Application.ActiveWorkbook.Path & "\" & Range("A1").Value & ".docx"
EDrive = "E:\" & Range("A1").Value & ".docx"
If Len(Dir(Application.ActiveWorkbook.Path & "\" & Range("A1").Value & ".docx")) = 0 Then
Call FileCopy(str1, PlanDocTemplate)
Else
MsgBox ("The Plan document already exists, please delete or rename the existing Plan Doc in folder " _
& Application.ActiveWorkbook.Path & "\ before creating a new one.")
Exit Sub
End If
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
Worksheets("Data").Activate
'Opens New Plan Doc Template
Set appWD = CreateObject("Word.Application")
appWD.Visible = True
appWD.Documents.Open Filename:=PlanDocTemplate
ActiveDocument.MailMerge.OpenDataSource Name:=strWorkbookName, _
Format:=wdMergeInfoFromExcelDDE, _
ConfirmConversions:=True, _
ReadOnly:=False, _
LinkToSource:=True, _
AddToRecentFiles:=False, _
PasswordDocument:="", _
PasswordTemplate:="", _
Revert:=False, _
Connection:="Entire Spreadsheet", _
SQLStatement:="SELECT * FROM `Data$`", _
SQLStatement1:="", _
SubType:=wdMergeSubTypeOther
appWD.Visible = True
appWD.Selection.WholeStory
appWD.Selection.Fields.Update
appWD.Selection.Fields.Unlink
ActiveDocument.MailMerge.MainDocumentType = wdNotAMergeDocument
appWD.ActiveDocument.Save
Worksheets("Form").Activate
MsgBox "Successfully Created " & Range("A1").Value & " in Location: " & Application.ActiveWorkbook.Path & "\"
answer2 = MsgBox("Do you want to save a draft in the E:\ drive as well?", vbYesNo + vbQuestion, "E: Drive Copy")
If answer2 = vbYes Then
If Dir("E:\") <> "" Then
ActiveDocument.SaveAs2 Filename:= _
"E:\" & Range("A1").Value & ".docx", _
FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
MsgBox ("Successfully Created " & Range("A1").Value & " in E:\ Location.")
Exit Sub
Else
MsgBox ("Please open the E:\ drive and enter your username/password." & _
vbCrLf & vbCrLf & "Click Ok when E:\ drive is opened.")
If Len(Dir("E:\")) = 0 Then
MsgBox ("Error connecting to E:\ drive." & vbCrLf & vbCrLf & "Please ensure you're connected and try again.")
Exit Sub
Else
ActiveDocument.SaveAs2 Filename:= _
"E:\" & Range("A1").Value & ".docx", _
FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
MsgBox ("Successfully Created " & Range("A1").Value & " in E:\ Location.")
Exit Sub
End If
End If
Else
Exit Sub
End If
End Sub
sorry for the inconvenience. I've tried to google (I always said "google is my friend"), but everything I try only give me an error in VBA.
I would like to add a function, which replace invalid characters (!"#¤%&/()=?`^*>;:#£${[]}|~\,.'¨´+-) in filename with "_".
This is my current (and working) macro:
Sub Save_to_PDF()
Dim v As Variant
Dim name, datedd As String
ThisWorkbook.Sheets(Array("sheet1")).Select
datedd = Date
strFilename = Worksheets("sheet1").Range("B2")
v = Application.GetSaveAsFilename(strFilename & " document " & datedd & " .pdf", "PDF Files (*.pdf), *.pdf")
On Error GoTo openfile
If FileExists(v) Then
Kill v
End If
If VarType(v) = vbString Then
ThisWorkbook.Sheets("sheet1").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=v, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, From:=1, To:=1, OpenAfterPublish:=True
End If
Exit Sub
openfile:
MsgBox "You have one file open allready whith that name. Please try again", vbInformation, "Please close file"
Exit Sub
End sub
The following Function will replace pre-selected characters with an alternative:
Function clean_filename(fname As String, replace_with As String)
Dim inv_chars As String
Dim cpos As Long
invchars = "!""#¤%&/()=?`^*>;:#£${[]}|~\,.'¨´+-"
For cpos = 1 To Len(invchars)
fname = Replace(fname, Mid(invchars, cpos, 1), replace_with)
Next
clean_filename = fname
End Function
You could use this by adding v = clean_filename(v,"_") once you've captured v (as a string).
However, you've included . and / in your invalid character list, and both are important to filenames so you may want to consider removing them and/or dealing with those in a different way.
I would greatly appreciate it if you could help me with this, I am creating a dynamic excel sheet and I managed so far to create excel charts using Excel vba.
However, I am struggling with exporting all of the charts and one additional sheet to one pdf. I have around 15 excel charts and one excel sheet that I need to put in one pdf. And I need the excel sheet to be the first page in the pdf. Then email this pdf (all using vba).
Could you please help me on this! Your help is much appreciated. Thank you in advance!
Well you could Publish the workbook to PDF, just make sure your fist page is the first sheet
Option Explicit
Sub PDF_And_Mail()
Dim FileName As String
'// Call the function with the correct arguments
FileName = Create_PDF(Source:=ActiveWorkbook, _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=False)
If FileName <> "" Then
Mail_PDF FileNamePDF:=FileName
End If
End Sub
'// Create PDF
Function Create_PDF(Source As Object, OverwriteIfFileExist As Boolean, _
OpenPDFAfterPublish As Boolean) As String
Dim FileFormatstr As String
Dim Fname As Variant
'// Test If the Microsoft Add-in is installed
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
'// Open the GetSaveAsFilename dialog to enter a file name for the pdf
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
Title:="Create PDF")
'// If you cancel this dialog Exit the function
If Fname = False Then
Exit Function
End If
'If OverwriteIfFileExist = False we test if the PDF
'already exist in the folder and Exit the function if that is True
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
'Now the file name is correct we Publish to PDF
Source.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
'If Publish is Ok the function will return the file name
If Dir(Fname) <> "" Then
Create_PDF = Fname
End If
End If
End Function
'// Email Created PDF
Function Mail_PDF(FileNamePDF As String)
Dim GMsg As Object
Dim gConf As Object
Dim GmBody As String
Dim Flds As Variant
Set GMsg = CreateObject("CDO.Message")
Set gConf = CreateObject("CDO.Configuration")
gConf.Load -1 ' CDO Source Defaults
Set Flds = gConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "GmailAddress#gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
GmBody = "Hi there" & vbNewLine & vbNewLine
With GMsg
Set .Configuration = gConf
.To = "recip#email.com"
.CC = ""
.BCC = ""
.From = "Reply#something.com"
.Subject = "Important message"
.TextBody = GmBody
.AddAttachment FileNamePDF
.Send
End With
End Function
Most codes from Ron de Bruin
I am new to Macro
By googling I coded this and I have changed some part for my use.
Problem is Runtime error is coming. And I don't know how to print all word documents in folder both .doc and .docx
My Requirement
Want to print all word document in folder A (both .doc and .docx).
Print active document ( Number of copies want to be get from User ).
Close active document.
Repeat 2 and 3 for all document in folder A
My code will get page number to print from case selected by the user
case 1 will print 1st two pages one by one.
case 2 will print 3rd to reset of the pages.
case 3 will print full document.
In my office duplex is default printer setup to print. But I will be using letter head. I need this macro to solve my issue. I tried simplex macro code to print but its not working.
Sub prnt()
Dim c As Integer
Dim i As Integer
Dim strName As String
'get print type
strName = InputBox(Prompt:="Choose Your Option" & vbNewLine & "" & vbNewLine & "1. Letter Head" & vbNewLine & "2. A4 Sheet" & vbNewLine & "3. Comp Plan" & vbNewLine & "", _
Title:="ENTER YOUR PRINT TYPE", Default:="Your Choice here")
If strName = "Your Choice here" Or strName = vbNullString Then
MsgBox "Sorry...! Choose Correct option"
Exit Sub
Else
'case to choose option
Select Case strName
Case "1"
Dim file
Dim path As String
Dim ans As String
'get number of copies from user
c = InputBox("Please enter number of copies")
ans = MsgBox("Are you sure you want to print " & _
c & "?", _
vbQuestion + vbYesNo, "Print pages")
If ans = vbNo Then
Exit Sub
Else
'path to the folder
path = "E:\print\"
file = Dir(path & "*.docx")
Do While file ""
Documents.Open Filename:=path & file
For i = 1 To 2 'loop 2 pages
ActiveDocument.PrintOut , Copies:=c, Range:=wdPrintRangeOfPages, Pages:=i
Next
ActiveDocument.Close
' set file to next in Dir
file = Dir()
Loop
End If
Case "2"
Case "3"
Case Else
MsgBox "Sorry...! Choose Correct option"
End Select
End If
End Sub
There's bad programming practice to work on strings instead of numbers.
See this:
Sub Test()
Dim noofcopies As Integer
noofcopies = GetNumberOfCopies()
MsgBox noofcopies
End Sub
Function GetNumberOfCopies() As Integer
Dim iRetVal As Integer
On Error GoTo Err_GetNumberOfCopies
iRetVal = CInt(InputBox("Enter no. of copies to print" & vbCr & vbCr & _
"Enter proper integer value between 1 and 3" & vbCr & _
"0 (zero) equals to Cancel", "No. of copies", "1"))
If iRetVal > 3 Then iRetVal = 3
Exit_GetNumberOfCopies:
GetNumberOfCopies = iRetVal
Exit Function
Err_GetNumberOfCopies:
Err.Clear
Resume 0
End Function
Use the same logic to get print option ;)