UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> Add Pictures/powerpoint Slide To Excel From Access 2013, Access 2013    
 
   
EvanLS
post Jan 12 2018, 08:12 PM
Post#1



Posts: 119
Joined: 10-March 09



I am very frustrated trying to find the proper code to do the following:

1. From an Access 2013 module, I am trying to update an existing Excel spreadsheet with a picture(.jpg) and
2. Update a Powerpoint slide on the same spreadsheet.
3. There is also a static picture on the spreadsheet that doesn't get updated.

I am able to add the objects successfully, BUT before I add the objects to the spreadsheet it is necessary to delete
the objects previously inserted in a prior update. Therein lies the problem. I'm using the following code:

'Delete old picture.jpg
xlsapp.ActiveSheet.Shapes(2).Delete
xlsapp.ActiveSheet.Shapes.AddPicture "c:\picture.jpg", False, True, 25, 325, 650, -1

ActiveSheet.Shapes(2).OLEFormat.Object.Border.ColorIndex = 11
ActiveSheet.Shapes(2).OLEFormat.Object.Border.Weight = xlThick


'Powerpoint
xlsapp.ActiveSheet.Shapes(1).Delete
xlsapp.ActiveSheet.OLEObjects.Add(FileName:="c:\PowerpointSlide.ppt", Link:=False, DisplayAsIcon:=False, Left:=185, Top:=200, Width:=200, Height:=15).Select
ActiveSheet.Shapes(1).OLEFormat.Object.Border.ColorIndex = 11
ActiveSheet.Shapes(1).OLEFormat.Object.Border.Weight = xlThick

The problem is that every time the object is deleted and recreated the shape has a different relative address.
I've tried naming the objects after creating them, but I haven't been successful. I've tried code that loops thru the shapes in an attempt to delete them,
but I can't get that to work either.

Any suggestions would be much appreciated!
Go to the top of the page
 
cheekybuddha
post Jan 13 2018, 10:21 AM
Post#2


UtterAccess VIP
Posts: 10,432
Joined: 6-December 03
From: Telegraph Hill


Hi,

Firstly, when automating Excel from Access, try and get explicit references to the workbook and worksheet, rather than relying on ActiveSheet, which can be flaky at times.

For your situation, try and grab the relevant properties of the objects before you delete them and then use them in your new objects.

>> The problem is that every time the object is deleted and recreated the shape has a different relative address. <<

Do you mean that when you create and delete an object the indicies of the Shapes collection change and you no longer refer to the object you thought you were?

If you know the shape names in advance, then that is easier - otherwise you can grab the names into an array and use that.

I'll assume that you know the shape names beforehand, so you can do something along the lines of:
CODE
  Dim xlsapp As New Excel.Application
  Dim wb As Excel.Workbook
  Dim ws As Excel.Worksheet
  Dim shapeOld As Excel.Shape
  Dim shapeNew As Excel.Shape
  
  Const PPT_SHAPE As String = "ppt"    ' Use your actual names here
  Const JPG_SHAPE As String = "jpg"

  Set wb = xlsapp.Workbooks.Open "Path\To\Your\File.xlsx"
  Set ws = wb.Worksheets("SheetName")    ' Use your actual names here

  With ws

    Set shapeOld = .Shapes(JPG_SHAPE)
    Set shapeNew = .Shapes.AddPicture("c:\picture.jpg", False, True, shapeOld.Left, shapeOld.Top, shapeOld.Width, shapeOld.Height)
    With shapeNew
      .Line.Weight = shapeOld.Line.Weight
      .Line.ForeColor.RGB = shapeOld.Line.ForeColor.RGB
    End With
    shapeOld.Delete
    shapeNew.Name = JPG_SHAPE

    Set shapeOld = .Shapes(PPT_SHAPE)
    Set shapeNew =  .Shapes.AddOLEObject(FileName:="c:\PowerpointSlide.ppt", Link:=False, DisplayAsIcon:=False, Left:=shapeOld.Left, Top:=shapeOld.Top, Width:=shapeOld.Width, Height:=shapeOld.Height)
    With shapeNew
      .Line.Weight = shapeOld.Line.Weight
      .Line.ForeColor.RGB = shapeOld.Line.ForeColor.RGB
    End With
    shapeOld.Delete
    shapeNew.Name = PPT_SHAPE

  End With

  Set shapeOld = Nothing
  Set shapeNew = Nothing
  Set ws = Nothing
  wb.Close True
  Set wb = Nothing


(Please note: the above is aircode, so it may require some tweaking!)

hth,

d
Go to the top of the page
 
EvanLS
post Jan 13 2018, 04:03 PM
Post#3



Posts: 119
Joined: 10-March 09



