Exporting to PDF Macro Missing Shapes - excel

I have a macro that, upon clicking a button, will generate a barcode image (the image is composed of nothing but shapes), and after that, will export 3 sheets to a pdf. The problem I'm having is that doing this will generate the barcode image, but when exporting as a PDF the shapes that were used to generate to barcode don't show up. They will show up if I print or print to pdf without using the export to pdf macro, but that defeats the point of the macro.
An even bigger headache is that this code is on a different version (spreadsheet is a template) of the spreadsheet, but the macro process is working just fine on that spreadsheet. I copy/pasted the working code to the spreadsheet that's giving me trouble and the trouble maker is still not working. Below is the related code. Why are the shapes not being included on the exported PDF?
Sub BevelPrint_Click()
' DisplayBarcode generates a code128 scannable barcode. Max of 14 characters for the selected line width and max width
Call DisplayBarcode
Sheets(Array("(Cal Cert) Page 1 of 3", "(Cal Cert) Page 2 of 3", "(Cal Cert) Page 3 of 3")).Select
' If Application.Dialogs(xlDialogPrinterSetup).Show = True Then
Dim varResult As Variant
Dim ActBook As Workbook
Dim defaultPath As String
Dim WorkbookName As String
'Dim fso As New Scripting.FileSystemObject
' WorkbookName = fso.GetBaseName(ThisWorkbook.Name)
WorkbookName = ThisWorkbook.Sheets("(0) Calibration System QC").Range("B2").Value
WorkbookName = WorkbookName & " Cert"
defaultPath = "\\TSISVFP01\MANUFACTURING\W405 - Particle\"
defaultPath = defaultPath & WorkbookName
'displays the save file dialog
varResult = Application.GetSaveAsFilename(FileFilter:= _
"PDF File (*.pdf), *.pdf, Excel Files (*.xlsx), *.xlsx", Title:="Save Cert as PDF", _
InitialFileName:=defaultPath)
If varResult <> False Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
varResult, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
End If
' End If
Sheets("(0) Calibration System QC").Select
End Sub
Sub DisplayBarcode()
Dim s As Shape
ThisWorkbook.Worksheets("(Cal Cert) Page 1 of 3").Activate
For Each s In ThisWorkbook.Worksheets("(Cal Cert) Page 1 of 3").Shapes
If s.Name Like "*Straight*" Then
ThisWorkbook.Worksheets("(Cal Cert) Page 1 of 3").Shapes(s.Name).Select
Selection.Delete
End If
Next s
Code128Generate_v2 184, 72, 9, 1.5, Worksheets("(Cal Cert) Page 1 of 3"), ThisWorkbook.Sheets("(0) Calibration System QC").Range("B2"), 40
Dim t As Shape
For Each t In ThisWorkbook.Worksheets("(Cal Cert) Page 1 of 3").Shapes
t.ControlFormat.PrintObject = True
Next t
End Sub

Related

How to Add upload attachment button in VBA excel

I've developed a small ticketing system on excel VBA
The Save button will take all data from textboxes and radio button and add it to the row number 7 (in this case)
But when I press upload I can't add the link to the label of attachments
How to add link to the attachment label using (upload file ) button
And also save the Link value stored in upload file button to use it later in clear button and save button?
I'm confused to work with private sub and private dim variables.
I'm newbie in VBA please help
User Form of the System
Save Button Code
Upload button code
Public Sub btnAttachment_Click()
'To upload file link format is png, jpeg, PDF or All files'
Dim wks As Worksheet
Dim LinksList As Range
Dim lastRowLink As Long
Dim LinkAttached As Long
Set wks = ActiveSheet
Set LinksList = Range("N1")
'declare last row to insert link to
lastRowLink = WorksheetFunction.CountA(Sheets("Tickets").Range("A:A"))
Sheets("Tickets").Cells(lastRow + 1, 11).Value = LinkAttached
ChDrive "C:\"
ChDir "C:\"
Filt = "PNG Files(*.png),*.png ," & _
"Jpeg Files(*.jpeg),*.jpg ," & _
"PDF Files (*.pdf),*.pdf ," & _
"All Files (*.*),*.*"
FilterIndex = 1
Title = "Select a File to Hyperlink"
Filename = Application.GetOpenFilename _
(FileFilter:=Filt, _
FilterIndex:=FilterIndex, _
Title:=Title)
If Filename <> False Then
wks.Hyperlinks.Add Anchor:=LinksList, _
Address:=Filename, _
TextToDisplay:=Filename
Else
MsgBox "No file was selected.", vbCritical, "Loading Error"
Exit Sub
End If
End Sub
Attachment PDF file link contains the code and photo too
Buttons Code link

Looping "Batch Export" Crashes - Processor or Code Error?

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 :)

excel document printing differently between users

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

Using Selection.ExportAsFixedFormat to generate PDF properly

I want to export to pdf all the sheets on the workbook except the first one. To do that I used Selection.ExportAsFixedFormat instead of ActiveWorkbook.ExportAsFixedFormat.
The problem using Selection.ExportAsFixedFormat, is that for each sheet, the only part of it that will appear ond the correspondent pdf page is a manual selection instead of all the printing area as it should be (if I select only one cell it will be the only one that appears on the pdf). Using ActiveWorkbook.ExportAsFixedFormat the pdf is generated as intended.
Sub PDF()
Dim SaveAsStr As String
Dim strName As String
Dim i As Long
ReDim ArraySh(2 To Sheets.Count)
For i = 2 To Sheets.Count
ArraySh(i) = Sheets(i).Name
Next
...
'ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, fileName:=SaveAsStr & ".pdf", OpenAfterPublish:=True, IgnorePrintAreas:=False
Sheets(ArraySh).Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, fileName:=SaveAsStr & ".pdf", OpenAfterPublish:=True, IgnorePrintAreas:=False
End Sub
How can I use the Selection method, to generate the PDF properly?

Only allow saving to PDF in Excel 2007/2010

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

Resources