Given a workbook like this one:
I need to add the logo from cell A2 - worksheet A, in the footer of worksheets B,C.
Here's the code I've found and modified a little bit but it is not working.
Sub Logo()
Dim printWorksheet As Worksheet
Dim logoShape As Shape
Dim tempImageFile As String
Set printWorksheet = ThisWorkbook.ActiveSheet
Set logoShape = ThisWorkbook.Sheets("A").Shapes("myLogo")
tempImageFile = Environ("temp") & Application.PathSeparator & "image.jpg"
Save_Object_As_Picture logoShape, tempImageFile
With printWorksheet.PageSetup
.RightHeaderPicture.FileName = tempImageFile
.RightHeader = "&G"
End With
I have found a solutions (http://www.vbforums.com/showthread.php?538529-Export-an-Image-from-Excel-Sheet-to-Hard-Drive), that I have adopted to this task.
The key is, that a chart object can be exported as a picture, so the original shape is copied into a chart.
The chart is created, used, and deleted.
The ShapeExportAsPicture has two arguments: the shape, that is to be exported as picture and the full path where to store it.
Sub Logo()
Dim printWorksheet As Worksheet
Dim logoShape As Shape
Dim tempImageFile As String
Set printWorksheet = ThisWorkbook.ActiveSheet
Set logoShape = ThisWorkbook.Sheets("A").Shapes("myLogo")
logoShape.Visible = True
tempImageFile = Environ("temp") & Application.PathSeparator & "image.jpg"
Call ShapeExportAsPicture(logoShape, tempImageFile)
With printWorksheet.PageSetup
.RightFooterPicture.Filename = tempImageFile
.RightFooter = "&G"
End With
logoShape.Visible = False
End Sub
Private Sub ShapeExportAsPicture(pShape As Shape, sPathImageLocation As String)
Dim sTempChart As String
Dim shTempSheet As Worksheet
Set shTempSheet = pShape.Parent
Charts.Add 'Add a temporary chart
ActiveChart.Location Where:=xlLocationAsObject, Name:=shTempSheet.Name
Selection.Border.LineStyle = 0
sTempChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With shTempSheet
'Change the dimensions of the chart to the size of the original shape
With .Shapes(sTempChart)
.Width = pShape.Width
.Height = pShape.Height
End With
pShape.Copy 'Copy the shape
With ActiveChart 'Paste the shape into the chart
.ChartArea.Select
.Paste
End With
'export the chart
.ChartObjects(1).Chart.Export Filename:=sPathImageLocation, FilterName:="jpg"
.Shapes(sTempChart).Delete 'Delete the chart.
End With
End Sub
Related
I am having an issue getting the row height to adjust in Excel to the inserted image. I have tried cell.EntireRow = pic.Height but it does not adjust the row to match image height. It loops through several worksheets to find the code then selects the next empty cell to it so the image gets inserted there. Also not sure if this is the correct way to go through the entire worksheet as the is usually more that one Photo1 in there. If I can get this figured out, I can do the photo2 and photo3 using whatever solution is found.
Here is my code
Private Sub cmdInsertPhoto1_Click()
'insert the photo1 from the folder into each worksheet
Dim ws As Worksheet
Dim fso As FileSystemObject
Dim folder As folder
Dim rng As Range, cell As Range
Dim strFile As String
Dim imgFile As String
Dim localFilename As String
Dim pic As Picture
Dim findit As String
Application.ScreenUpdating = True
'delete the two sheets if they still exist
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "PDFPrint" Then
Application.DisplayAlerts = False
Sheets("PDFPrint").Delete
Application.DisplayAlerts = True
End If
Next
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "DataSheet" Then
Application.DisplayAlerts = False
Sheets("DataSheet").Delete
Application.DisplayAlerts = True
End If
Next
Set fso = New FileSystemObject
Set folder = fso.GetFolder(ActiveWorkbook.Path & "\Photos1\")
'Loop through all worksheets
For Each ws In ThisWorkbook.Worksheets
ws.Select
Set rng = Range("A:A")
ws.Unprotect
For Each cell In rng
If cell = "CG Code" Then
'find the next adjacent cell value of CG Code
strFile = cell.Offset(0, 1).Value 'the cg code value
imgFile = strFile & ".png" 'the png imgFile name
localFilename = folder & "\" & imgFile 'the full location
'just find Photo1 cell and select the adjacent cell to insert the image
findit = Range("A:A").Find(what:="Photo1", MatchCase:=True).Offset(0, 1).Select
Set pic = ws.Pictures.Insert(localFilename)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Width = 200
.ShapeRange.Height = 200 'max row height is 409.5
.Placement = xlMoveAndSize
End With
cell.EntireRow = pic.Height
End If
'delete photo after insert
'Kill localFilename
Next cell
Next ws
Application.ScreenUpdating = True
' let user know its been completed
MsgBox ("Worksheets created")
End Sub
What it currently looks like
You have to use the rowheight property of the range object: cell.EntireRow.RowHeight= pic.Height
As you wrote it (cell.EntireRow = pic.Height) you implicitly used the default property of cell.EntireRow which is value)
Managed to solve it. for anyone else its cell was selected so, this works for me:
'just find Photo1 cell and select the adjacent cell to insert the image
findit = Range("A:A").Find(what:="Photo1", MatchCase:=True).Offset(0, 1).Select
ActiveCell.EntireRow.RowHeight = 200 'max row height is 409.5
Set pic = ws.Pictures.Insert(localFilename)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Width = 200
'.ShapeRange.Height = 200 'max row height is 409.5
.ShapeRange.Height = ActiveCell.MergeArea.Height
.ShapeRange.Top = ActiveCell.MergeArea.Top
.ShapeRange.Left = ActiveCell.MergeArea.Left
.Placement = xlMoveAndSize
End With
Hi there I have the code below which calls "Delete_Image_Click" and deletes the shape in a specified cell range and then inserts a new image from a selected filepath into the same cell range.
I need to then delete images in other ranges (on the same worksheet and other worksheets) and then add the same image into the other cell ranges on the same worksheet and then go into another named worksheet and insert the same image into two more ranges.
Could anyone help me with how I go about this?
Sub RectangleRoundedCorners6_Click()
Call Delete_Image_Click
Dim sPicture As String, pic As Picture
sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.png), *.gif;*.png; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")
If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoTrue
.Height = Range("Q36:W41").Height
.Top = Range("Q36:W41").Top
.Left = Range("Q36:W41").Left
.Placement = xlMoveAndSize
End With
Set pic = Nothing
End Sub
Sub Delete_Image_Click()
Dim xPicRg As Range
Dim xPic As Picture
Dim xRg As Range
Application.ScreenUpdating = False
Set xRg = Range("Q36:W41")
For Each xPic In ActiveSheet.Pictures
Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Delete
Next
Application.ScreenUpdating = True
End Sub
I have the following dataset:
I am trying to code a macro that builds a chart for each of the locations. I have created code that creates a new workbook, names the sheet, can create the first chart for Location 1, but I need the code to then loop back through and do the same for Location 2, Location 3, etc. Here is a sample chart below:
The hard part - Sites (Column A) will change. Some months I may have up to Location 10. I need the code to be dynamic enough to create a chart for each unique Site. As you'll see in the code, I'm creating a new workbook, creating the chart in the old file, and cut/paste into a tab in the new workbook. I then rename the worksheet based on Chart Title. I then need the code to loop back to the beginning and repeat the process for each unique location in Column A.
Here is the code:
Sub ChartBuilder()
Dim Wb As Workbook
Set Wb = ActiveWorkbook
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Wb.Path & "\Outputs.xlsx"
ActiveSheet.Name = "Results"
Wb.Activate
Sheets("Sheet1").Select
'88888 Loop ends below and Loop should come back here
ActiveSheet.Shapes.AddChart2(227, xlLine).Select
With ActiveChart
'Needs to be dynamic in both Chart Title Name and Data Range
'Column A is the Location Name - will have duplicates
'Column C has the weeks. Weeks are limited to Week 1, Week 2, Week 3, Week 4
'Column E thru I are the data columns that need to be displayed.
.ChartTitle.Text = ActiveSheet.Range("A2")
.SetSourceData Source:=Range("Sheet1!$C$2:$C$5,Sheet1!$E$2:$I$5")
ActiveChart.PlotBy = xlColumns 'Chart was flipping and I couldn't figure out why, so wrote code to flip it
Set Srs1 = ActiveChart.SeriesCollection(1)
Srs1.Name = ActiveSheet.Range("$E$1")
Set Srs2 = ActiveChart.SeriesCollection(2)
Srs2.Name = ActiveSheet.Range("$F$1")
Set Srs3 = ActiveChart.SeriesCollection(3)
Srs3.Name = ActiveSheet.Range("$G$1")
Set Srs4 = ActiveChart.SeriesCollection(4)
Srs4.Name = ActiveSheet.Range("$H$1")
Set Srs5 = ActiveChart.SeriesCollection(5)
Srs5.Name = ActiveSheet.Range("$I$1")
'Resizes chart
With ActiveChart.Parent
.Height = 300
.Width = 600
.Top = 100
.Left = 100
End With
End With
'Copy to new tab, name tab same as Chart Title
'Loop back to beginning for next filter
Dim OutSht As Worksheet
Dim Chart As ChartObject
Dim PlaceInRange As Range
Workbooks("Outputs.xlsx").Activate
Set OutSht = ActiveWorkbook.Sheets("Results") '<-- Output sheet
Set PlaceInRange = OutSht.Range("B2:J21") '<-- Output location
Wb.Activate
For Each Chart In Sheets("Sheet1").ChartObjects '<-- Loop charts
Chart.Cut 'Cut/paste charts
OutSht.Paste PlaceInRange
Next Chart
Workbooks("Outputs.xlsx").Activate
Worksheets("Results").Activate
ActiveSheet.Name = ActiveChart.ChartTitle.Text
Sheets.Add.Name = "Results"
'88888 Loop back to beginning
ActiveWorkbook.SaveAs Filename:=Wb.Path & "\" & Format(Now, "yyyymmdd") & " Outputs.xlsx"
Kill Wb.Path & "\Outputs.xlsx"
Wb.Activate
End Sub
The following code assumes that there are always four weeks per location. I'm not sure why the original code created an "Outputs.xlsx", just to subsequently delete it for a "YYYYMMDDOutputs.xlsx". I just went straight to the dated file name. I also did away with the "Results" tab and just made each chart it's own tab.
Quarterback Subroutine ChartAllLocations:
Public Sub ChartAllLocations()
Dim location As String, WB As Workbook, ws As Worksheet
Dim resultsWB As Workbook, data As Range, currLocation As Range
Dim headers As Range
Set WB = ThisWorkbook
Set ws = WB.Worksheets("Data")
Set resultsWB = ResultsWorkbook(WB.path)
Set headers = ws.Range("E1:I1")
locIdx = 2
Do
Set data = ws.Cells(locIdx, 1).Resize(4, 9)
ChartBuilder2 resultsWB, data, headers
locIdx = locIdx + 4
Loop While ws.Cells(locIdx, 1).Value <> ""
resultsWB.Worksheets("Sheet1").Delete
End Sub
Function for new Workook, ResultsWorkbook:
Private Function ResultsWorkbook(path As String) As Workbook
Dim output As Workbook
Dim ws As Worksheet
Set output = Workbooks.Add
output.SaveAs filename:=path & "\" & Format(Now, "yyyymmdd") & " Outputs.xlsx"
Set ResultsWorkbook = output
End Function
Function for building each chart ChartBuilder2:
Public Sub ChartBuilder2(WB As Workbook, data As Range, hdrs As Range)
Dim Chrt As Chart
Set Chrt = WB.Charts.Add(After:=WB.Worksheets(WB.Worksheets.Count))
Chrt.Name = data.Cells(1, 1)
Chrt.HasTitle = True
Chrt.ChartTitle.Text = data.Cells(1, 1)
Chrt.SetSourceData Source:=data.Cells(1, 5).Resize(4, 5)
Chrt.ChartType = xlLine
Chrt.PlotBy = xlColumns
Chrt.FullSeriesCollection(1).XValues = _
"={""Week 1"",""Week 2"",""Week 3"",""Week 4""}"
Chrt.Axes(xlValue).TickLabels.NumberFormat = "0%"
For srsIdx = 1 To 5
Chrt.SeriesCollection(srsIdx).Name = hdrs.Cells(1, srsIdx).Value
Next srsIdx
End Sub
I am trying to save a range as a picture file. The code below (scraped from another post) works, but I don't want to create a chart page which I then need to delete. Any suggestions?
Sub savedeal()
Dim sSheetName As String
Dim oRangeToCopy As Range
Dim oCht As Chart
Dim myFileName As String, myPath As String
myFileName = Format(Now(), "dd-mmm-yy") & "-" & "DEAL.PNG"
myPath = "D:\Hughs Files\Google Drive\Work Folder\Polaris\Blog\"
Worksheets("BOOK").Range("B15:M45").CopyPicture xlScreen, xlBitmap
Set oCht = Charts.Add
With oCht
.Export Filename:=myPath & "\" & myFileName, Filtername:="PNG"
End With
End Sub
This has been discussed for years, if you want it saved as an image you will have to add a chart, even add-ins use a chart.
One thing you can do though is save the desired range as a PDF for example.
Sub RngToPDF()
Dim sh As Worksheet, rng As Range, Fnm As String
Set sh = Sheets("Book")
Set rng = sh.Range("B15:M45")
Fnm = "C:\Users\Dave\Downloads\TestMe.pdf"
With sh.PageSetup
.PrintArea = rng.Address
.PrintGridlines = True
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fnm
End Sub
I have VBA code that exports the active chart from Excel in PNG format.
I have some dots and lines, marking some important data overlaid on my Excel chart, and they are grouped (select all objects and chart, Right Click -> Group).
Is there anything that I can replace the ActiveChart with (like ActiveGroup or similar) to export the whole thing, not just the chart.
Sub ExportChartToPNG()
'Take ActiveChart and copy it as a GIF image to the same directory as the Workbook is in and name it with the Chart_Title with spaces replaced with underscores.
Dim chtCopyChart As Chart, sCurrentDirectory As String, sFileName As String
Dim x As Integer, CellCharacter As String
Dim sInteractive As Boolean
Set chtCopyChart = ActiveChart
sCurrentDirectory = ActiveWorkbook.Path
sFileName = chtCopyChart.ChartTitle.Text
sFileName = InputBox("Enter filename for export:", "Export object", sFileName)
For x = 1 To Len(sFileName)
CellCharacter = Mid(sFileName, x, 1)
If CellCharacter Like "[</*\?%]" Then
sFileName = Replace(sFileName, CellCharacter, "_", 1) ', Replaces all illegal filename characters with "_"
End If
If Asc(CellCharacter) <= 32 Then
sFileName = Replace(sFileName, CellCharacter, "_", 1) ' Replaces all non printable characters with "_"
End If
Next
sFileName = sFileName & ".png"
sFileName = sCurrentDirectory & "\" & sFileName
sInteractive = True
chtCopyChart.Export Filename:=sFileName, FilterName:="PNG", Interactive:=sInteractive
MsgBox "Chart copied to " & sFileName, vbOKOnly, "Success!"
End Sub
Old question I know, but the solution comes from the fact that a chart grouped with other shapes becomes a shape object in the worksheet. So what you actually need to do is get a reference to the shape object which is the group you've created.
However, there's no export method on shapes, so you need to create a temporary blank chart, copy the shape into it, export the new chart, then delete it.
The steps are:
Get the shape object and copy it as a picture
set myshape = Sheet24.Shapes("shapename")
myshape.CopyPicture
Create a new chartobject with the same dimensions as the source shape
set chtObj = Sheets24.ChartObjects.Add(myshape.Left, myshape.Top, myshape.Width, myshape.height)
Paste the object from the clipboard to the new chart
chtObj.Chart.Paste
Export the chart, deleting an existing file if needed
Kill fullpathandfilename
chtObj.Chart.Export filename:=fullpathandfilename, Filtername:="PNG"
Then delete the chart and clean up objects.
chtObj.Delete
Set chtObj = nothing
Here is code that works to save an image of a group of shapes. It's a modification of Jeremy's answer, that finds a specific group (based on the [Alt Text] Title found under 'Format Shape'). The sub runs a specific macro first (to update the graph in the Group).
Global Const myFilePath = "C:\YourFolder\"
Public Sub saveChart(ByVal sheetName As String, ByVal macroName As String, _
ByVal fileName As String, exportType As Integer)
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = Sheets(sheetName)
ws.Activate
Application.Run "'" & wb.Name & "'!VBAProject." & ws.CodeName & "." & macroName
Select Case exportType
Case 0 'standard chart
Set objChrt = Sheets(sheetName).ChartObjects(1)
Set myChart = objChrt.Chart
myChart.Export fileName:=myFilePath & fileName, Filtername:="JPEG"
Case 1 'Group of chart and other objects
Dim sh As Shape
Dim I As Integer
Dim groupedName As String
I = 1
'Find grouped shape in worksheet with Title of 'Export'
For Each sh In ActiveSheet.Shapes
If sh.Type = 6 Then '6 indicates it's a group
If sh.Title = "Export" Then
Set myshape = sh
groupedName = sh.Name
End If
End If
I = I + 1
Next
'Select and copy group
ws.Shapes.Range(Array(groupedName)).Select
Selection.CopyPicture
'Create temporary chart
Set chtObj = ws.ChartObjects.Add( _
myshape.Left, myshape.Top, myshape.Width, myshape.Height)
'Select temporary chart and paste the Group
chtObj.Select
chtObj.Chart.Paste
'Export the image
chtObj.Chart.Export fileName:=myFilePath & fileName, Filtername:="JPEG"
'Clean up
chtObj.delete
Set chtObj = Nothing
Case Else
End Select
Set wb = Nothing
Set ws = Nothing
End Sub