David,
Thank you so much for taking the time to respond in such a comprehensive manner.
Your code looks promising...I'm anxious to try it.

In reply to your question: "Do you mean that when you create and delete an object the indicies of the Shapes collection change and you no longer refer to the object you thought you were?"
You are absolutely correct.

I'm just having an issue with one line of code: Set wb = xlsapp.Workbooks.Open "Path\To\Your\File.xlsx"
I'm getting a compile error: "Expected: End of Statement"
I tried quotes around my path/filename, parens and even added "Filename:=" but no luck.
Any ideas?

Thanks Again!
Evan
Go to the top of the page
 
cheekybuddha
post Jan 13 2018, 05:03 PM
Post#4


UtterAccess VIP
Posts: 10,432
Joined: 6-December 03
From: Telegraph Hill


My apologies!

It should be:
CODE
  Set wb = xlsapp.Workbooks.Open("Path\To\Your\File.xlsx")


Here, the .Open() method is being used as a function to return a Workbook object, so its argument(s) must be enclosed in parentheses.

I warned you I hadn't tested the code - I hope no more blows up!

thumbup.gif

d
Go to the top of the page
 
EvanLS
post Jan 13 2018, 06:20 PM
Post#5



Posts: 119
Joined: 10-March 09



Thanks again Dave...got by that compile error with your assist.

Now another compile error: "Duplicate declaration in current scope"
"Dim xlsapp as New Excel.Application" is highlighted

I searched my code and found: Set xlsapp = CreateObject("Excel.Application") from my original code.
I removed it, but same error. I don't see the duplicate.

Any ideas?
Go to the top of the page
 
cheekybuddha
post Jan 13 2018, 07:24 PM
Post#6


UtterAccess VIP
Posts: 10,432
Joined: 6-December 03
From: Telegraph Hill


You probably also have :
CODE
  Dim xlsapp AS Object


I didn't know whether your code was early- or late-bound, so I guessed early.

Remove:
[code] Dim xlsapp as New Excel.Application[/cpde]
and leave your original declaration.

If you get any more compile errors then post the whole procedure code.

hth,

d
Go to the top of the page
 
EvanLS
post Jan 14 2018, 07:59 AM
Post#7



Posts: 119
Joined: 10-March 09



Dave,
I left my original Declaration and that eliminated the compile error.
Now I'm getting a runtime error: "Object variable or With block variable not set"
on
CODE
"Set ws = wb.Worksheets
"


'Original Declaration:
CODE
Set xlsapp = CreateObject("Excel.Application")
Set xlswkb = xlsapp.Workbooks.Open(varFilePathToFunction)

    'Excel.Application.DisplayAlerts = False
xlsapp.DisplayAlerts = False
xlsapp.Workbooks.Open varFilePathToFunction, notify:=False
xlsapp.Visible = True
xlsapp.Cursor = xlWait


'Your Code
CODE
'Dim xlsapp As New Excel.Application    'commented out per Dave
  Dim wb As Excel.Workbook
  Dim ws As Excel.Worksheet
  Dim shapeOld As Excel.Shape
  Dim shapeNew As Excel.Shape
  
  Const PPT_SHAPE As String = "PPT Shape"    ' Use your actual names here
  Const JPG_SHAPE As String = "JBG Shape"

  Set wb = xlsapp.Workbooks.Open("w:\ExcelFile.xls")
  Set ws = wb.Worksheets("Sheet1")    ' Use your actual names here

  With ws

    Set shapeOld = .Shapes(JPG_SHAPE)
    Set shapeNew = .Shapes.AddPicture("c:\picture.jpg", False, True, shapeOld.Left, shapeOld.Top, shapeOld.Width, shapeOld.Height)
    With shapeNew
      .Line.Weight = shapeOld.Line.Weight
      .Line.ForeColor.RGB = shapeOld.Line.ForeColor.RGB
    End With
    shapeOld.Delete
    shapeNew.Name = JPG_SHAPE

    Set shapeOld = .Shapes(PPT_SHAPE)
    Set shapeNew = .Shapes.AddOLEObject(FileName:="c:\PowerpointSlide.ppt", Link:=False, DisplayAsIcon:=False, Left:=shapeOld.Left, Top:=shapeOld.Top, Width:=shapeOld.Width, Height:=shapeOld.Height)
    With shapeNew
     .Line.Weight = shapeOld.Line.Weight
     .Line.ForeColor.RGB = shapeOld.Line.ForeColor.RGB
    End With
    shapeOld.Delete
    shapeNew.Name = PPT_SHAPE

  End With

  Set shapeOld = Nothing
  Set shapeNew = Nothing
  Set ws = Nothing
  wb.Close True
  Set wb = Nothing


