Solved

make this work with active workbook

Posted on 2011-09-13
23
350 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 12
  • 7
  • 4
23 Comments
 
LVL 45

Expert Comment

by:aikimark
ID: 36536455
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
ID: 36536547
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
ID: 36536691
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
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 1

Author Comment

by:montrof
ID: 36537562
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
ID: 36537565
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
ID: 36537723
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
ID: 36537985
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
ID: 36538082
>>...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
ID: 36538121
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
ID: 36538177
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
ID: 36538223
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
 
LVL 45

Expert Comment

by:aikimark
ID: 36538379
>>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
ID: 36538435
>>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
ID: 36538727
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
ID: 36538850
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
ID: 36538989
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
ID: 36538994
Correct
0
 
LVL 39

Accepted Solution

by:
nutsch earned 500 total points
ID: 36539085
This update might do it.

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

Author Comment

by:montrof
ID: 36539331
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
ID: 36539376
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
ID: 36540220
yes it is a loop and I version 12 not 14 for the object library.
0
 
LVL 1

Author Comment

by:montrof
ID: 36542590
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
ID: 36543149
Glad to finally have made it work for you. Thanks for the grade.

Thomas
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
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…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

717 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