Code to create message/input box, for save via VBA to powerpoint

K

kanddo2

New Member
Joined
Aug 20, 2008
Messages
29
Hello,

I am stumped on an issue an amateur of hack at VBA. I have tried to find a solution on-line but have failed in every attempt. So I defer to the knowledge of this group to possibly help me.

I am trying to create a message box to prompts users to save an extracted PowerPoint file, using a standardized naming solution i would reference in the source excel file, similar to the way I have done in the code is use for excel output. I know how to do it when hard coded value files from excel to another excel. Code I use, that works well is below:

Code: 
         '       Input box to name new file
        NewName = InputBox("REQUIRED NAMING FORMAT:" & vbCr & _
        " " & vbCr & _
        "Name<name<client name=""> <id>_Number<number<sfdc#>_YYYY.MM.DD_v#_Mini CFO Briefing" & vbCr & _
        " " & vbCr & _
        "EX: GBR Inc_27sf7_2018.09.01_v2.0_Mini CFO Briefing" & vbCr & _
        " " & vbCr & _
        "Adjust Input Box as needed, based on Naming Requirements demonstrated above:", "New Copy", Range("Title_MiniCFOB").Value)
         
         '       Save it with the NewName and in the same directory as original
        fpath = ThisWorkbook.Path & "\"
        ActiveWorkbook.SaveAs Filename:=fpath & NewName & ".xlsb", FileFormat:=50
        ActiveWorkbook.Close SaveChanges:=False
         
        .ScreenUpdating = True
        
    MsgBox "Packet has been saved at current tool location. Please REVIEW before distribution."
I would like to do this same exercise with an extracted powerpoint file. The code I have up to that point is as follows. I can't for some reason figure out how to make the msg box function and then get the proper save:

Code: 
Sub PowerPt_VRB_CompactDash()


' PURPOSE: Create only Compact Review slide '


Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShapeRange As Object


If ActiveWorkbook.Name <> ThisWorkbook.Name Then End


'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")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0
  
'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate
    
'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add
  myPresentation.PageSetup.SlideSize = 2


'Add a slide to the Presentation '11 = ppLayoutTitleOnly
  Set mySlide = myPresentation.slides.Add(1, 11)


'Copy Excel Range
  Range("Review_1_Compact").Copy


'Paste to PowerPoint and position '2 = ppPasteEnhancedMetafile
  mySlide.Shapes.PasteSpecial DataType:=2
  Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
  
    'Set position: '1 = ppAlignLeft
      myShapeRange.Left = 35
      myShapeRange.Top = 75
      myShapeRange.ScaleHeight 1.05, msoFalse
      myShapeRange.ScaleWidth 1.3, msoFalse


      
      mySlide.Shapes.Title.TextFrame.TextRange.Characters.Text = "Compact Review Dashboard"
      mySlide.Shapes.Title.TextFrame.TextRange.Characters.Font.Name = "Arial"
      mySlide.Shapes.Title.TextFrame.TextRange.Characters.Font.Size = 22
      mySlide.Shapes.Title.TextFrame.TextRange.Characters.Font.Bold = True
      mySlide.Shapes.Title.ScaleHeight 0.3, msoFalse
      mySlide.Shapes.Title.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = 1
    
    'Clear The Clipboard
  Application.CutCopyMode = False

         '       Input box to name new file
        NewName = InputBox("REQUIRED NAMING FORMAT:" & vbCr & _
        " " & vbCr & _
        "<name<client name="">Name_Number<id><number<sfdc#>_YYYY.MM.DD_Compact_v#" & vbCr & _
        " " & vbCr & _
        "EX: GBR Inc_27sf7_2018.09.01_Compact_v2.0" & vbCr & _
        " " & vbCr & _
        "Adjust Input Box as needed, based on Naming Requirements demonstrated above:", "New Copy", Range("Title_CompactDash").Value)
         


         '       My every attempt to do this fails HERE



         '       Upon close, reminder message to user

    MsgBox "Packet has been saved at current tool location. Please REVIEW before distribution."


End Sub


Thank you in advance for any suggestions.

</number<sfdc#></id></name<client></number<sfdc#></id></name<client>
 