Any ideas?
Thanks!
Go to the top of the page
 
cheekybuddha
post Jan 14 2018, 11:07 AM
Post#8


UtterAccess VIP
Posts: 10,432
Joined: 6-December 03
From: Telegraph Hill


So, you have 2 calls to open the workbook:
CODE
' ...
  Set xlswkb = xlsapp.Workbooks.Open(varFilePathToFunction)
' ...
  xlsapp.Workbooks.Open varFilePathToFunction, notify:=False
' ...


Post the whole code as you have it of your procedure that's throwing up the errors and we can eliminate what's duplicated.

hth,

d
Go to the top of the page
 
EvanLS
post Jan 14 2018, 02:23 PM
Post#9



Posts: 119
Joined: 10-March 09



Dave,
Here is the code you requested.
I commented out what you asked me to. It still throws runtime error 91. I indicated where within the code.
Thanks for taking the time....much appreciated.


CODE
Function FormatExcelWorkBook(varFilePathToFunction)

On Error GoTo Err_FormatWorkBook

Set xlsapp = CreateObject("Excel.Application")
Set xlswkb = xlsapp.Workbooks.Open(varFilePathToFunction)

'Excel.Application.DisplayAlerts = False
'xlsapp.DisplayAlerts = False
'xlsapp.Workbooks.Open varFilePathToFunction, notify:=False
xlsapp.Visible = True
xlsapp.Cursor = xlWait


      Case Is = varASpreadsheet
    
    xlsapp.Rows("66:66").Select
    'xlsApp.Selection.ClearContents
    xlsapp.Selection.Delete Shift:=xlUp
    xlsapp.Range("A1").Select
    ChDir "c:\"
    
    xlsapp.Range("A13").Select
    xlsapp.Range("A13") = "Availability"
    xlsapp.ActiveCell.HorizontalAlignment = xlCenter
    
    xlsapp.Range("A14").Select
    xlsapp.Range("A14") = "Week " & WeekNumber & " " & Format(Date, "yyyy")
    xlsapp.ActiveCell.HorizontalAlignment = xlCenter
        
    xlsapp.Range("B9").Select
    xlsapp.Range("B9") = varCustomerNameForEmailSubject
    xlsapp.ActiveCell.HorizontalAlignment = xlLeft
    xlsapp.ActiveCell.Font.Bold = True
    
      
    Dim Line1 As String
    Dim Line2 As String
    Dim Line3 As String
    Line1 = "Current Week " & WeekNumber & " Powerpoint slide"
    Line2 = "All Photos taken " & Format(Date, "mmm d, yyyy") & " *No Filter*"
    Line3 = "xxx@xxx.com"
    
    xlsapp.Range("C23").Select
    xlsapp.Range("C23") = Line1
    xlsapp.ActiveCell.HorizontalAlignment = xlCenter
    xlsapp.ActiveCell.Font.Name = "Calibri Light"
    xlsapp.ActiveCell.Font.Color = RGB(0, 0, 128)      'Navy Blue
    xlsapp.ActiveCell.Font.Bold = True
    
    xlsapp.Range("C24").Select
    xlsapp.Range("C24") = Line2
    xlsapp.ActiveCell.HorizontalAlignment = xlCenter
    xlsapp.ActiveCell.Font.Name = "Calibri Light"
    xlsapp.ActiveCell.Font.Color = RGB(0, 0, 128)      'Navy Blue
    xlsapp.ActiveCell.Font.Bold = True
    
    xlsapp.Range("C25").Select
    xlsapp.Range("C25") = Line3
    xlsapp.ActiveCell.HorizontalAlignment = xlCenter
    xlsapp.ActiveCell.Font.Name = "Calibri Light"
    xlsapp.ActiveCell.Font.Color = RGB(0, 0, 128)      'Navy Blue
    xlsapp.ActiveCell.Font.Bold = True
    
    Convert_GardenCenter_To_Hyperlinks
    xlsapp.Range("I64").Select
    xlsapp.Range("I64") = "Retail Price"
    xlsapp.ActiveCell.HorizontalAlignment = xlCenter
    
   'Dave's Code
  'Dim xlsapp As New Excel.Application
  Dim wb As Excel.Workbook
  Dim ws As Excel.Worksheet
  Dim shapeOld As Excel.Shape
  Dim shapeNew As Excel.Shape
  
  Const PPT_SHAPE As String = "Powerpoint slide.ppt"    ' Use your actual names here
  Const JPG_SHAPE As String = "picture.jpg"

  Set wb = xlsapp.Workbooks.Open("Spreadsheet.xls")
  Set ws = wb.Worksheets("Sheet1")                                          ' This is where Error 91 occurs  

  With ws
    Set shapeOld = .Shapes(JPG_SHAPE)
    Set shapeNew = .Shapes.AddPicture("c:\picture.jpg", False, True, shapeOld.Left, shapeOld.Top, shapeOld.Width, shapeOld.Height)
    With shapeNew
      .Line.Weight = shapeOld.Line.Weight
      .Line.ForeColor.RGB = shapeOld.Line.ForeColor.RGB
    End With
    shapeOld.Delete
    shapeNew.Name = JPG_SHAPE

    Set shapeOld = .Shapes(PPT_SHAPE)
    Set shapeNew = .Shapes.AddOLEObject(FileName:="c:\PowerpointSlide.ppt", Link:=False, DisplayAsIcon:=False, Left:=shapeOld.Left, Top:=shapeOld.Top, Width:=shapeOld.Width, Height:=shapeOld.Height)
    With shapeNew
     .Line.Weight = shapeOld.Line.Weight
     .Line.ForeColor.RGB = shapeOld.Line.ForeColor.RGB
    End With
    shapeOld.Delete
    shapeNew.Name = PPT_SHAPE

  End With

  Set shapeOld = Nothing
  Set shapeNew = Nothing
  Set ws = Nothing
  wb.Close True
  Set wb = Nothing
  
    
    xlsapp.Range("A1").Select
    
    xlsapp.ActiveWorkbook.Application.DisplayAlerts = False
    xlsapp.ActiveWorkbook.SaveAs FileName:="Spreadsheet.xls", FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
    xlsapp.ActiveWorkbook.Application.DisplayAlerts = True
    xlsapp.ActiveWorkbook.Close
    
    
    Case Else
     MsgBox "The Excel macro was NOT FOUND" & vbCr & vbCr & "Please be sure your exported QuickBooks" & vbCr & vbCr & "spreadsheet is named properly" & vbCr & vbCr & "        JOB TERMINATED!"
     varMacroError = 1

