Using VBA to Print Data From Excel to PDF - excel

Seemingly very simple question but I have an excel spreadsheet that uses vba code to take a screenshot of something, pastes it into a 'Screenshot' tab and then exports that tab to a pdf. My issue is that the page break that I pass does not line up with the dotted page break line that seems to be produced by default(?)...
Section of Code:
Set Screen = Sheets("Screenshots")
Set Block = Sheets("BlockChart")
Set CopyRangeBlock = Block.Range("A1:N51")
Set PasteRange = Screen.Cells(1, 1)
Application.DisplayStatusBar = True
CopyRangeBlock.CopyPicture xlScreen, xlPicture
DoEvents
Screen.Paste Destination:=PasteRange
DoEvents
Sheets("Screenshots").Rows(52).PageBreak = xlPageBreakManual
Application.CutCopyMode = False
The range of the data to screenshot is from "A1:N:51" and therefore I place a page break at row 52. However, a dotted page break line appears (seemingly by default) at row 50. This screws up my export to pdf and produces blank pages. This is particularly an issue when I loop through the code to generate multiple pages in a pdf. How can I make it so that the dotted line either doesn't appear or matches with the page break that I set so that I'm not getting extra blank pages?
Example:
Just to reiterate the point, the whole worksheet has pre-determined dotted lines for the print area. I essentially want to modify these (via manual breaks or something) so that each page printed to a pdf is a custom size that fits the data I screenshot.

By following code you can paste some example ranges as screenshots to the destination worksheet, each with a manual page break between them.
I left 1 row blank before and after each screenshot (reason: when a border of a shape is directly placed at a page break, the border might be printed on the adjacent page too).
Please adapt the zoom level in the last code line, to get even the largest screenshot printed on 1 page (e. g. 54 %). If you want to get it calculated automatically, see the second code part of this answer.
Private Sub CollectScreenshots()
Dim wsSource As Worksheet, wsDestination As Worksheet
Dim rngExampleRanges As Range
Dim rngCopy As Range
Dim rowPaste As Long
Dim shpScreenshot As Shape
Dim dlg As Dialog
Application.DisplayStatusBar = True
Set wsSource = Sheets("BlockChart")
Set rngExampleRanges = wsSource.Range("A1:N51, A52:B53, C60:E99")
Set wsDestination = Sheets("Screenshots")
' Copy all ranges as screenshot into destination worksheet:
rowPaste = 1
With wsDestination
.ResetAllPageBreaks
For Each rngCopy In rngExampleRanges.Areas
rngCopy.CopyPicture Appearance:=xlScreen, Format:=xlPicture
DoEvents
If rowPaste > 1 Then .HPageBreaks.Add Before:=.Rows(rowPaste)
.Paste Destination:=.Cells(rowPaste + 1, 1), Link:=False
DoEvents
Set shpScreenshot = .Shapes(.Shapes.Count)
rowPaste = shpScreenshot.BottomRightCell.Row + 1
Next rngCopy
End With
Application.CutCopyMode = False
' set appropriate zoom level
wsDestination.PageSetup.Zoom = 54
End Sub
Automatic Zoom Level
If you want Excel to calculate the optimum zoom level, it is a bit more complicated.
If you have a cell range, e. g. A1:N51, which has to be printed on 1 page, then you can set the page dialog parameters manually like this:
define the print area as A1:N51
set scaling to 1 page width and 1 page height
Then you can visually see the calculated zoom level within the page setup dialog.
Unfortunately you can not read this zoom level directly via VBA, as Worksheet.PageSetup.Zoom in this case returns False only. If you urge Excel to use the zoom level, e. g. by setting FitToPagesWide to False, Excel calculates a new zoom level.
To read the calculated zoom level, you have to send a keyboard shortcut to the page setup dialog. To get the correct keyboard shortcut for that, please check within your page setup dialog, which shortcut is used for zoom level. In my German Excel version, it's Alt + V.
Then exchange the last line from above code by following:
' get cell dimensions of the largest screenshot:
Dim maxVerticalCells, maxHorizontalCells
For Each shpScreenshot In wsDestination.Shapes
maxVerticalCells = Application.WorksheetFunction.Max( _
maxVerticalCells, _
shpScreenshot.BottomRightCell.Row - shpScreenshot.TopLeftCell.Row + 1)
maxHorizontalCells = Application.WorksheetFunction.Max( _
maxHorizontalCells, _
shpScreenshot.BottomRightCell.Column - shpScreenshot.TopLeftCell.Column + 1)
Next shpScreenshot
' set appropriate zoom level
With wsDestination
' Simulate a print area with required dimensions to get it printed to 1 page
.PageSetup.Zoom = False
.PageSetup.FitToPagesWide = 1
.PageSetup.FitToPagesTall = 1
.PageSetup.PrintArea = _
.Range(.Cells(1, 1), .Cells(maxVerticalCells, maxHorizontalCells)).Address
' change the page setup to automatic and keep previous zoom level
' by sending keys to page setup dialog
.Activate
Dim strKeys As String
strKeys = "P" ' key "P" for first tab in that dialog
strKeys = strKeys & "%V" ' key <Alt>+<V> for automatic zoom (German, might be %A in other countries)
strKeys = strKeys & "~" ' key <Enter>
SendKeys strKeys ' send keys to following dialog
Application.Dialogs(xlDialogPageSetup).Show
Dim myZoomlevel As Double
myZoomlevel = .PageSetup.Zoom
' Reset print area, reset automatic page adaption, use previous zoom level
.PageSetup.PrintArea = ""
.PageSetup.FitToPagesWide = False
.PageSetup.FitToPagesTall = False
.PageSetup.Zoom = myZoomlevel
End With