Last edited:

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
Sort by date Sort by votes
Re: Help with code to create message/input box, for save via VBA to powerpoint

Hi heres my suggestion... its not pretty but it may get you want you wanted:

using your code, I made some changes at the top and bottom - highlighted for you in red. it may or may not work for you!! Good luck! :eeek:

Code: 
Sub PowerPt_VRB_CompactDash()


' PURPOSE: Create only Compact Review slide '


[COLOR="#FF0000"]''''' ///////////////////////////////////////////////
''''' //// NEW CODE HERE

Dim newname, prompt As String
prompt = " Name_Number_YYYY.MM.DD_Compact_v#" & vbCr & _
        vbCr & " EX: GBR Inc_27sf7_2018.09.01_Compact_v2.0" & vbCr & _
        vbCr & " Adjust Input Box as needed, based on Naming Requirements demonstrated"
caption = "New Copy " & (Range("Title_CompactDash").Value)

    
newname = InputBox(prompt, caption)
'If they dont enter a name then they dont get a powerpoint file created as its exits the sub
'if we did this the other way around then we would have powerpoint presentations with no names
'just sat open
If newname = "" Then
MsgBox "Invalid name"
Exit Sub
Else
End If
''''' //// NEW CODE STOPS HERE
''''' ///////////////////////////////////////////////
[/COLOR]
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShapeRange As Object


If ActiveWorkbook.Name <> ThisWorkbook.Name Then End


'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")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0
  
'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate
    
'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add
  myPresentation.PageSetup.SlideSize = 2


'Add a slide to the Presentation '11 = ppLayoutTitleOnly
  Set mySlide = myPresentation.Slides.Add(1, 11)


'Copy Excel Range
  Range("Review_1_Compact").Copy


'Paste to PowerPoint and position '2 = ppPasteEnhancedMetafile
  mySlide.Shapes.PasteSpecial DataType:=2
  Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
  
    'Set position: '1 = ppAlignLeft
      myShapeRange.Left = 35
      myShapeRange.Top = 75
      myShapeRange.ScaleHeight 1.05, msoFalse
      myShapeRange.ScaleWidth 1.3, msoFalse


      
      mySlide.Shapes.Title.TextFrame.TextRange.Characters.Text = "Compact Review Dashboard"
      mySlide.Shapes.Title.TextFrame.TextRange.Characters.Font.Name = "Arial"
      mySlide.Shapes.Title.TextFrame.TextRange.Characters.Font.Size = 22
      mySlide.Shapes.Title.TextFrame.TextRange.Characters.Font.Bold = True
      mySlide.Shapes.Title.ScaleHeight 0.3, msoFalse
      mySlide.Shapes.Title.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = 1
    
    'Clear The Clipboard
  Application.CutCopyMode = False


[COLOR="#FF0000"]''''' ///////////////////////////////////////////////
''''' //// NEW CODE HERE
    
Filename = "C:\testuser\Desktop\" & newname & ".pptx" ' hardcoded saveas using the newname previously asked for.  can also set the fileformat here
PowerPointApp.activepresentation.SaveAs Filename

         '       Upon close, reminder message to user

   ActiveWorkbook.Activate 'attempting to bring excel forward...not working!
''''' //// NEW CODE STOPS HERE
''''' ///////////////////////////////////////////////[/COLOR]
   

    MsgBox "Packet has been saved at current tool location. Please REVIEW before distribution."


End Sub
 
Upvote 0
Re: Help with code to create message/input box, for save via VBA to powerpoint

Thank you very much bugmosta !!! You were right that it wasn't quite what I was thinking of, but it prompted me into what I really wanted to get done. And I really liked your idea to move the input box forward in the process. The double message box upfront may be more than needed, but sometimes you can't be too descriptive when not present to resolve items.

Your help popped the wall I was hitting. It was like writer's block, and your code pushed me in the right path.
I took what you gave me and then modified it to meet what I needed. Very much appreciated.
I did want the powerpoint to sit open once created so the user could review, but wanted it saved at the location of their file, and then they could modify if needed, then save/close when done.
This may keep the active powerpoint up front, and excel workbook in the background, but after testing it several times, it ended up being what we needed to force the user into reviewing it before closing.

I pasted my final coding below so you could see it. Red is what i did differently in my attempt after your response. It works wonderfully now.

