Last week i upgraded office from 16 to O365, everything seemed fine at the beginning...
I have a function that calls a userform to get a signature and place it on a hidden worksheet(layout) that will be printed in a second moment.
with office 16 i had no problems placing the signature on a hidden sheet, but with office O365, it just continues to assign the wrong top value...
I noticed that if the target sheet is active the top property of the target shape works fine, but if the sheet is not active o hidden, excel does not assign the correct value to the top property of the target shape. This issue was not present in office 2016.
Here is an example code:
Private Sub SetSignature()
Dim userSign As Shape 'picture (shape)
Dim filePth As String 'picture path
Dim signatureRng As Range 'range at which the picture will be placed
filePth = "C:\Users\UserX\Desktop\signature.png"
Set signatureRng = ThisWorkbook.Sheets("LayoutDoc").Range("A48")
Set userSign = ThisWorkbook.Sheets("LayoutDoc").Shapes.AddPicture(filePth, False, True, 1, 1, 1, 1)
With userSign
.ScaleHeight 0.4, True
.ScaleWidth 0.4, True
.Top = signatureRng.Top - Application.CentimetersToPoints(0.3)
.Left = signatureRng.Left + Application.CentimetersToPoints(0.1)
.Name = "Signature1"
End With
End Sub
And here is the full function:
Private Function GetSignature() As String
Dim signaturePath As String 'Signature path
Dim userSign As Shape 'Signature img
Dim filePth As String 'Signature file path
Dim signatureRng As Range 'range at which the signature should be placed
Dim checkTopSignature As Boolean 'used to check if the picture top was set correctly
Dim sheetVisibilty As Integer 'sheet visibility
Dim curScreenUpSt As Boolean 'current screenupdating state
filePth = PJ_PubVar.firmeTempDir & "\" & PJ_PubVar.kFirmaApPrepInt & nuovoPermesso.ID & PJ_PubVar.firmaExtenion
'assign the range at which the signture will be placed
Set signatureRng = ThisWorkbook.Sheets(WB_PubVar.curWB_wsLayoutPermesso).Range(WB_PubVar.curWB_rngOraFirmaInizioInt)
'get sheet visibility
sheetVisibilty = ThisWorkbook.Sheets(WB_PubVar.curWB_wsLayoutPermesso).Visible
'get current screenupdating state
curScreenUpSt = Application.ScreenUpdating
'userform to get the signature from the user
With FormSignature
.filePath = filePth
.Show
End With
'if signature acquired, then save the signature address and add it to the document layout
If firmaAquisita Then
signaturePath = filePth
'add the signature to the sheet (hidden)
Set userSign = ThisWorkbook.Sheets("LayoutDoc").Shapes.AddPicture(signaturePath, False, True, 1, 1, 1, 1)
'setup picture position and dimentions
With userSign
.ScaleHeight PJ_PubVar.perceMisuFirma, True
.ScaleWidth PJ_PubVar.perceMisuFirma, True
'******************************************************************************************************************************************
'******************************************************************************************************************************************
'**** 04/15/2022:
'**** After switching to Office 365, I noticed that when the sheet is not active (or hidden) the top of the picture is assigned incorrectly
'**** as a work arround I had to assign the same value of the top of the range to the image top
'**** check if the values are the same, if they are the same (office 2016) I proceed normally
'**** otherwise, I unlock the wb and activate the worksheet
'**** I set top, left and name
'**** set back the worksheet visiblity and the workbook protection as before
'assign the same value of the top of the range to the image top
.Top = signatureRng.Top
'check if the values are the same
checkTopSignature = (.Top = signatureRng.Top)
If Not checkTopSignature Then
'I unlock the wb and activate the worksheet
Application.ScreenUpdating = False
ThisWorkbook.Unprotect (WB_PubVar.curWB_Password)
With Sheets(WB_PubVar.curWB_wsLayoutPermesso)
.Visible = xlSheetVisible
.Activate
End With
'set top, left and name of the picture
.Top = signatureRng.Top - Application.CentimetersToPoints(PJ_PubVar.offsetFirmaInCm_H)
.Left = signatureRng.Left + Application.CentimetersToPoints(PJ_PubVar.offsetFirmaInCm_W)
.Name = WB_PubVar.curWB_imgFirmaInizioInt
'set back the worksheet visiblity and the workbook protection as before
Sheets(WB_PubVar.curWB_wsLayoutPermesso).Visible = sheetVisibilty
ThisWorkbook.Protect (WB_PubVar.curWB_Password)
Application.ScreenUpdating = curScreenUpSt
Else
.Top = signatureRng.Top - Application.CentimetersToPoints(PJ_PubVar.offsetFirmaInCm_H)
.Left = signatureRng.Left + Application.CentimetersToPoints(PJ_PubVar.offsetFirmaInCm_W)
.Name = WB_PubVar.curWB_imgFirmaInizioInt
End If
'******************************************************************************************************************************************
'******************************************************************************************************************************************
End With
Else
signaturePath = ""
End If
GetSignature = signaturePath
End Function
Here is a screenshot of the issue.. even if i assign the range.top value to the picture.top, vba just ignores it...
Does anyone know what is wrong?
Is it a bug with office 365?
Thanks in advance.
Hello i found you message and i have the same issue i thinks.
I just want position a picture in top left corner of a cell. The higher the index of the row, the more the offset is visible.
Exemple : https://imgur.com/5id3KsY
Related
The task is to loop through an Excel workbook with multiple sheets and copy all the charts contained in the workbook into a PowerPoint presentation, one chart per slide and always the same layout.
Sub PPT_Example()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim sh As Worksheet
Dim ch As ChartObject
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9
For Each sh In ActiveWorkbook.Sheets
For Each ch In sh.ChartObjects
Dim pptSlide As Slide
Dim Title As Object
Dim Box As Object
Dim Txt As Object
Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
ch.Copy
With pptSlide.Shapes.Paste
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
'Insert Box
Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
Prop_Box.Name = "Box"
pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
'Insert the text box
Set Txt = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
Txt.Name = "Txt"
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
'Clear the Clipboard
Dim oData As New DataObject 'object to use the clipboard
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard
Next
Next
End Sub
The code works on my example (2 sheets, 3 charts total) but not if I apply it to the real thing, which is a workbook with 10-15 sheets and 8 charts per sheet. At some (random?) point, the code stops and gives me this error.
Run-time error:
Shapes (unknown member): Invalid request. Clipboard is empty or contains data which may not be pasted here.
I noted that the code crashed earlier, the more objects I put on the slides (which is why I left the text and the box in my example, although not strictly neccessary). Given that and the error message, I assumed the clipboard might not be cleared properly after each loop, so I put in a section to clear the clipboard but it didn't solve the issue.
After the chart is copied, try adding DoEvents and pausing the macro for a few seconds before pasting it into your slide. And the same thing after it's pasted into your slide.
So, for example, first add the following function to pause your code . . .
Sub PauseMacro(ByVal secs As Long)
Dim endTime As Single
endTime = Timer + secs
Do
DoEvents
Loop Until Timer > endTime
End Sub
Then try something like this . . .
ch.Copy
DoEvents
PauseMacro 5 'pause for 5 seconds
With pptSlide.Shapes.Paste
DoEvents
PauseMacro 5 'pause for 5 seconds
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
You may find through testing that you can pause for less than 5 seconds, maybe 3 seconds.
My approach is to split out potentially time-consuming operations into separate functions (see "'' Call as a Function" below). When a function is called, and then has to return, it seems that Excel/VBA/the-little-green-men-running-everything make sure that whatever operation it is waits until the operation is finished (the chart is totally added to the clipboard, the clipboard contents are totally pasted, the shape is totally instantiated, etc.) before continuing.
This also means not necessarily forcing a delay during execution that might not be needed (the Do Until or Loop Until or Wait that is often suggested).
So your code might look like this (caveat: untested)
Sub PPT_Example()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim sh As Worksheet
Dim ch As ChartObject
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9
For Each sh In ActiveWorkbook.Sheets
For Each ch In sh.ChartObjects
Dim pptSlide As Slide
Dim Title As Object
Dim Box As Object
Dim Txt As Object
Set pptSlide = NewSlide(pptPres) '' Call as a Function
ch.Copy
Dim shp As PowerPoint.Shape
Set shp = NewShape(pptSlide) '' Call as a Function
With shp
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
'Insert Box
Set Box = NewBox(pptSlide) '' Call as a Function
Prop_Box.Name = "Box"
pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
'Insert the text box
Set Txt = NewTextBox(pptSlide) '' Call as a Function
Txt.Name = "Txt"
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
'Clear the Clipboard
Dim oData As New DataObject 'object to use the clipboard
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard
Next
Next
End Sub
Function NewSlide(pptPres As PowerPoint.Presentation) As PowerPoint.Slide
Set NewSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
End Function
Function NewShape(pptSlide As PowerPoint.Slide) As PowerPoint.Shape
Set NewShape = pptSlide.Shapes.Paste
End Function
Function NewBox(pptSlide As PowerPoint.Slide) As Object
Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
End Function
Function NewTextBox(pptSlide As PowerPoint.Slide) As Object
Set NewTextBox = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
End Function
my program :
produce a picture that is extracting data from excel .
Paste it in word and make the page setting as Landscape .
However ,the picture generated is small and the setting of page become custom.
the photo is so wide .I don't want to enlarge by myself everytimes.
How can I add this setting in vba ?Make it as large and wide as it can .
Secondly , it is pleasure that the data extracted can be pasted as table format.
my codes :
Private Sub CommandButton1_Click()
Dim tbl0 As Excel.RANGE
Dim Tbl As Excel.RANGE
Dim tbl2 As Excel.RANGE
Dim wordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("17-18") ' Change e.g. sheet9.Name
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
Value1 = Me.TextBox1.Value
Value2 = Me.TextBox2.Value
ws.Rows("84:89").EntireRow.Hidden = True 'ADJUST AS APPROPRIATE
'Copy Range from Excel
'Set tbl0 = ws.RANGE("A78:I83")
Set Tbl = ws.RANGE("A78:I92")
' Set tbl2 = ws.Range("A90:I92")
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already opened?
Set wordApp = GetObject(Class:="Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already open then open MS Word
If wordApp Is Nothing Then Set wordApp = CreateObject(Class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
wordApp.Visible = True
wordApp.Activate
'Create a New Document
Set myDoc = wordApp.Documents.Add
'Trigger copy separately for each table + paste for each table
Tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture
wordApp.Selection.Paste
wordApp.Selection.TypeParagraph
wordApp.Selection.PageSetup.Orientation = wdOrientLandscape
resize_all_images_to_page_width myDoc
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Although I don't fiddle with Word but Excel only it might give you an idea...
The code of my XmasPrep excel sucks in a bunch of pictures in order to produce a catalog, listing the pictures to select from.
For each line, i.e. each picture, the code
assigns an Excel cell range and then resizes the range ROW height and width
as well as the range height itself
assigns the picture object thisPic = .Parent.Pictures.Insert(picFileName) and then resizes that according to the cell range's coordinates and size:
thisPic.Top = .Top + 1
thisPic.Left = .Left + 1
thisPic.Width = .Width - 2
thisPic.Height = .Height - 2
So, if you're able to grab the picture object (thisPic) in Word you might be able to resize it to your needs as well. Hope it helps.
:
Const MaxHeight = 50
Const MaxWidth = 14
Dim picFileName As String
Dim i, j, k As Long
Dim col_Filenames As Long
Dim col_Pictures As Long
Dim range_PicCell As Range
Dim thisPic As Picture
:
picFileName = filesPath & select2order.Cells(i, col_Filenames).Value
Set range_PicCell = select2order.Cells(i, col_Pictures)
range_PicCell.RowHeight = MaxHeight
range_PicCell.ColumnWidth = MaxWidth
With range_PicCell
.Height = MaxHeight
Set thisPic = .Parent.Pictures.Insert(picFileName)
thisPic.Top = .Top + 1
thisPic.Left = .Left + 1
thisPic.Width = .Width - 2
thisPic.Height = .Height - 2
End With
:
I am programmatically placing a button on a worksheet and it places fine, however when I click it i get an error saying "Cannot run the macro. The macro may not be available in this workbook or all macros may be disabled". I believe I've set it up fine but here is my code if anyone spots anything would greatly appreciate it.
Sub ButtonGenerator()
Application.ScreenUpdating = False
Dim wsCRC As Worksheet
Set wsCRC = Worksheets("CRC")
Dim lcolumncrc As Long
lcolumncrc = CRC.LastColumnInCRC
'Button Declarations
Dim ShowHideDates As Button
wsCRC.Buttons.Delete
'Show/Hide Dates Button Set Up
Dim SHDrange As Range
Set SHDrange = wsCRC.Range(Cells(5, lcolumncrc + 2), Cells(5, lcolumncrc + 4))
Set ShowHideDates = wsCRC.Buttons.Add(SHDrange.Left, SHDrange.Top, SHDrange.Width, SHDrange.Height)
With ShowHideDates
.OnAction = "wsCRC.SHDbtn"
.Caption = "Show Hidden Date Columns"
.Name = "ShowHideDates"
End With
Application.ScreenUpdating = True
End Sub
Sub SHDbtn()
Dim wsCRC As Worksheet
Set wsCRC = Worksheets("CRC")
Dim ShowHideDates As Button
Dim CurrentDateColumn As Long
CurrentDateColumn = GetTodaysDateColumn()
ActiveSheet.Unprotect
If ShowHideDates.Caption = "Hide Old Date Columns" Then
wsCRC.Range(wsCRC.Cells(5, 10), wsCRC.Cells(5, CurrentDateColumn - 6)).EntireColumn.Hidden = True
ShowHideDates.Caption = "Show Hidden Date Columns"
Else
wsCRC.Range(wsCRC.Cells(5, 10), wsCRC.Cells(5, CurrentDateColumn - 6)).EntireColumn.Hidden = False
ShowHideDates.Caption = "Hide Old Date Columns"
End If
ActiveSheet.Protect
End Sub
You're referring to a worksheet by the label you've given it within your code, not as a sheet itself.
Try changing:
.OnAction = "wsCRC.SHDbtn"
to
.OnAction = "CRC.SHDbtn"
or even
.OnAction = "SHDbtn"
Whilst this proven method has worked for people and works for me in the general sense, I receive "Error 1004: Method 'Paste' of object '_Chart' failed." However, on the 5th iteration of the loop this method failure occurs. I have tried isolating each component of the Array and the 6th and 7th elements always fail, but when the 5th element is used in isolation or as the starting point of the loop it succeeds. I have also tried clearing the clipboard at different stages of the process to see if that helps and tested the object property of the "cht" object.
Sub PicturesCopy()
'Define path variables
Path = "C:\Users\khill\Documents\Macro Tests\"
PathSC = Path & "Master Cockpit\"
FileMCP = "Master_Daily sales cockpit.xlsm"
Set wbMCP = Workbooks(FileMCP)
Dim cht As ChartObject
Dim rngList, fileList As Variant
rngList = Array("B2:Y19", "B22:U39", "B43:O58", "B61:R76", "B81:J96", "B101:AD118", "B122:V139")
fileList = Array("Fig 1a", "Fig 1b", "Fig 2a", "Fig 2b", "Fig 2c", "Fig 3a", "Fig 3b")
For x = 0 To UBound(rngList)
'Application.CutCopyMode = True
With wbMCP.Worksheets("Graphs")
Debug.Print rngList(x)
Dim rgExp As Range: Set rgExp = .Range(rngList(x))
Debug.Print x
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
''' Create an empty chart with exact size of range copied
Set cht = wbMCP.Worksheets("Pictures").ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
Width:=rgExp.Width, Height:=rgExp.Height)
cht.Name = "PicChart"
With cht
.Chart.Paste
Debug.Print fileList(x)
.Chart.Export "C:\Users\khill\Documents\Macro Tests\Pics\" & fileList(x) & ".jpg"
.Delete
'Application.CutCopyMode = False
End With
Set cht = Nothing
Set rgExp = Nothing
Next x
End Sub
Have you tried using a clipboard viewer to verify that the rgExp.CopyPicture operation has done what you expect when Debug.Print x shows 5 (6th iteration)?
Assuming you are using some version of Windows, there are some tips on how to view clipboard here, depending on version:
View & Manage Clipboard In Windows 10 / 8 / 7
http://www.thewindowsclub.com/windows-clipboard-manager-viewer
Ok. I found the problem. The charts have to be contained within the viewable screen to be pasted by the clipboard. so you can either zoom out (not ideal because the images are saved small and therefore pixelated) or zoom to the new Chart area/select the position where the chart object is placed in the first place. My solution was to zoom to the range. Adjusted Code is below. Hope this helps someone else :)
Sub PicturesCopy()
'Define path variables
Path = "C:\Users\khill\Documents\Macro Tests\"
PathSC = Path & "Master Cockpit\"
FileMCP = "Master_Daily sales cockpit.xlsm"
Set wbMCP = Workbooks(FileMCP)
Dim cht As ChartObject
Dim rngList, fileList As Variant
rngList = Array("B2:Y19", "B22:U39", "B43:O58", "B61:R76", "B81:J96", "B101:AD118", "B122:V139")
fileList = Array("Fig 1a", "Fig 1b", "Fig 2a", "Fig 2b", "Fig 2c", "Fig 3a", "Fig 3b")
For x = 0 To UBound(rngList)
'Application.CutCopyMode = True
With wbMCP.Worksheets("Graphs")
Debug.Print rngList(x)
Dim rgExp As Range: Set rgExp = .Range(rngList(x))
Debug.Print x
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
''' Create an empty chart with exact size of range copied
Set cht = wbMCP.Worksheets("Pictures").ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
Width:=rgExp.Width, Height:=rgExp.Height)
cht.Name = "PicChart"
'Use ZoomToRange sub to re-size the window as appropriate
ZoomToRange ZoomThisRange:=Range(rngList(x)), PreserveRows:=True
With cht
.Chart.Paste
Debug.Print fileList(x)
.Chart.Export "C:\Users\khill\Documents\Macro Tests\Pics\" & fileList(x) & ".jpg"
.Delete
'Application.CutCopyMode = False
End With
Set cht = Nothing
Set rgExp = Nothing
Next x
End Sub
The ZoomToRange macro that is called in the above is as follows:
Sub ZoomToRange(ByVal ZoomThisRange As Range, _
ByVal PreserveRows As Boolean)
'###################################
'This macro resizes the window and''
'zoom properties to be appropriate''
'for our use''''''''''''''''''''''''
'###################################
'Turn alerts and screen updating off
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Declare variable type
Dim Wind As Window
'Create variable for window
Set Wind = ActiveWindow
'Zooming to specified range set to true
Application.GoTo ZoomThisRange(1, 1), True
'Select the resized range
With ZoomThisRange
If PreserveRows = True Then
.Resize(.Rows.Count, 1).Select
Else
.Resize(1, .Columns.Count).Select
End If
End With
'Set zoom and visible range to specified range
With Wind
.Zoom = True
.VisibleRange(1, 1).Select
End With
End Sub
Ok, here is what I am looking for (Im new, so be gentle):
Copy and paste (default format) from excel to powerpoint (from just the one sheet)
I can only fit so many rows in ppt - so after a slide fills, I want ppt to create a new slide
Same title for each slide is fine!
I only need columns B:K copied over
That's it, however I am stuck :( I know the below code is NOT the best way to write this and it contains errors in which I am sure will be easy to spot. I cannot find how to do this anywhere on the net.
This is what I have so far:
Sub ExcelRangeToPowerPoint()
Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim i As Integer
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)
For i = 1 To 6
'need to set focus to slde 1
PowerPointApp.ActiveWindow.View.GotoSlide (1)
'Deletes Title
'mySlide.Shapes.Title.Delete
'builds new title
mySlide.Shapes.AddShape Type:=msoShapeRectangle, left:=9, Top:=6, Width:=702, Height:=30
mySlide.Shapes(mySlide.Shapes.Count).Line.Visible = msoTrue
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Font.Size = 20
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Text = "Current Full Initiative Details – Branded Book as of " & Date
mySlide.Shapes(mySlide.Shapes.Count).Name = "I am TITLE"
mySlide.Shapes(mySlide.Shapes.Count).Line.ForeColor.RGB = RGB(0, 0, 0)
mySlide.Shapes(mySlide.Shapes.Count).Line.Weight = 1
mySlide.Shapes(mySlide.Shapes.Count).Fill.Visible = msoTrue
mySlide.Shapes(mySlide.Shapes.Count).Fill.ForeColor.RGB = RGB(255, 255, 255)
'Copy Range from Excel
Set rng = ActiveWorkbook.Worksheets("RAW").Range("B1:K23")
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
PowerPointApp.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShapeRange.left = 10
myShapeRange.Top = 42
myShapeRange.Height = 492
myShapeRange.Width = 702
ActiveWorkbook.Sheets("RAW").Rows("2:23").Delete
Call myPresentation.Slides.Add(1, PpSlideLayout.ppLayoutTitleOnly)
'Clear The Clipboard
Application.CutCopyMode = False
Next i
End Sub
As requested in comments, here is the code I use to copy a slide from a master PPT template to the report PPT.
There is some extraneous code in there to provide status updates on the form we use to drive the process, as well as a debugging flag that I can toggle on/off at run time - these can both be removed.
This will serve as a starting point to finding the proper solution for your situation, and is not a complete answer to the question as asked.
'I've chosen to declare these globally, though it's probably not the best way:
Dim PPTObj As PowerPoint.Application
Dim PPTMaster As PowerPoint.Presentation
Dim PPTClinic As PowerPoint.Presentation
Private Sub InsertPPT(ByVal SlideName As String, ByVal StatusText As String)
Dim Shp As PowerPoint.Shape
Dim Top As Single
Dim Left As Single
Dim Height As Single
Dim width As Single
PPTMaster.Slides(SlideName).Copy
PPTClinic.Slides.Paste
Form_Master.ProcessStatus.Value = StatusText & " InsertPPT"
With PPTClinic.Slides(PPTClinic.Slides.count)
If Debugging Then
.Select
End If
.Design = PPTMaster.Slides(SlideName).Design 'this ensures we get all the right formatting - only seems to be necessary 1 time, but we'll just do it on all
.ColorScheme = PPTMaster.Slides(SlideName).ColorScheme
.FollowMasterBackground = PPTMaster.Slides(SlideName).FollowMasterBackground
For Each Shp In .Shapes 'loop through all the shapes on the slide
If Debugging Then
' .Select
Shp.Select
End If
Form_Master.ProcessStatus.Value = StatusText & " InsertPPT-" & Shp.Name
If Shp.Type = msoLinkedOLEObject Then 'when we find a linked one
ReLinkShape Shp, TempVars!NewXLName
'need to store off top, left, width, height
Top = Shp.Top
Left = Shp.Left
Height = Shp.Height
width = Shp.width
Shp.LinkFormat.Update 'and force the link to refresh
MySleep 2, "S" 'hopefully, the 2 second pause will allow everything to update properly before moving on.
'then reset them here - they seem to change shape when I update them
Shp.LockAspectRatio = msoFalse
Shp.Top = Top
Shp.Left = Left
Shp.width = width
Shp.Height = Height
ElseIf Shp.Name = "SlideName" And Not Debugging Then 'if it's the "SlideName" tag
Shp.Delete 'delete it (unless we're debugging)
End If
Next
End With
Form_Master.ProcessStatus.Value = StatusText
End Sub
Private Sub ReLinkShape(ByRef Shp As PowerPoint.Shape, ByVal NewDestination As String)
Dim Link() As String
Dim link2() As String
If Shp.Type = msoLinkedOLEObject Then 'when we find a linked one
Link = Split(Shp.LinkFormat.SourceFullName, "!") 'update the link to point to the new clinic spreadsheet instead of the master
If InStr(1, Link(2), "]") > 0 Then
link2 = Split(Link(2), "]")
Link(2) = "[" & TempVars!ClinicName & ".xlsx]" & link2(1)
End If
Shp.LinkFormat.SourceFullName = NewDestination & "!" & Link(1) & "!" & Link(2)
End If
End Sub
Public Sub MySleep(ByRef Unit As Double, ByRef UOM As String)
Dim Pause As Date
Pause = DateAdd(UOM, Unit, Now())
While Now < Pause
DoEvents
Wend
End Sub