End Select

'============================================================================
=============

'Shutdown Excel

If IsAppRunning("Excel.Application") Then
   Set xlswkb = Nothing
   xlsapp.Quit
   Set xlsapp = Nothing
End If

Exit Function

Err_FormatWorkBook:

MsgBox Err.Description

'If Excel is running after the error....shut it down.    
If IsAppRunning("Excel.Application") Then
   Set xlswkb = Nothing
   xlsapp.Quit
   Set xlsapp = Nothing
End If

End Function
Go to the top of the page
 
cheekybuddha
post Jan 14 2018, 02:31 PM
Post#10


UtterAccess VIP
Posts: 10,432
Joined: 6-December 03
From: Telegraph Hill


It'll take me a little while to look over this, but you seem to be missing an opening Select Case statement, before Case Is = varASpreadsheet .

Also, where do you declare and set varASpreadsheet ?

Let me know that, and I'll get back as soon as I can.
Go to the top of the page
 
EvanLS
post Jan 14 2018, 06:29 PM
Post#11



Posts: 119
Joined: 10-March 09



Dave,

No need to look any further.....all OK now using your elegant code!

Thank you so much for your assist.
Go to the top of the page
 
EvanLS
post Mar 11 2018, 12:32 PM
Post#12



Posts: 119
Joined: 10-March 09



Hello again Dave,

I need your expertise again. I hope you can help.
The code you supplied a while back has been working great.
We just upgraded to Microsoft Office Pro 2016.....and now it's crashing.

At first I was getting compile errors. I worked thru them and now I'm getting the dreaded,
"Object Doesn't Support This Property or Method." error message.
I can't figure out why?

The following instruction is causing the crash:
"Set shapeOld = .Shapes(JPG_SHAPE)"
Please see attachment.

I'm sure it has to be a difference between Office 2016 and 2013 causing the problem,
but I don't know how to fix the code to make it run under Office 2016.

Any ideas?
Thank You!
Evan

Attached File(s)
Attached File  Handle_Shapes.JPG ( 91.62K )Number of downloads: 2
 
Go to the top of the page
 
cheekybuddha
post Mar 14 2018, 05:49 PM
Post#13


UtterAccess VIP
Posts: 10,432
Joined: 6-December 03
From: Telegraph Hill


Hi Evan,

My apologies - I seem to have missed your latest question in this thread.

Looking at your attached image, I can't see where you declare varFilePathToFunction.

Previously it was passed as an argument to the function, but HandleSpreadsheetShapes() has no such argument.

I guess this will be at the root of the issue.

hth,

d
Go to the top of the page
 


Custom Search
RSSSearch   Top   Lo-Fi    18th October 2018 - 06:36 AM