AGAIN, VERY MUCH APPRECIATE YOUR RESPONSE!!!

\m/, (*o*) ,\m/


Rich (BB code): 
Sub PowerPt_Review1_CompactDash()


' PURPOSE: Create only Review1_Compact slide '

-----------------------------------------------------
Dim NewName As String
Dim fpath As String
Dim nm As Name


    ' Msg Box Prompt to create new slide
    If MsgBox("Create Compact Dashboard Slide? " & vbCr & _
    " " & vbCr & _
    "(May Require 1-2 Minutes to complete - Remain Patient)" & vbCr & _
    " " & vbCr & _
    "New Compact Dash will be Saved in Same Location as Your Current Model." & vbCr & _
    "New Sheets will be pasted as objects. All formulas/links Removed." _
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub


    ' Input box to name new file
    NewName = InputBox("REQUIRED NAMING FORMAT:" & vbCr & _
    " " & vbCr & _
    "Name_Number_YYYY.MM.DD_v#_CompactDash" & vbCr & _
    " " & vbCr & _
    "EX: GBR Inc_27sf7_2018.09.01_v2.0_ CompactDash " & vbCr & _
    " " & vbCr & _
    "Adjust Input Box as needed, based on Naming Requirements demonstrated above:", "New Copy", Range("Title_CompactDash").Value)
    If NewName = vbNullString Then Exit Sub
-------------------------------------------------------


Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShapeRange As Object


If ActiveWorkbook.Name <> ThisWorkbook.Name Then End


'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")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0
  
'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate
    
'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add
  myPresentation.PageSetup.SlideSize = 2


'Add a slide to the Presentation '11 = ppLayoutTitleOnly
  Set mySlide = myPresentation.slides.Add(1, 11)


'Copy Excel Range
  Range("Review_1_Compact").Copy


'Paste to PowerPoint and position '2 = ppPasteEnhancedMetafile
  mySlide.Shapes.PasteSpecial DataType:=2
  Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
  
    'Set position: '1 = ppAlignLeft
      myShapeRange.Left = 35
      myShapeRange.Top = 75
      myShapeRange.ScaleHeight 1.05, msoFalse
      myShapeRange.ScaleWidth 1.3, msoFalse


      
      mySlide.Shapes.Title.TextFrame.TextRange.Characters.Text = "Compact Review Dashboard"
      mySlide.Shapes.Title.TextFrame.TextRange.Characters.Font.Name = "Arial"
      mySlide.Shapes.Title.TextFrame.TextRange.Characters.Font.Size = 22
      mySlide.Shapes.Title.TextFrame.TextRange.Characters.Font.Bold = True
      mySlide.Shapes.Title.ScaleHeight 0.3, msoFalse
      mySlide.Shapes.Title.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = 1
    
    'Clear The Clipboard
  Application.CutCopyMode = False


--------------------------------------------------
    'Save it with the NewName and in the same directory as original Excel file
    fpath = ThisWorkbook.Path & "\"
    PowerPointApp.activepresentation.SaveAs Filename:=fpath & NewName & ".pptx"
--------------------------------------------------



    'Prompt user that file was generated in active Excel file
    MsgBox "Compact Dash PowerPoint Slide of the model has been generated. " & vbCr & _
    "Slide may require resizing due to source file formatting. " & vbCr & _
    "Please review/adjust slide for fit, before distribution.", vbOKOnly


End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question Question
VBA to update Powerpoint Text from Excel Data in Cells
Replies
9
Views
978
tbakbradley
T
C
  • Question Question
Replacing PowerPoint Input using Find and Replace Arrays from Excel through VBA
Replies
0
Views
2K
ckcs
C
N
  • Question Question
Automating textbox updates in PP using VBA to read excel data
Replies
0
Views
908
noobslayer252
N
S
  • Question Question
VBA code for Excel tables into ppt - automation
Replies
3
Views
3K
Trebor76
T
E
  • Solved
Need to Export Excel sheet range to Multiple Powerpoint Slides
2
Replies
13
Views
4K
sijpie
sijpie

Forum statistics

Threads
1,223,894
Messages
6,175,252
Members
452,623
Latest member
Techenthusiast

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top