I am wanting to open an existing PowerPoint template and select slide 3 and copy a table from my spreadsheet to the PowerPoint slide.
Please can someone show me how to do this?
Sub Open_PowerPoint_Presentation()
'Opens a PowerPoint Document from Excel
Dim objPPT As Object
Dim PPSlide As Object
Set objPPT = CreateObject("PowerPoint.Application")
Set PPSlide = objPPT.Slides(5)
objPPT.Visible = True
'Change the directory path and file name to the location
'of your document
objPPT.Presentations.Open "\\MI-FILESERVE1\Shared Folders\Shared_Business_Dev\assets\Tender Time Allocation Deck.pptx"
PPSlide.Select
End Sub
Be CAREFUL : You cannot paste in the Shapes of your Slide if the collection is empty
I.E. : you'll need a slide with at least a title or a shape (square, triangle, ...) to be able to paste what you have copied in your clipboard.
Here are the basics, you should correct the excel lines to copy what you want :
Sub Open_PowerPoint_Presentation()
Dim objPPT As Object, _
PPTPrez As PowerPoint.Presentation, _
pSlide As PowerPoint.Slide
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Set PPTPrez = objPPT.Presentations.Open("\\MI-FILESERVE1\Shared Folders\Shared_Business_Dev\assets\Tender Time Allocation Deck.pptx")
Set pSlide = PPTPrez.Slides(5)
If pSlide.Shapes.Count <> 0 Then
'Table
ActiveWorkbook.Sheets("Sheet1").Range("Named Range").Copy
pSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'OR
ActiveWorkbook.Sheets("Sheet1").Range("Named Range").CopyPicture
pSlide.Shapes.Paste
'Charts
ActiveWorkbook.Sheets("Graph1").ActiveChart.ChartArea.Copy
pSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'OR
ActiveWorkbook.Sheets("Graph1").ActiveChart.ChartArea.CopyPicture
pSlide.Shapes.Paste
Else
MsgBox "There is no shape in this Slide (" & pSlide.SlideIndex & ")." & vbCrLf & "Please use a slide with at least one shape, not a blank slide", vbCritical + vbOKOnly
End If
End Sub
Related
I was trying to use VBA to open another PPT and copy the 2 pages in it to the end of my current ppt.
I used Presentation.Open to open the ppt, however, it gave me an error at this line: Presentations.Open (ppt_SourceFile): Run-time error '-2147467259(80004005)': Method 'Open' of object 'Presentations' failed.
Can anyone please help me understand what was wrong?
Thank you in advance!!!
Sub copyFromPPT()
Dim slideCount As Integer
Dim sourcePath as string, ppt_SourceFile As String, pptSource As String, thisPresentation As String
'Copy and paste the pages at the end
thisPresentation = ActivePresentation.Name
slideCount = ActivePresentation.Slides.Count
'Open ppt file
sourcePath = ActivePresentation.Path
ppt_SourceFile = sourcePath & "\CFTC Reg Reporting*.pptx"
Presentations.Open (ppt_SourceFile)
pptSource = ActivePresentation.Name
'Copy the 1st slide of source ppt to end of this slide
ActivePresentation.Slides(1).Copy
Presentations(thisPresentation).Slides.paste
slideCount = ActivePresentation.Slides.Count
'Copy the 2nd slide of source ppt to end of this slide
Presentations(pptSource).Slides(2).Copy
Presentations(thisPresentation).Slides.paste
'Close source ppt file
Presentations(pptSource).Close
ActivePresentation.Save
End Sub
If there's only one matching file in the folder you can do something like this:
Sub copyFromPPT()
Dim thisPres As Presentation, sourcePres As Presentation, f
Dim sourcePath As String
Set thisPres = ActivePresentation
sourcePath = thisPres.Path & "\"
f = Dir(sourcePath & "CFTC Reg Reporting*.pptx") 'see if there's a file...
If Len(f) = 0 Then
MsgBox "No matching file found", vbExclamation
Exit Sub
End If
Set sourcePres = Presentations.Open(sourcePath & f) 'Open ppt file and get a reference
sourcePres.Slides(1).Copy
thisPres.Slides.Paste 'you can add a paste position here, or leave blank to paste to the end...
sourcePres.Slides(2).Copy
thisPres.Slides.Paste
sourcePres.Close
thisPres.Save
End Sub
I am building a report where users will take tables from Excel and paste them into a PowerPoint. Since I won't know what the users will name the PowerPoint, I am giving them two options. If the one they want is not open, they will open it. What I am having trouble is if the one they want is already open, how can I have them select it? This is what I have so far:
Dim ans As Integer
Dim pptName As String
Dim ppt As PowerPoint.Application
Dim myPres As PowerPoint.Presentation
Dim arr() As String
Dim j As Variant
ans = MsgBox("Is the PowerPoint already open?", vbYesNo + vbQuestion)
If ans = vbYes Then
For Each myPres in ppt.Presentations
Redim Preserve arr(j)
arr(j) = myPres.Name
j = j + 1
Next
'How to use the names of all the current ppts in the array and let a user select which one from that list
Set myPres = ppt.Presentations(1)
Else
MsgBox ("Please choose PowerPoint to open.")
'openDialog is a function I have already created
pptName = openDialog()
Set myPres = ppt.Presentations.Open(pptName)
End If
Any suggestions would be greatly appreciated!
It's a little long, But I've included the code in the regular Module, and also the User_Form.
Code Module
Option Explicit
Public PPTFileName As String '<-- defined as Public, will get it from the User_Form's ListBox
Sub SelectPPTPresentation()
' === this loop through all open PowerPoint Presentations is using Late Binding
' === to avoid future problems when working with multiple Office Versions
Dim ppApp As Object
Dim ppPres As Object
Dim ObjPres As Object
If MsgBox("Is the PowerPoint already open?", vbYesNo + vbQuestion) = vbYes Then
On Error Resume Next
Set ppApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If ppApp Is Nothing Then
MsgBox "No PowerPoint is open!"
Else
If ppApp.Presentations.Count > 0 Then ' check that at least 1 Presentation is open
For Each ObjPres In ppApp.Presentations ' loop through all open presnetations (
UserForm1.OpenPPPres_LB.AddItem ObjPres.FullName '<-- add their full names to the User_Form ListBox
Next ObjPres
End If
End If
UserForm1.Show '<-- show the User_Form with the ListBox of all open PPT presentations
' loop through all open presnetations (check Full Name: Path and name)
For Each ObjPres In ppApp.Presentations
If StrComp(ObjPres.FullName, PPTFileName, vbTextCompare) = 0 Then
Set ppPres = ObjPres ' <-- set the current PPT pres to the selected Item from the ListBox
Exit For
End If
Next ObjPres
MsgBox "Selected Presentation is " & ppPres.Name ' <-- just for confirmation >> show Name (without Path)
Else ' <-- you will need to modify this section to fit the upper section
' MsgBox ("Please choose PowerPoint to open.")
' 'openDialog is a function I have already created
' pptName = openDialog()
' Set myPres = ppt.Presentations.Open(pptName)
'
End If
End Sub
User_Form Code the event is under the "OpenPPPres_LB" ListBox DblClick event:
Private Sub OpenPPPres_LB_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim i As Long
For i = 0 To OpenPPPres_LB.ListCount - 1
If OpenPPPres_LB.Selected(i) Then
PPTFileName = OpenPPPres_LB.List(i) ' <-- save the PPT filename
Exit For
End If
Next i
Unload UserForm1
End Sub
Screen-shot of the User_Form populated with the current Open Presentations:
I would like this particular code to be run on multiple powerpoint files in a folder. But it would be even better if it would open the powerpoint file, run this code below, save it and then open the next one. Any suggestions are welcome! I have been through code on this website, but can't seem to adapt it to my code below (e.g. this one Loop through files in a folder using VBA?)
LOOPING ATTEMPT
flag
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("c:\testfolder\")
While (file <> "")
If InStr(file, "test") > 0 Then
MsgBox "found " & file
Exit Sub
End If
file = Dir
Wend
End Sub
Existing Code
Option Explicit
' Selects the shape that support text which is closest to the top of the slide
' Written by Jamie Garroch of YOUpresent Ltd (http://youpresent.co.uk)
Sub SelectHigestTextShape()
Dim oSld As Slide
Dim oShp As Shape, oShpTop As Shape
Dim sShpTop As Single
On Error Resume Next
Set oSld = ActiveWindow.View.Slide
If Err Then Exit Sub
On Error GoTo 0
' Set the top to the bottom of the slide
sShpTop = ActivePresentation.PageSetup.SlideHeight
' Check each shape on the slide is positioned above the stored position
' Shapes not supporting text and placeholders are ignored
For Each oShp In oSld.Shapes
If oShp.Top < sShpTop And oShp.HasTextFrame And Not oShp.Type = msoPlaceholder Then
sShpTop = oShp.Top
Set oShpTop = oShp
End If
Next
' Select the topmost shape
If Not oShpTop Is Nothing Then oShpTop.Select msoTrue
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
' Clean up
Set oSld = Nothing
Set oShp = Nothing
Set oShpTop = Nothing
End Sub
That's my code sample for the SelectHigestTextShape sub but I'm not sure it'll work the way you want for multiple files. The reason is that it was designed to SELECT a textbox object within the ACTIVE PRESENTATION using the ACTIVE VIEW. None of this exists when you loop through files in a folder as you'd need to open each one in turn but even then, what would be the point of selecting a shape only to close the presentation afterwards? I guess we really need to know the end goal. In the type of batch processing you're attempting, it would not be a good idea to select anything at all as that requires the object's view to be active which is a debugging nightmare and slows everything down a lot. If you want to do something with a particular object, it's much better to use a reference to it without requiring an active view or even an active window (you could open each file invisibly, process it and then close it).
This example will loop through a folder, open each presentation it finds (without a window), loop through all shapes on all slides, output a count of slides and shapes to the immediate pane, and then close the file:
' Loop through all PowerPoint files in a specified folder
' Open each and then loop through each shape of each slide
' Output a count of slides and shapes in immediate pane before closing the file
' Modified by Jamie Garroch of YOUpresent Ltd (http://youpresent.co.uk)
Sub LoopThroughPPTFiles()
Dim oPres As Presentation, oSld As Slide, oShp As Shape
Dim SldCount As Long, ShpCount As Long
Dim MyFile As String
Const MyFolder = "c:\testfolder\"
On Error GoTo errorhandler
MyFile = Dir(MyFolder)
While (MyFile <> "")
If Right(MyFile, 5) Like ".ppt*" Then
Set oPres = Presentations.Open(FileName:=MyFolder & MyFile, ReadOnly:=msoTrue, Untitled:=msoFalse, WithWindow:=msoFalse)
For Each oSld In oPres.Slides
SldCount = SldCount + 1
For Each oShp In oSld.Shapes
ShpCount = ShpCount + 1
Next
Next
Debug.Print oPres.Name & " has " & SldCount & " slide(s) and " & ShpCount & " shapes."
SldCount = 0: ShpCount = 0
oPres.Close
End If
MyFile = Dir
Wend
' clean up
Set oPres = Nothing: Set oSld = Nothing: Set oShp = Nothing
Exit Sub
errorhandler:
If Not oPres Is Nothing Then oPres.Close: Set oPres = Nothing
End Sub
You could use this to then examine the shapes after the "For Each oShp In oSld.Shapes" line to find the one positioned highest on the slide and then process it (without selecting it).
I am trying to write a macro to find and copy all the graphs/images inline in a word document and paste them into individual slides in a new powerpoint. However when I run into multiple runtime errors. Here's the entire code.
Sub wordtoppt()
'This macro copies all pictures out of a word document of your choice and into a new powerpoint presentation.
'Two reference libraries need to be open - Word and Powerpoint. Go Tools > References, and tick the relevant box.
Dim wdApp As Word.Application 'Set up word and powerpoint objects
Dim wdDoc As Word.Document
Dim pptApp As PowerPoint.Application
Dim pptShw As PowerPoint.Presentation
Dim pptChart As PowerPoint.Shape
Dim pptSld As PowerPoint.Slide
On Error GoTo 0
Dim wcount As Integer 'Number of open word documents
Dim doclist() As String 'Collects the names of open word documents
Dim desc As String 'inputbox text
Dim chosendoc As Integer 'stores the index number of your selected word document
Dim ccount As Integer 'number of shapes in the word document
Dim wellpasted As Integer 'Counts the number of shapes that have successfully been pasted into powerpoint.
Application.ScreenUpdating = False
'Establishes link with word.
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
On Error GoTo 0
If wdApp Is Nothing Then 'Error message if Word is not open
MsgBox "Error: Word is not open." & Chr(10) & Chr(10) & "Is word actually open? This is a bug."
Exit Sub
End If
'Counts the number of word documents open
wcount = CInt(wdApp.Documents.Count)
ReDim doclist(wcount) 'resizes string array of word documents
If wcount = 0 Then 'Error message if Word is open, but there are no documents open
MsgBox "There are no word documents open!" & Chr(10) & "Open a word document and try again"
Exit Sub
End If
'text for input box
desc = "Which document would you like to extract the graphs from?" & Chr(10) & Chr(10) & "Type the number in the box (one number only)." & Chr(10) & Chr(10)
'input boxes for selection of word document
If wcount = 1 Then 'if only one document open
myinput = MsgBox("Do you want to paste graphs from " & wdApp.Documents(1).Name & "?", vbYesNo, "From Release Note to Powerpoint")
If myinput = vbYes Then
chosendoc = 1
Else
Exit Sub
End If
Else
For i = 1 To wcount 'multiple documents open
doclist(i) = wdApp.Documents(i).Name
desc = desc & i & ": " & doclist(i) & Chr(10)
Next
myinput = InputBox(desc, "From Release Note to Powerpoint")
If IsNumeric(myinput) And myinput <= wcount Then 'Error handling - if cancel is clicked, or anything other than a number is typed into the input box.
chosendoc = CInt(myinput)
Else
If myinput = "" Then 'clicking cancel, or leaving input box blank
MsgBox "You didn't enter anything!"
Exit Sub
Else 'if you type a short novel
MsgBox "You didn't enter a valid number!" & Chr(10) & "(Your response was " & myinput & ")"
Exit Sub
End If
End If
End If
'Error handling, for chart-free word documents.
If wdApp.Documents(chosendoc).InlineShapes.Count = 0 Then
MsgBox "There are no charts in this Word Document!"
Exit Sub
End If
'Opens a new powerpoint presentation
Set pptApp = CreateObject("PowerPoint.Application")
Set pptShw = pptApp.Presentations.Add
'PowerPoint.Application
'Sets up slide dimensions
Dim sldwidth As Integer
Dim sldheight As Integer
sldwidth = pptShw.PageSetup.SlideWidth
sldheight = pptShw.PageSetup.SlideHeight
wellpasted = 0
Dim shapecount As Integer 'Number of shapes in the word document
shapecount = wdApp.Documents(chosendoc).InlineShapes.Count
For j = 1 To shapecount 'Adds in the correct number of slides into the powerpoint presentation
Set pptSld = pptShw.Slides.Add(pptShw.Slides.Count + 1, ppLayoutBlank)
Next
For j = 1 To shapecount 'loops through all shapes in the document
On Error GoTo Skiptheloop 'sometimes some objects don't paste. This is a way to skip over them.
'Application.Wait Now + (1 / 86400)
wdApp.Documents(chosendoc).InlineShapes(j).Range.Copy 'copies chart
Set pptSld = pptShw.Slides(j)
pptSld.Shapes.Paste 'pastes chart
'Application.CutCopyMode = False
With pptSld.Shapes(1) 'resizes and aligns shapes
.LockAspectRatio = msoTrue 'Currently sets charts to the height of the slide. Alternatively can scale to 100%
.Height = sldheight
.Left = (sldwidth / 2) - (.Width / 2)
.Top = (sldheight / 2) - (.Height / 2)
End With
wellpasted = wellpasted + 1 'if the chart was pasted successfully, increment by 1.
Skiptheloop:
Next
On Error GoTo 0
If (shapecount - wellpasted) <> 0 Then 'produces a message box if some shapes did not paste successfully.
MsgBox CStr(shapecount - wellpasted) & " (of " & CStr(shapecount) & ") shapes were not pasted. Best that you check all the graphs are in."
End If
Application.ScreenUpdating = True
pptApp.Activate 'brings powerpoint to the front of the screen
Exit Sub
End Sub
On the line pptSld.shapes.paste I get the error clipboard empty or cannot paste.
Any ideas?
I am using Simple solution for my job devided in two pars
1) Extract all images from word file
This can be done in two ways.
a. save as html which will create the folder filenam_files which will hold all the images in .png formate. There may be duplicate images in diff formate but .png will be unique.
b. change filename of word from file.docx to file.docx.zip
You can get the images at file.docx\word\media
There will be no duplicate images in this method.
2) Import all images in powerpoint.
1)
As you have already opened the document manually you can do one more step manually or record macro which will look like this.
Sub exportimages()
ChangeFileOpenDirectory "D:\temp\"
ActiveDocument.SaveAs2 FileName:="data.html", FileFormat:=wdFormatHTML, _
LockComments:=False, passWord:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, CompatibilityMode:=0
End Sub
2)
Close the word document.
Open Power point and paste this
Sub ImportABunch()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
strPath = "D:\temp\data_files\"
strFileSpec = "*.png" 'if you are using mehtod **a.** to extract the images.
'strFileSpec = "*.*" 'if you are using mehtod **b.** to extract the images.
strTemp = Dir(strPath & strFileSpec)
Do While strTemp <> ""
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0, _
Width:=-1, _
Height:=-1)
strTemp = Dir
Loop
End Sub
You can write vbscript to combine this two steps together. I have no idea how to do that. You can google it.
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