I have inherited an excel program built in vba that generates a document in a worksheet to be printed into pdf.
My problem is that with the exact same inputs I can get two different documents. The main differences is the line spacing between cells. For one user there might be 2 words that appear on the last line of the cell leaving no space between the cells while for another user might have all their words appear on the previous line and now has a line space between the two cells.
I have tried manually adding line break at the end of the cells to try to make sure that all cells have some spacing between the two but this has now caused a few users to get double line spacing between their cells.
I'm a little lost as to what might be causing this. All my users are running the same version of excel and since this is still in the testing phase are using the exact same inputs. Also we are all part of the same organization and I believe our environments are almost identical ( did not set up so no guarantee )
How do I go about to make sure that when my vba sends the worksheet the be printed as a pdf that it comes out identical for all my users.
Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
Dim FileFormatstr As String
Dim Fname As Variant
'Test to see if the Microsoft Create/Send add-in is installed.
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
If FixedFilePathName = "" Then
'Open the GetSaveAsFilename dialog to enter a file name for the PDF file.
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
Else
Fname = FixedFilePathName
End If
'If OverwriteIfFileExist = False then test to see if the PDF
'already exists in the folder and exit the function if it does.
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
'Now export the PDF file.
On Error Resume Next
Myvar.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0
'If the export is successful, return the file name.
If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
End If
End Function
Related
There are a number of issues with this error, but none seem to match my case exactly so posting in the hope of some help.
I have a macro which takes all the files in a directory, opens them silently in a new (hidden) instance of Excel and does two "Save As" operations: one to a location on SharePoint and one to an archive folder. The purpose of this is that the files are produced by SAS in XML format with an XLS extension. Saving them as native XLSX reduces file size dramatically.
Each day we produce a number of files which we then run the macro on. It has been erroring on the same file each day; that is to say it's not exactly the same file, but the same report with different versions each day. It is the largest of the files, but other than that there's nothing outstanding about it.
There are two other oddities:
When running the code step-by-step with F8, the error doesn't occur - this has meant I've been unable to pinpoint exactly where it's erroring;
The code has an option to skip files that error - when skipping and rerunning it again immediately afterwards, with no other changes, the error doesn't occur the second time.
Here's the code; the macro is called different times with different locations as parameters:
Sub LoopThroughDirectory(inPath As String, sharepointPath As String, archivePath As String)
Dim sDir As String
Dim app As New Excel.Application
Dim wb As Excel.Workbook
Dim mbErr As Integer, mbFinished As Integer
If Right(inPath, 1) <> "\" Then inPath = inPath & "\"
On Error GoTo ErrHandler:
sDir = Dir$(inPath, vbNormal)
Do Until Len(sDir) = 0
On Error GoTo LoopError:
app.Visible = False
app.DisplayAlerts = False
Set wb = app.Workbooks.Add(inPath & sDir)
With wb
.SaveAs Filename:=sharepointPath & Left(.Name, InStrRev(.Name, ".")) & "xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, ReadOnlyRecommended:=True
.SaveAs Filename:=archivePath & Left(.Name, InStrRev(.Name, ".")) & "xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close SaveChanges:=False
End With
Set wb = Nothing
app.DisplayAlerts = True
app.Quit
Kill (inPath & sDir) ' delete the file
NextFile:
sDir = Dir$ ' find the next filename
Loop
mbFinished = MsgBox( _
"The process has finished. You may need to review any files that have errored.", _
vbOKOnly, _
"Process finished" _
)
On Error GoTo 0
Exit Sub
ErrHandler:
mbErr = MsgBox( _
"There has been an error finding files. Check the SharePoint folder and try again.", _
vbCritical + vbOKOnly, _
"Error finding files" _
)
On Error GoTo 0
Exit Sub
LoopError:
Select Case MsgBox("There has been an error with " & sDir & "." & vbCrLf & vbCrLf & _
"The error is " & vbCrLf & vbCrLf & _
Err.Description & "." & vbCrLf & vbCrLf & _
"Press OK to continue with the next file or Cancel to stop the process.", _
vbCritical + vbOKCancel, "Error")
Case vbOK
Resume NextFile ' go back and try the next file
Case vbCancel
On Error GoTo 0
Exit Sub ' stop processing the files
End Select
End Sub
I suggest to insert the sub below underneath your existing code, outside your procedure but in the same code module.
Private Sub WaitASecond(ByVal Sec As Single)
Dim WaitTill As Single
WaitTill = Timer + Sec
Do
DoEvents
Loop While Timer < WaitTill
End Sub
Call it from your main procedure with a line of code like this.
WaitASecond(0.5) ' which would wait for half a second
Experiment with both the length of time, in increments of 0.25 seconds, if you like, and the location of the code. Bear in mind that it seems that your biggest file creates the problem. So, you might limit the call to that one file or vary the length of the wait depending upon the file size (if it makes a significant difference to your process).
You might instroduce a wait after each SaveAs, only after both SaveAs and/or after the Kill.
Why can't Excel loop through large datasets?!
I have 2 different document forms which need to be exported to PDF by the hundreds. I pulled the batch export script from the internet and modified it for my usage so it would process either of these forms depending on the checkbox selected on the "Batch PDF Printer" worksheet.
Everything runs well - for the first 10-15 workbooks accessed by the loop, and then it crashes. Every Excel document freezes (Not Responding) and the page that is currently accessed by the Macro partially opens with no visible data or cells. The "Publishing" message box may also freeze at this point. Once it reported a lack of memory error - but I have not been able to repeat this. Shouldn't Excel be deleting unused cache's so as to not overload the memory? I would suspect a bum loop if it didn't run well for a while. I've heard there is no way to script in a "cache dump" or something of that nature. Is it bad code, or am I asking too much of my processor?
Sub Convert2PDF()
'Update the checkbox linked formulas on the GUI workbook
Sheet1.Range("A2").Formula = Sheet1.Range("A2").Formula
Sheet1.Range("B2").Formula = Sheet1.Range("B2").Formula
Sheet1.Range("C2").Formula = Sheet1.Range("C2").Formula
Dim strFolder As String
Dim strXLFile As String
Dim strPDFFile As String
Dim wbk As Workbook
Dim lngPos As Long
' set folder
strFolder = ThisWorkbook.Path & "\putfileshere" & "\"
Application.ScreenUpdating = False
' Get first filename
strXLFile = Dir(strFolder & "*.xls*")
' Loop through Excel workbooks in folder
Do While strXLFile <> ""
' Open workbook
Set wbk = Workbooks.Open(Filename:=strFolder & strXLFile)
' Assemble the PDF filename
lngPos = InStrRev(strXLFile, ".")
strPDFFile = Left(strXLFile, lngPos) & "pdf"
' Export to PDF
'Do the next 8 lines crash the Macro because they recalculate for every sheet? Page1, Page2, Page3 value are the same for all workbooks processed in a batch
Dim Page1 As String
Dim Page2 As String
Dim Page3 As String
Dim Page4 As String
Page1 = ThisWorkbook.Sheets("Batch PDF Printer").Range("A2")
Page2 = ThisWorkbook.Sheets("Batch PDF Printer").Range("B2")
Page3 = ThisWorkbook.Sheets("Batch PDF Printer").Range("C2")
If ThisWorkbook.Sheets("Batch PDF Printer").Range("C2") = "" Then
wbk.Sheets(Array(Page1, Page2)).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\pdfsgohere" & "\" & wbk.Name, _
Quality:=xlQualityStandard, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
'run process for format option 2
Else:
wbk.Sheets(Array(Page1, Page2, Page3)).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\pdfsgohere" & "\" & wbk.Name, _
Quality:=xlQualityStandard, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
'Tried killing the finished document to improve function
Dim xFullName As String
xFullName = Application.ActiveWorkbook.FullName
ActiveWorkbook.Saved = True
Application.ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill xFullName
Application.ActiveWorkbook.Close False
End If
' Close workbook - didn't seem to help (can't do it when the workbook is gone)
'wbk.Close SaveChanges:=False
' Get next filename
strXLFile = Dir
Loop
Application.ScreenUpdating = True
MsgBox "All Done"
Thanks for the help. I've been trying to figure this out for days now.
This ran for me on >30 files with no problem:
Sub Convert2PDF()
Dim strFolder As String, strXLFile As String
Dim strPDFFile As String
Dim wbk As Workbook
Dim lngPos As Long
Dim pages(1 To 4) As String
Dim shtBatch As Worksheet, arr
Set shtBatch = ThisWorkbook.Sheets("Batch PDF Printer")
shtBatch.Range("A2:C2").Calculate '<< assume this was the point of resetting the formulas?
pages(1) = shtBatch.Range("A2").Value
pages(2) = shtBatch.Range("B2").Value
pages(3) = shtBatch.Range("C2").Value
'what pages to print? Only need to do this once
arr = IIf(Len(pages(3)) = 0, Array(pages(1), pages(2)), _
Array(pages(1), pages(2), pages(3)))
strFolder = ThisWorkbook.Path & "\putfileshere\"
strXLFile = Dir(strFolder & "*.xls*")
Do While strXLFile <> ""
Set wbk = Workbooks.Open(Filename:=strFolder & strXLFile, ReadOnly:=True)
lngPos = InStrRev(strXLFile, ".")
strPDFFile = Left(strXLFile, lngPos) & "pdf"
wbk.Sheets(arr).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\pdfsgohere\" & strPDFFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
wbk.Close False
strXLFile = Dir
Loop
MsgBox "All Done"
End Sub
Even if your visible system RAM is not overloading, the internal capacity of the Excel application seems to be exceeded for a brief moment. I was able to finally view the message box "Not enough system resources to display completely" before the app went into automatic reboot. Try streamlining the workbooks being accessed by the loop. If your workbooks take a while to start up, that may be indication of heavy background processes (calculations and VBA subs). DoEvents may help the code run more smoothly by asking for more processing time so the system can sort it's demands. Ultimately,
Application.Calculation = xlManual
at the top of the loop was sufficient to reduce the computational demands on the 20 gig system (which I never expected to overload).
If you have linked images in your exports.
Exported linked images leaves behind a bit or byte in the kernel, which accumulates and eventually breaks excel.
I found this solution only 1 place on the internet and i cannot find it again, but it got me from 200s to 1000 loops of VBA Macro by removing linked images.
Nothing in the VBA code would help, i used pauses, save the workbook to clear memory, disable events etc...
I wrote an answer to my problem here: https://stackoverflow.com/a/53600884/10069870
Disregard if you have no linked images in your exports :)
When automating other MS-Office applications with excel, I frequently get ok-only prompts saying that Microsoft Excel is waiting for another application to complete an OLE action.
This only happens when automating lengthy tasks.
How can I deal with this in an appropriate fashion?
Two recent examples (I recon the code is less important):
creating an accdb-Database from Excel with an Access.Application and populating it by running rather complex SQL-queries on large amount of data.
Public Function createDB(pathDB As String, pathSQL As String) As String
Dim dbs As DAO.Database
Dim sql As String
Dim statement As Variant, file As Variant
Dim sErr As String, iErr As Integer
With New Access.Application
With .DBEngine.CreateDatabase(pathDB, dbLangGeneral)
For Each file In Split(pathSQL, ";")
sql = fetchSQL(file)
For Each statement In Split(sql, ";" & vbNewLine)
If Len(statement) < 5 Then GoTo skpStatement
Debug.Print statement
On Error Resume Next
.Execute statement, dbFailOnError
With Err
If .Number <> 0 Then
iErr = iErr + 1
sErr = sErr & vbCrLf & "Error " & .Number & " | " & Replace(.Description, vbCrLf, vbNullString)
.Clear
End If
End With
On Error GoTo 0
skpStatement:
Next statement
Next file
End With
.Quit acQuitSaveAll
End With
dTime = Now() - starttime
' Returnwert
If sErr = vbNullString Then sErr = "Keine Fehler"
createDB = "Zeit: " & Now & " | Dauer: " & Format(dTime, "hh:mm:ss") & " | Anzahl Fehler: " & iErr & vbCrLf & sErr
' Log
With ThisWorkbook
'...
.Saved = True
.Save
End With
End Function
create mail merges from Excel in a Word.Application, using existing and rather large .docm-templates and dynamic SQL-queries that returns the receipents
Set rst = GetRecordset(ThisWorkbook.Sheets("Parameter").Range("A1:S100"))
With New Word.Application
.Visible = False
While Not rst.EOF
If rst!Verarbeiten And Not IsNull(rst!Verarbeiten) Then
Debug.Print rst!Sql
.Documents.Open rst!inpath & Application.PathSeparator & rst!infile
stroutfile = fCheckPath(rst!outpath, True) & Application.PathSeparator & rst!outfile
.Run "quelle_aendern", rst!DataSource, rst!Sql
.Run MacroName:="TemplateProject.AutoExec.SeriendruckInDokument"
Application.DisplayAlerts = False
.ActiveDocument.ExportAsFixedFormat _
OutputFileName:=stroutfile _
, ExportFormat:=wdExportFormatPDF _
, OpenAfterExport:=False _
, OptimizeFor:=wdExportOptimizeForPrint _
, Range:=wdExportAllDocument _
, From:=1, To:=1 _
, Item:=wdExportDocumentContent _
, IncludeDocProps:=False _
, KeepIRM:=True _
, CreateBookmarks:=wdExportCreateNoBookmarks _
, DocStructureTags:=False _
, BitmapMissingFonts:=True _
, UseISO19005_1:=False
Application.DisplayAlerts = True
For Each doc In .Documents
With doc
.Saved = True
.Close SaveChanges:=wdDoNotSaveChanges
End With
Next doc
End If
rst.MoveNext
Wend
.Quit
End With
notes:
When run on a smaller scale (for example, when querying less records or using less complex templates), both codes do run smoothly.
In both cases, when I OK through all the reappearing prompts, the code will eventually finish with the desired results.
Therefore, I guess I'm not encountering an error (also it doesn't trigger the error handlers), but rather something like a timeout.
As suggested on other sources, I do wrap my code into Application.DisplayAlerts = False. This, however, seems like a horrible idea, since there might actually be cases where I do need to be alerted.
I'll add the code that #Tehscript linked to in the comments.
You can solve this by using the COM API to remove VBA's message filter.
This will prevent COM from telling VBA to displaying a message box when it
thinks the process you're calling has blocked. Note that if the process
really has blocked for some reason this will prevent you from receiving any
notification of that. [source]
I think this is the code I used back in 2006 for the same problem (it worked).
Private Declare Function _
CoRegisterMessageFilter Lib "OLE32.DLL" _
(ByVal lFilterIn As Long, _
ByRef lPreviousFilter) As Long
Sub KillMessageFilter()
'''Original script Rob Bovey
'''https://groups.google.com/forum/?hl=en#!msg/microsoft.public.excel.programming/ct8NRT-o7rs/jawi42S8Ci0J
'''http://www.appspro.com/
Dim lMsgFilter As Long
''' Remove the message filter before calling Reflections.
CoRegisterMessageFilter 0&, lMsgFilter
''' Call your code here....
''' Restore the message filter after calling Reflections.
CoRegisterMessageFilter lMsgFilter, lMsgFilter
End Sub
I tried the COM API code as well, which works. But it is only useful in so far as you don't see the error - the 30-sec delay every time the error is triggered still happens which makes this unworkable for me.
The better change I have made is to turn off "Real time presence in Microsoft Office" in Drive File Stream (the google product). This has (so far!) resolved the issue for me. I'm guessing there is some sort of clash between this and another excel addin.
I recently updated to office 2016 and now my macro that i am using to select a range in excel, and then convert this range to PDF and automatically send an email, does not fully work.
Before when i used this macro, the filename was automatically filled in the SaveAs dialog box, but now it is empty. I do not understand why.
Does anyone else has a problem like this or know how to fix it?
Here is my code:
Function Skicka_projektunderlag_PDF(Myvar As Object, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
Dim FileFormatstr As String
Dim Fname As Variant
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws = Sheets("Partner_information")
Set ws1 = Sheets("Kundinformation")
Set ws2 = Sheets("Kalkyl")
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
If FixedFilePathName = "" Then
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename(ws.Range("B1").Value & " - Projektunderlag " & ws2.Range("BF104").Value & " " & ws1.Range("B3").Value _
, FileFilter:=FileFormatstr, Title:="Create PDF")
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
On Error Resume Next
Myvar.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0
If Dir(Fname) <> "" Then Skicka_projektunderlag_PDF = Fname
End If
End Function
Best regards
AgatonSaxx
The following answer isn't refined but I have also been struggling with this problem in Word 2016 VBA to generate a default file name when Save As is selected in Word 2016
and wanted to share what I've found thus far as it is working with some success.
I was able to get the code semi-working again by adding an event handler.
Application.DocumentBeforeSave Event
example here https://msdn.microsoft.com/en-us/library/office/ff838299.aspx
tied to Using Events with Application Object
example here https://msdn.microsoft.com/en-us/library/office/ff821218.aspx
I moved my actual code to within the class module
Cancel=true
had to be added to the end of the code or the Save As dialog box would open twice.
This "solution" has some drawbacks that it only works once per document. So, if for some reason, you want to use SaveAs on the same document more than once, the name won't default. It also seems a bit clunky/limited for my taste but it is a start.
This "solution" is Word based but you should be able to do/ find something similar for Excel.
Hope this helps put you on the path to success. Apologies for not being a perfect answer. Just wanted to share lessons learned as maybe it will cut down on your time to a solution!
Is there any way to force excel to always print a file in PDF format? For some reason the standard code I found (on this site and others) doesn't seem to work.
Here's the code I'm using:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
cFileName, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
I've got a simple Input box to capture the file name, and I'd like to prevent them from doing anything else. Ideally, I'd like to put this code into my BeforeSave event and my BeforePrint event so that the only thing they can do is print to PDF. Is this possible?
A long time ago I used the opensource PDFPrinter in combination with Excel. Here is some of the code I wrote that seems to do what you want. Maybe you can use this as a start for your own solution?
'Print the saved file as a pdf in the same directory
KTCurrentFilePath = ActiveWorkbook.Path 'Store current FilePath
'Define Variables for PDF printjob
Dim pdfjob As Object
Dim KTPDFName As String
Dim KTPDFPath As String
Dim KTPCurrentPrinter As String
'Set Variable Values
KTPDFName = Range("MyPDFName").Value & ".pdf"
KTPDFPath = ActiveWorkbook.Path & Application.PathSeparator
KTPCurrentPrinter = Application.ActivePrinter
'Check if worksheet is empty and exit if so
If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub
'Start PDF Engine
Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
On Error GoTo 0
With pdfjob
If .cStart("/NoProcessingAtStartup") = False Then
MsgBox "Can't initialize PDFCreator.", vbCritical + _
vbOKOnly, "PrtPDFCreator"
Application.ActivePrinter = KTPCurrentPrinter
Exit Sub
End If
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = KTPDFPath
.cOption("AutosaveFilename") = KTPDFName
.cOption("AutosaveFormat") = 0 ' 0 = PDF
.cClearCache
End With
'Print the document to PDF
ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"
'Wait until the print job has entered the print queue
Do Until pdfjob.cCountOfPrintjobs = 1
DoEvents
Loop
pdfjob.cPrinterStop = False
'Wait until PDF creator is finished then release the objects
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
pdfjob.cClose
Set pdfjob = Nothing
'Reset Printer to default
Application.ActivePrinter = KTPCurrentPrinter
End Sub
Regards,
Robert Ilbrink
Are you getting an error like this or running the code?
"Automation error: The object invoked has disconnected from its clients" error message in Excel 2000
If yes then have a look at the link below
http://support.microsoft.com/kb/813120
Use the code below in worksheet
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Macro1
End Sub
Add the following code in a new module
Sub Macro1()
cfilename = "C:\Users\SONY\Desktop\Book1.pdf" 'you can use the input box method to get the desired file name and location
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
cfilename, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End Sub