Solved

make this work with active workbook

Posted on 2011-09-13
23
306 Views
Last Modified: 2012-05-12
So I have had a lot of help with this and I still just can not seem to get it to work.  I want to make this code work for the active workbook so you do not even have to enter the file path that is currently being entered into row B.  I thought for the strwbk I could just change it to activeworkbook.fullname but that did not work.  I am just a rookie and any help would be great.  the end goal is to move the macro into the workbook  and not have to reference the path.  
Sub UpdatePPT()

   Dim oPPTApp As PowerPoint.Application
   Dim oPPTShape As PowerPoint.Shape
   Dim rngNewRange As Excel.Range, strSlideNum As String
   Dim oSheet As Object, shShape As Object, nmName As Name
   Dim lngRow As Long, shtRef As Worksheet, strLeaveOpen As String, strPrevWbk As String, _
        blPrevWbkXist As Boolean
   Dim strWbk As String, strRange As String, intSlideNum As Integer, _
        intWidth As Integer, intTop As Integer, intLeft As Integer, _
        intHeight As Integer, strWbkName As String, strError As String
'
' Set oPPTApp to PowerPoint by creating a new instance of PowerPoint.
' If PowerPoint is already open, you would instead use the GetObject
' method instead.

    Set shtRef = Application.ActiveWorkbook.ActiveSheet
    
    Set oPPTApp = CreateObject("PowerPoint.Application")

' Set PowerPoint to be Visible.
'
   oPPTApp.Visible = msoTrue
'
' Open Presentation
'
   oPPTApp.Presentations.Open Range("PPT_Path").Value

'Loop through all Range lines
    For lngRow = Range("FirstWbk").Row To Range("XL_Path").Row - 1
          
        If shtRef.Cells(lngRow, 9).Value = "no" Then GoTo endLoop1
          
        With shtRef
            strWbk = .Cells(lngRow, 2).Value
            strRange = .Cells(lngRow, 3).Value
            intTop = .Cells(lngRow, 4).Value
            intLeft = .Cells(lngRow, 5).Value
            intWidth = .Cells(lngRow, 6).Value
            intHeight = .Cells(lngRow, 7).Value
            intSlideNum = .Cells(lngRow, 8).Value
        End With
        
'check if the workbook is open, and if not if it exists
    
        If strWbk = strPrevWbk Then
            If blPrevWbkXist = False Then GoTo endLoop1
        Else
            If blPrevWbkXist = True And strLeaveOpen = "False" Then _
                Application.Workbooks(FunctionGetFileName(strPrevWbk)).Close (False)
        
            strLeaveOpen = CheckOpenExistWorkbook(strWbk)
    
            strPrevWbk = strWbk
        
            If strLeaveOpen = "No Exist" Then
                MsgBox ("The workbook " & strWbk & " does not exist. Please check.")
                blPrevWbkXist = False
                GoTo endLoop1
            End If
        End If
        
        blPrevWbkXist = True
        
        strWbkName = FunctionGetFileName(strWbk)
            
        'transfer to Powerpoint
        strError = strError & CopyRangeToPPT(oPPTApp, intSlideNum, intLeft, intWidth, intHeight, intTop, strWbkName, strRange)

endLoop1:
    Next

If strLeaveOpen = "False" Then _
    Application.Workbooks(FunctionGetFileName(strPrevWbk)).Close (False)

oPPTApp.Activate
'oPPTApp.ActivePresentation.SaveAs (Range("Save_Path").Text)

Set oPPTApp = Nothing

'MsgBox (strError)

End Sub
            
Sub GetPPTPath()
    Range("PPT_Path").Value = Application.GetOpenFilename
End Sub
            
Sub GetXLPath()
    Range("XL_Path").Value = Application.GetOpenFilename
End Sub

Sub callfunction()

Call CheckOpenExistWorkbook("test")

End Sub