Related

Excel to word VBA for mail merge

I have a mail merge I'm attempting to do but I can't find any information on how to update existing merge fields from VBA code. I have 10 labels on each page but each label needs to be processed as a block before moving to the next record as they have to pull from multiple columns to fill out the label. So I need to be able to replace Merge field values with what I have stored in the array. creating a new page of labels every 10 like a normal mail merge would.
I have thought about several approaches but nothing seems to be panning out for me.
I started by trying just a normal mail merge but I was only able to get the left side of the page to populate properly populating the right side causes the data to jump to the next record at the wrong time and there doesn't seem to be a way to go back a record. I couldn't find a way to process the label as a range or block.
After that I tried to reference the field codes directly. with this code but it returns an error that it's read only.
Sub OpenExcelFile()
Dim oExcel As Excel.Application
Dim oWB As Workbook
Dim RowLoc As Integer
Dim ExcelArray(1 To 10000, 1 To 6) As Variant
RowLoc = 1
Set oExcel = New Excel.Application
Set oWB = oExcel.Workbooks.Open("C:\Users\ScottCannon\Documents\Sticker Maker.xlsm")
oExcel.Visible = True
Do While oWB.Sheets("Barcode").Cells(RowLoc, 1) <> ""
ExcelArray(RowLoc, 1) = oWB.Sheets("Barcode").Cells(RowLoc, 1)
ExcelArray(RowLoc, 2) = oWB.Sheets("Barcode").Cells(RowLoc, 2)
ExcelArray(RowLoc, 3) = oWB.Sheets("Barcode").Cells(RowLoc, 3)
ExcelArray(RowLoc, 4) = oWB.Sheets("Barcode").Cells(RowLoc, 4)
ExcelArray(RowLoc, 5) = oWB.Sheets("Barcode").Cells(RowLoc, 5)
ExcelArray(RowLoc, 6) = oWB.Sheets("Barcode").Cells(RowLoc, 6)
RowLoc = RowLoc + 1
Loop
RowLoc = 1
ActiveDocument.MailMerge.DataSource.DataFields("Job_Name").Value = ExcelArray(RowLoc, 1) 'this part specifically doesn't work.
oWB.Close
Excel.Application.Quit
End Sub
I tried to see if there was a way to create references I can replace, but it seems like if I managed to do that it would only work for a single page. This seems so stupid it should let you group cells together as a single object or something.
I just solved my own problem. creating the labels as normal (with each label being it's own cell of a table.) I can insert a table into each cell and that will allow each label to have completely customizable formatting while still treating each label individually. So I can insert the barcode I need and the company logo without worry that text from other areas is going to screw up the formatting.

Excel VBA Page-Setup - Page fit to width looses it's value after adding HPage-Breaks

I am trying to set-up an Excel sheet with about 3000 rows, to print nicely to a PDF file.
I am trying to set-up the page to fit 1 page width, and I want to modify the Horizontal Page breaks according to row numbers stored in an array PgBreakRowsArr.
After I run the attached sub-routine, the page breaks are set-up nicely, but the printing width has shrunk from ~85% to ~45%, and printing at about 50% of the page size.
Any ideas ?
Code
Option Explicit
Sub SetFriendlyPrintArea(Sht As Worksheet)
'======================================================================================================================
' Description : Sub sets the Friendly Print Area.
' It loop through 'PgBreakRowsArr' array, and per rows stored inside sets the page breaks.
'
' Argument(s) : sht As Worksheet
'
' Caller(s) : Sub RawDataToByTimeReport (Excel_to_byTime_Report Module)
'======================================================================================================================
Dim LastRow As Long, i As Long
Dim VerticalPageCount As Long, HPageBreakIndex As Long
HPageBreakIndex = 1 ' reset pg. break index
Application.ScreenUpdating = False
With Sht
.Activate
LastRow = FindLastRow(Sht)
With .PageSetup
.PrintArea = "$A$1:I" & LastRow
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
' .PaperSize = xlPaperLetter
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = UBound(PgBreakRowsArr) + 1
End With
ActiveWindow.View = xlPageBreakPreview ' switch to Page Break view to set page breaks
' Debug.Print .HPageBreaks.Count
' loop through array and create Page Breaks according to array's rows
For i = 1 To UBound(PgBreakRowsArr) - 1
Set .HPageBreaks(i).Location = Range("A" & PgBreakRowsArr(i))
Next i
' --- last one need to add it (not move existing one) ---
.HPageBreaks.Add Before:=Range("A" & PgBreakRowsArr(i))
ActiveWindow.View = xlNormalView ' go back to normal view
End With
Application.ScreenUpdating = True
End Sub
.HPageBreaks is a nightmare. I pulled my hair out many times on it. Here you are a few magical things that make no harm and may help:
Issue .ResetAllPageBreaks before setting anything
Turn Application.PrintCommunication = False before and ... True after. It can improve the result, and also can speed up the operation. It depends on your printer and the printer driver.
Move the activecell out of the affected area and restore it (if necessary) after setting page breaks, like
somestring = Activecell.Address
Cells(4000, 3000).Activate
....
Range(somestring).Activate
If the amount of pages on the actual sheet and the size of the arrangement required for page division are different, the phenomenon of enlargement and reduction occurs. If the size of the array is smaller than the actual page amount, it will shrink, so it would be better to delete this phrase.
.FitToPagesTall = UBound(PgBreakRowsArr) + 1
Case FitToPagesTall is 5 in a 16-page document
Case FitToPagesTall is 8
Case FitToPagesTall is 10
Case FitToPagesTall is 13
Case FitToPagesTall is 16 or remove the that code

Can't insert pictures in Excel with VBA

I am getting completely crazy about this issue, please help me.
I have made a shell script that writes in a text file the path of some images that are stored in a folder. Then I use an excel code to read each path and write it in an excel cell.
I have then made a code that should take that path and use it to insert the picture. I have tried with Pictures.insert(path) and shapes.addpictures "path", but I have the same issue every time, the picture can't be loaded.
What's weird, is that, if I manually insert the picture before and then delete it, the code will perfectly load the picture. But if it's the first time then no.
The paths that I'm using look like that: "/Users/theodorebedos/Documents/code_tilly/new_pict_tilly/IMG_9040.jpg"
I'm using a mac, maybe that matters?
Private Sub Convert_Img()
Dim myPict As Picture
Dim PictureLoc As String
Dim EndPictRow, i As Integer
Dim StartPath As String
If Worksheets("Main").Cells(3, 1).Value <> "" Then
EndPictRow = Worksheets("Main").Range("A2").End(xlDown).Row
For i = 3 To EndPictRow
PictureLoc = Worksheets("Main").Cells(i, 1).Value
Worksheets("Main").Cells(i, 1).ClearContents
Worksheets("Main").Cells(i, 1).ColumnWidth = 30
Worksheets("Main").Cells(i, 1).RowHeight = 150
ActiveSheet.Shapes.AddPicture PictureLoc, False, True, Worksheets("Main").Cells(i, 1).Left, Worksheets("Main").Cells(i, 1).Top, Worksheets("Main").Cells(i, 1).Width, Worksheets("Main").Cells(i, 1).Height
Next i
End If
End Sub
Edit:
When I use "Pictures.insert" or "shapes.addpicture path, true, true " I have no error message in VBA but I have in excel instead of my picture, a blank image with inside an error message like this:
image
If I use "shapes.addpicture path, FALSE, true" then I have an error message like this but no image at all is loaded: image 2
And then an error 1004 like that:
image3
And if I do the process to have image 1, then I save the document, reopen it, I'll have this directly: image 4
Thanks for you help. It will be much appreciated.
I streamlined your code so it becomes possible to see what it's doing. Note that I avoided reading values from the cell's properties which were just set or are obvious.
Once the column width has been set, the width of all cells in it are the same.
The Left property of all cells in a column is always the same.
If the column is column A, the Left is always 0.
Of course, what you tried to achieve is to enter a value only once. That is good practice but to read properties from the sheet is slow. The faster way - less code volume and better readable, too - is to declare a constant at the top and use that name in the code.
So you end up with this code.
Private Sub Convert_Img()
Const ClmWidth As Single = 30
Const RowHight As Single = 150
Dim EndPictRow As Long, R As Long
' sorry, I recommend i for arrays and R for rows (C for columns)
With Worksheets("Main")
' End(xlDown) will find the first blank cell below the base cell.
' There might be more filled cells further down.
' End(xlUp) will find the first used cell above the base cell
' disregarding more blanks above that one.
EndPictRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' no need to set the column width multiple times in the loop
.Columns(1).ColumnWidth = ClmWidth
' this loop will never run if R < EndPicRow
For R = 3 To EndPictRow
With .Cells(R, 1)
.RowHeight = RowHight
' this will work only once:-
.Worksheet.Shapes.AddPicture CStr(.Value), False, True, 0, .Top, ClmWidth, RowHight
End With
Next R
End With
End Sub
The reason why it works only once becomes quite obvious. The new picture takes its source path from the cell's Value. Of course, once you insert a picture (image) in the cell that value can't be the path (string) anymore. If you run the code a second time it will fail. However, if that is your need, it should be possible to extract the path from the formula that defines the picture in the cell. Given that the picture itself isn't present at that location the formula should either hold the path or a reference to a location within the workbook's background data, depending upon how it was loaded.
Ok, so it's not perfect yet, but I put the loop off and I used Dir() as you said #Variatus.A pop-up window like this opened when I executed the command Dir(). It asked me the authorisation to access the file. I pressed yes and then it worked.
It worked but only for that file. So I guess, I am on the right way now and I need to find how to give access to all the files in that folder before running the code. I can't do it for all of them.
Thank you very much.
I hope someone will benefit from this old thread. As it turns out this is some sort of a permission issue also noted already in one of the comments, possibly only occurring with Excel 16 macros on OSX.
It seems like Excel is lacking the permissions to access the resources linked and is not asking for them. We need to grant permissions to all files in the folder. The following code demonstrates how to achieve this, given the identifier to build the paths is in Column A2:20. Run this macro (adjust the way the path is built), then grant access once the dialogue appears:
Sub GrantAccess()
Dim cName As Variant
Dim files() As Variant
Set xRange = ActiveSheet.Range("A2:A20")
For Each cell In xRange
ReDim Preserve files(1 To cell.Row - 1)
cName = "/Users/adjust-your-path/path" & Cells(cell.Row, "A") & "_thumb_600.png"
files(cell.Row - 1) = cName
Next
fileAccessGranted = GrantAccessToMultipleFiles(files)
End Sub
Code used:
Sub URLPICInsertMM()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
Dim cName As String
Dim img As Picture
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("B2:B10")
For Each cell In xRange
'cName = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
' files are located in thumbs sub-directory
cName = "/Users/.../IonChannels/thumbs/" & Cells(cell.Row, "A") & "_thumb_300.png"
Set img = ActiveSheet.Pictures.Insert(cName)
img.Select
Set cShape = Selection.ShapeRange.Item(1)
If cShape Is Nothing Then GoTo line22
Cells(cell.Row, "C").Value = "file://" & cName
Set cRange = Cells(cell.Row, cell.Column)
With cShape
.LockAspectRatio = msoTrue
'If .Width > cRange.Width Then .Width = cRange.Width
If .Height > cRange.Height Then .Height = cRange.Height
.Top = cRange.Top + (cRange.Height - .Height)
.Left = cRange.Left + (cRange.Width - .Width)
End With
line22:
Set cShape = Nothing
Range("T2").Select
Next
Application.ScreenUpdating = True
End Sub
Edit:
Evidence:
I created a simple test sheet (the idea is to load some protein visualization thumbs into an excel sheet) with an identifier in Column A, image file descriptors are constructed from the identifier + path and file extension.
The image is inserted into Column B and the file descriptor as text into Column C.
When I ran the macro for the first time, only the first image was loaded. Excel formats the file descriptor as a hyperlink. When clicking the file:///... link, Excel opens a dialog that asks to grant permissions to that file (screenshot). If I grant access and accept warnings, then run the macro again, the image appears.
After running macro again, image is displayed:

Format Table Style in PowerPoint from Excel - 2013

I have the following code block that loops through an array of table names in a workbook. It is a ParamArray from a calling procedure (Callback). It copies each table and pastes it to the ppt slide. Then it creates a textbox, which is the title for the table. I am pasting it using the destination style (which I think is the default) because I want to use ppt styles. The object I am pasting from Excel is a table. How can I change the style of the table after it is pasted and make the first row bold? Changing PowerPoint Table Styles doesn't seem to be well documented. I tried the commented section below but it didn't work. Thank you!
For i = LBound(vObjects(0)) To UBound(vObjects(0))
Set practice = ActiveWorkbook.Worksheets(Range("T_" & vObjects(0)(i)).Parent.Name).ListObjects("T_" & vObjects(0)(i))
practice.Range.Copy
PPT_Slide.Shapes.Paste 'Special DataType:=ppPasteOLEObject, Link:=msoTrue
Set PPT_Shape = PPT_Slide.Shapes(PPT_Slide.Shapes.Count)
PPT_Shape.Name = "OBJ_" & vObjects(0)(i)
' With PPT_Shape
' .ApplyStyle "{C083E6E3-FA7D-4D7B-A595-EF9225AFEA82}", True
' .Rows(1).Font.Bold = True
' End With
Set objPPT_MilestoneTextbox = PPT_Slide.Shapes.AddTextbox(1, Left:=320, Top:=HorizontalTop, Width:=300, Height:=50).TextFrame.TextRange
With objPPT_MilestoneTextbox
.Text = vObjects(0)(i)
.Font.Size = 14
.Font.Bold = True
.ParagraphFormat.Alignment = 2
End With
Set PPT_Shape = PPT_Slide.Shapes(PPT_Slide.Shapes.Count)
PPT_Shape.Name = "CAP_" & vObjects(0)(i)
Next i
Application.CutCopyMode = False
This MS page documents the table style ids for PPT 2010 (and points out that they may not be the same for subsequent versions):
https://code.msdn.microsoft.com/office/PowerPoint-2010-Interact-ea2fbe1b
But you need to apply the style to the shape's .Table object, not to the shape itself. Try modifying your code like this:
Dim otbl As Table
Set PPT_Shape = PPT_Slide.Shapes(PPT_Slide.Shapes.Count)
Set otbl = PPT_Shape.Table
With otbl
.ApplyStyle "{C083E6E3-FA7D-4D7B-A595-EF9225AFEA82}", True
End With

Web Query from URL in Cell

I believe I have thoroughly researched this question (sorry if you have seen the answer, please be patient with me).
Truly a newcomer to VBA/Macros and do not even fully understand where to "put" the codes that are provided in these message boards, that is why I prefer a formula.
My sheet has cells which feed to a hyperlink (i.e. A1=JFK, B1:CVG, C1=HYPERLINK("http://www.gcmap.com/dist?p="&A1&"-"&B1,"My Flight").
If you visit the link (http://www.gcmap.com/dist?P=jfk-cvg) it shows the flying distance between these two points - 589 mi.
What I am trying to do is do a web query in Excel based off the link provided in cell C1, and then have the web query point to the total distance included in the link - and then populate another cell on my sheet (D1) with that distance.
Any and all help would be appreciated!
How's something like this:
Sub getMiles()
'Thanks to http://stackoverflow.com/questions/16975506/how-to-download-source-code-from-a-website-with-vba for idea
Dim k As Long, s
Dim URL2 As String
Dim ws As Worksheet, newWS As Worksheet
Set ws = ActiveSheet
Application.ScreenUpdating = False
URL2 = ws.Cells(1, 3) 'Cell C1 is the URL
' to get data from the url we need to creat a win Http object_
' tools > references > select Windows Win Http Services 5.1
Dim Http2 As New WinHttpRequest
'open the url
Http2.Open "GET", URL2, False
' send request
Http2.Send
'MsgBox Http2.ResponseText
Debug.Print s
'Debug.Print Http2
Debug.Print URL2
Dim Resp As String: Resp = Http2.ResponseText
Dim Lines2 As Variant: Lines2 = Split(Resp, ">")
Worksheets.Add after:=Sheets(Sheets.Count)
Set newWS = ActiveSheet
newWS.Name = "Temp for source code"
k = 0
For k = LBound(Lines2) To UBound(Lines2)
newWS.Cells(1 + k, 1).Value = Lines2(k)
k = k + 1
Next k
Dim findString As String, stringCell As Range
findString = " mi"
Set stringCell = newWS.Columns(1).Find(what:=findString)
Dim milesFlown As String
milesFlown = Left(stringCell.Value, WorksheetFunction.Search("&", stringCell, 1) - 1)
'MsgBox ("You would fly " & milesFlown)
ws.Cells(1, 4).Value = milesFlown
Application.DisplayAlerts = False
newWS.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
It's sort of roundabout, but what it does is get the source code of your URL, and in that source code, look for a string that only seems to occur before the miles are given (" mi"), then finds the numbers to the left of the &, and sets that as your miles. You will need to tweak the macro to correctly point to the cell with your URL. Let me know if you need any help doing so!
edit: Ah, to use this code, with Excel open, press ALT+F11, this will open up the VB editor. I think you can insert this code (just copy/paste) into the "Sheet1 (Sheet1)" part. If not, you'll need to right click "VBAProject ([yourbook])" and Insert Module, and put the code there. It should then show up in your macro list (View tab --> Macros).
Edit2: Also, you'll need to add a Reference most likely in VBA. Press ALT+F1 to open VB Editor, then in Tools -> References, look for "Microsoft WinHTTP Services, version 5.1" and add a check mark, and click "Ok" to add this reference. Otherwise, you'll get an error.
Edit3: Updated the code. It now puts the source code on a new sheet, so anything you have in Col. A won't be deleted.

Resources