Function CheckOpenExistWorkbook(strWbk As String) As String
Dim wbkLoop As Workbook, blOpen As Boolean
    
    blOpen = False
    
    For Each wbkLoop In Application.Workbooks
        If UCase(strWbk) = UCase(wbkLoop.Path & "\" & wbkLoop.Name) Then blOpen = True
    Next

    If blOpen = True Then
        CheckOpenExistWorkbook = "True"
        Exit Function
    End If
    
    On Error Resume Next
    AppActivate ("Microsoft excel")
    Workbooks.Open Filename:=strWbk, UpdateLinks:=xlUpdateLinksUserSetting, ReadOnly:=False
        
        If Err.Number = 1004 Then 'workbook does not exist
            CheckOpenExistWorkbook = "No Exist"
            Err.Clear
            Exit Function
        End If
        
    CheckOpenExistWorkbook = "False"
   
End Function
            
Function CopyRangeToPPT(oPPTApp As PowerPoint.Application, intSlideNum As Integer, intLeft As Integer, intWidth As Integer, intHeight As Integer, intTop As Integer, strWbkName As String, strRange As String) As String
   Dim shShape As Object, strError As String

    'delete shape if it exists on slide
        On Error Resume Next
        oPPTApp.ActivePresentation.Slides("Slide_" & strRange).Shapes("ExcelSlide_" & strRange).Delete
        If Err.Number <> 0 Then CopyRangeToPPT = Err.Number & " " & Err.Description & ": " & strRange & vbCrLf
        Err.Clear
' Select the range then copy it.
    
    Workbooks(strWbkName).Activate
    Range(strRange).CopyPicture Appearance:=xlScreen, _
        Format:=xlPicture
        Debug.Print Err.Description

    ' Paste the range
    Set shShape = oPPTApp.ActivePresentation.Slides(intSlideNum).Shapes.PasteSpecial(ppPasteEnhancedMetafile)
    
    ' Align the pasted range
    With shShape
        .Left = intLeft
        .Top = intTop
        .Width = intWidh
        .Height = intHeight
        .Name = "ExcelSlide_" & strRange
    End With
End Function

Function FunctionGetFileName(FullPath As String)
Dim StrFind As String
    Do Until Left(StrFind, 1) = "\"
        iCount = iCount + 1
        StrFind = Right(FullPath, iCount)
            If iCount = Len(FullPath) Then Exit Do
    Loop
    
    FunctionGetFileName = Right(StrFind, Len(StrFind) - 1)
    
End Function

Open in new window

Transfer-XL-to-PPT-V2.xlsm
0
Comment
Question by:montrof
  • 12
  • 7
  • 4
23 Comments
 
LVL 45

Expert Comment

by:aikimark
Comment Utility
Full path of active workbook:
ActiveWorkbook.Path & "\" & ActiveWorkbook.Name

Open in new window


Just the path:
ActiveWorkbook.Path

Open in new window

0
 
LVL 1

Author Comment

by:montrof
Comment Utility
So do you think that is the only change I would need to make to have it work inside the workbook.
0
 
LVL 45

Expert Comment

by:aikimark
Comment Utility
That bit of code supplies the current path to the active workbook.  The path does not include a trailing backslash.  I assume you can replace your user prompt with this data.  If it doesn't work, please post the updated code and any problems/errors.
0
 
LVL 1

Author Comment

by:montrof
Comment Utility
Ok it seems to fail when it goes into the Function CopyRangeToPPT. error user defined type not defined.
0
 
LVL 1

Author Comment

by:montrof
Comment Utility
code
Sub UpdatePPT()

   Dim oPPTApp As PowerPoint.Application
   Dim oPPTShape As PowerPoint.Shape
   Dim rngNewRange As Excel.Range, strSlideNum As String
   Dim oSheet As Object, shShape As Object, nmName As Name
   Dim lngRow As Long, shtRef As Worksheet, strLeaveOpen As String, strPrevWbk As String, _
        blPrevWbkXist As Boolean
   Dim strWbk As String, strRange As String, intSlideNum As Integer, _
        intWidth As Integer, intTop As Integer, intLeft As Integer, _
        intHeight As Integer, strWbkName As String, strError As String
'
' Set oPPTApp to PowerPoint by creating a new instance of PowerPoint.
' If PowerPoint is already open, you would instead use the GetObject
' method instead.

    Set shtRef = Application.ActiveWorkbook.ActiveSheet
    
    Set oPPTApp = CreateObject("PowerPoint.Application")

' Set PowerPoint to be Visible.
'
   oPPTApp.Visible = msoTrue
'
' Open Presentation
'
   oPPTApp.Presentations.Open Range("PPT_Path").Value

'Loop through all Range lines
    For lngRow = Range("FirstWbk").Row To Range("XL_Path").Row - 1
          
        If shtRef.Cells(lngRow, 9).Value = "no" Then GoTo endLoop1
          
        With shtRef
            strWbk = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
            strRange = .Cells(lngRow, 3).Value
            intTop = .Cells(lngRow, 4).Value
            intLeft = .Cells(lngRow, 5).Value
            intWidth = .Cells(lngRow, 6).Value
            intHeight = .Cells(lngRow, 7).Value
            intSlideNum = .Cells(lngRow, 8).Value
        End With
        
'check if the workbook is open, and if not if it exists
    
        If strWbk = strPrevWbk Then
            If blPrevWbkXist = False Then GoTo endLoop1
        Else
            If blPrevWbkXist = True And strLeaveOpen = "False" Then _
                Application.Workbooks(FunctionGetFileName(strPrevWbk)).Close (False)
        
            strLeaveOpen = CheckOpenExistWorkbook(strWbk)
    
            strPrevWbk = strWbk
        
            If strLeaveOpen = "No Exist" Then
                MsgBox ("The workbook " & strWbk & " does not exist. Please check.")
                blPrevWbkXist = False
                GoTo endLoop1
            End If
        End If
        
        blPrevWbkXist = True
        
        strWbkName = FunctionGetFileName(strWbk)
            
        'transfer to Powerpoint
        strError = strError & CopyRangeToPPT(oPPTApp, intSlideNum, intLeft, intWidth, intHeight, intTop, strWbkName, strRange)

endLoop1:
    Next

If strLeaveOpen = "False" Then _
    Application.Workbooks(FunctionGetFileName(strPrevWbk)).Close (False)

oPPTApp.Activate
'oPPTApp.ActivePresentation.SaveAs (Range("Save_Path").Text)

Set oPPTApp = Nothing

'MsgBox (strError)

End Sub
            
Sub GetPPTPath()
    Range("PPT_Path").Value = Application.GetOpenFilename
End Sub
            
Sub GetXLPath()
    Range("XL_Path").Value = Application.GetOpenFilename
End Sub

Sub callfunction()

Call CheckOpenExistWorkbook("test")

End Sub

Function CheckOpenExistWorkbook(strWbk As String) As String
Dim wbkLoop As Workbook, blOpen As Boolean
    
    blOpen = False
    
    For Each wbkLoop In Application.Workbooks
        If UCase(strWbk) = UCase(wbkLoop.Path & "\" & wbkLoop.Name) Then blOpen = True
    Next

    If blOpen = True Then
        CheckOpenExistWorkbook = "True"
        Exit Function
    End If
    
    On Error Resume Next
    AppActivate ("Microsoft excel")
    Workbooks.Open Filename:=strWbk, UpdateLinks:=xlUpdateLinksUserSetting, ReadOnly:=False
        
        If Err.Number = 1004 Then 'workbook does not exist
            CheckOpenExistWorkbook = "No Exist"
            Err.Clear
            Exit Function
        End If
        
    CheckOpenExistWorkbook = "False"
   
End Function
            
Function CopyRangeToPPT(oPPTApp As PowerPoint.Application, intSlideNum As Integer, intLeft As Integer, intWidth As Integer, intHeight As Integer, intTop As Integer, strWbkName As String, strRange As String) As String
   Dim shShape As Object, strError As String

    'delete shape if it exists on slide
        On Error Resume Next
        oPPTApp.ActivePresentation.Slides("Slide_" & strRange).Shapes("ExcelSlide_" & strRange).Delete
        If Err.Number <> 0 Then CopyRangeToPPT = Err.Number & " " & Err.Description & ": " & strRange & vbCrLf
        Err.Clear
' Select the range then copy it.
    
    Workbooks(strWbkName).Activate
    Range(strRange).CopyPicture Appearance:=xlScreen, _
        Format:=xlPicture
        Debug.Print Err.Description

    ' Paste the range
    Set shShape = oPPTApp.ActivePresentation.Slides(intSlideNum).Shapes.PasteSpecial(ppPasteEnhancedMetafile)
    
    ' Align the pasted range
    With shShape
        .Left = intLeft
        .Top = intTop
        .Width = intWidh
        .Height = intHeight
        .Name = "ExcelSlide_" & strRange
    End With
End Function

Function FunctionGetFileName(FullPath As String)
Dim StrFind As String
    Do Until Left(StrFind, 1) = "\"
        iCount = iCount + 1
        StrFind = Right(FullPath, iCount)
            If iCount = Len(FullPath) Then Exit Do
    Loop
    
    FunctionGetFileName = Right(StrFind, Len(StrFind) - 1)
    
End Function

Open in new window

0
 
LVL 45

Expert Comment

by:aikimark
Comment Utility
please explain what you are doing with strWbk and strWbkName variables.

At line 68, what are the values of these two variables?
(before invoking the CopyRangeToPPT function)
0
 
LVL 1

Author Comment

by:montrof
Comment Utility
All I am trying to do is take this macro and incorporate into an exsisting workbook so the user will no longer have to select the excel file because it would be the open file.  So I would copy the the control sheet to a new workbook and insert the macro into the file. That way it just runs within the file that it is copying the images from to excel.
0
 
LVL 45

Expert Comment

by:aikimark
Comment Utility
>>...and insert the macro into the file

Why are you doing that? (or trying to)

Generally, you would run this code in a workbook and it would open other workbooks and powerpoint files as needed.
0
 
LVL 1

Author Comment

by:montrof
Comment Utility
the file that I have attached is accessing another excel workbook that has all the images in it.  So I want to allow the user to run the macro from that workbook.  Currently you have to open the attached excel file and run the macro and select the excel file that you are using to move the graphs too.  I would still open the ppt.
0
 
LVL 45

Expert Comment

by:aikimark
Comment Utility
the file that I have attached is accessing another excel workbook that has all the images in it.


What is the relationship between the workbook with the code, the workbook with the images, and the ppt file?

So I want to allow the user to run the macro from that workbook.  

To what file do you refer when you wrote "that workbook"?

Currently you have to open the attached excel file and run the macro and select the excel file that you are using to move the graphs too.

We should be able to solve this problem once we understand the relationship (relative directory placement) of the workbooks.

I[t] would still open the ppt.
Is there just a single PPT file?
Will all images go into the same PPT?
0
 
LVL 1

Author Comment

by:montrof
Comment Utility
Ok The attached Transfer-Xl-to-PPT v2.xlsm. lets you select the excel file where the images that will be copied from to ppt.  That is inputed into column b.  I would like to no longer have to do this.  I want to be able to have it run from the current workbook which could be the Transfer-xl-to-ppt.  The ppt file path is inputed into column b2 and that is fine.  
Transfer-XL-to-PPT-V2.xlsm
0
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 
LVL 45

Expert Comment

by:aikimark
Comment Utility
>>The ppt file path is inputed into column b2
I see the PPT file name in B8.  Should I see something in B2?

* all the workbook names are the same (B13:B24).  Does this mean that all the images are coming from the same workbook?  Will this be true every time?

* What is the relationship (directory placement) between the workbook you posted and the
U:\ Reporting\2011\8-Aug\Report Development\Schedules-Aug11.xlsm workbook?

* Where does the mapping data (from->to and sizing) come from?

* Will there ever be more than one source workbook?

=============
If I understand your original question, you want to eliminate the Get Excel File command button by using some path information from the workbook.  If that isn't the case, please correct me.
0
 
LVL 1

Author Comment

by:montrof
Comment Utility
>>The ppt file path is inputed into column b2
I see the PPT file name in B8.  Should I see something in B2?  Typo B8 is correct

* all the workbook names are the same (B13:B24).  Does this mean that all the images are coming from the same workbook?  Will this be true every time? Yes it will actually be the workbook Transfer-xl-to-ppt.xlsm.

* What is the relationship (directory placement) between the workbook you posted and the
U:\ Reporting\2011\8-Aug\Report Development\Schedules-Aug11.xlsm workbook? this workbook is the workbook that has all the images in it but I would move those into the transfer-xl-toppt-v2

* Where does the mapping data (from->to and sizing) come from? the mapping data is inputed to size and position the images properly in ppt.   Also the range is a named range in excel where the image is located and the slide number is where the image will go in ppt.

* Will there ever be more than one source workbook? no

=============
If I understand your original question, you want to eliminate the Get Excel File command button by using some path information from the workbook.  If that isn't the case, please correct me.

I just want the active workbook to be the place where all the information is so you would not need to specify the excel path.
0
 
LVL 45

Expert Comment

by:aikimark
Comment Utility
Does this mean that all the images are coming from the same workbook?  Will this be true every time? Yes...
So, every time you run this code, the images will come from this workbook?
U:\ Reporting\2011\8-Aug\Report Development\Schedules-Aug11.xlsm


* Where does the mapping data (from->to and sizing) come from? the mapping data is inputed to size and position the images properly in ppt.   Also the range is a named range in excel where the image is located and the slide number is where the image will go in ppt.
I want to know if the mapping is persistent between months and how dynamic/static the mapping data is and whether the user or admin changes the mapping data.


I just want the active workbook to be the place where all the information is...
Some of the information is the name of the PPT file.
Some of the information is the mapping data.
Some of the information is the images in some workbook.

Do you really mean all the information?

================
My thoughts:

I would be surprised if the image source workbook was static.  Most of my questions originate with the assumption that the source workbook changes each month/quarter/period.

There are a couple of ways to approach this problem.
  - Place the Transfer-XL-to-PPT workbook in a folder that will always be in the same relative position to the image source workbook(s).
  - Package the code as an add-in that would be available to all your Excel users.  (a true push model)
  - Package the code in PowerPoint (as a template or add-in) to pull the images from the source workbook (a true pull model)
  - Change the code to pull the images from the most current workbook in the 'source' directory.  The code can iterate through the workbooks, looking for the most recent one, based on modified date or based on an appropriate file naming scheme.  The user could be give the opportunity to change the image source workbook.
  - The mapping information might be moved, depending on its volatility.
0
 
LVL 1

Author Comment

by:montrof
Comment Utility
The mapping might change but I would always have the control sheet to specify any changes.  The  workbook would be U:\ Reporting\2011\8-Aug\Report Development\Schedules-Aug11.xlsm because this is where the code would run from so it would be the active workbook.  I just want the code to run from the active workbook and all the images would come from the active workbook.  The control sheet would still have the mapping except for the Excel reference because the images would be in the current workbook.  This way everything that is needed to create the ppt is run from the excel file that has the images in it and the mapping page.  
0
 
LVL 39

Expert Comment

by:nutsch
Comment Utility
So in essence, you want to place the control sheet, with all specs <b>except</b> the workbook info in your workbook, run it from the workbook and assume that all references are from the workbook where the images are and the control sheet is and the macros are.

Correct?

T
0
 
LVL 1

Author Comment

by:montrof
Comment Utility
Correct
0
 
LVL 39

Accepted Solution

by:
nutsch earned 500 total points
Comment Utility
This update might do it.

Thomas
Transfer-XL-to-PPT-V2.xlsm
0
 
LVL 1

Author Comment

by:montrof
Comment Utility
This is on the right track but when I try and run it I get an error on Function CopyRangeToPPT saying user defined type not defined.  Also did you test it with multiple slides to make sure it was looping through all the lines of data and copying mutiple images to multiple slides.
0
 
LVL 39

Expert Comment

by:nutsch
Comment Utility
it works in a loop allright.

Do you have references to the following object libraries (Tools \ References in the VB Editor?)

Visual Basic for Applications
Microsoft Powerpoint 14.0 Object library
Microsoft Office 14.0 Object library
0
 
LVL 1

Author Comment

by:montrof
Comment Utility
yes it is a loop and I version 12 not 14 for the object library.
0
 
LVL 1

Author Comment

by:montrof
Comment Utility
My bad when I copied it over I did not have the powerpoint library checked.  So it works perfect.  Thank you both so much for your help.
0
 
LVL 39

Expert Comment

by:nutsch
Comment Utility
Glad to finally have made it work for you. Thanks for the grade.

Thomas
0

Featured Post

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

Introduction In all recent versions of PowerPoint it is possible to trigger animations. This means the animation takes place when a certain shape is clicked. This allows you to run animation “on demand” and outwith the normal sequence of mouse cl…
Many programs have tried to outwit PowerPoint in terms of technology and skill. These programs, however, still lack several characteristics that PowerPoint has possessed from the start. Here's why PowerPoint replacements won't entirely work for desi…
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

763 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

6 Experts available now in Live!

Get 1:1 Help Now