PDA

View Full Version : Traverse all images in workbook



Wouter
02-19-2018, 06:46 AM
I'm working on a macro that corrects linked image dimensions for a lot of documents at once.
I managed to get it working for Word but fail on the Excel part.

I run the macro using a Word document, it traverses our folder structure and edits each file one by one, the following code is a snippet doing the Excel editing part.
The problem is that I get a Type mismatch error (13) on retrieving the shapes of the sheet (highlighed code below).
It should return a shape object, what else could it be?



If IsFileOpen(WDDocPath) Then
Debug.Print "*** FILE IN USE *** " & WDDocPath
Else
Dim NewWidth As Double
Dim NewHeight As Double
Dim Path As String
Dim oSec As Section
Dim oHeader As HeaderFooter
Dim oLogo As Word.InlineShape
Dim oShape As Shape
Dim oSubShape As Shape
Dim oSource As String

'''''''''''''''''''''''''''''''''''''''''''''''''''''
' BEGIN OF SETTINGS

' Dimensions in cm
NewWidth = 3.28
NewHeight = 1.01

' Absolute path to image link
Path = "logo.jpg"

' END OF SETTINGS
'''''''''''''''''''''''''''''''''''''''''''''''''''''



'Verify it being a WORD or EXCEL document and call the correct functions.
If WDDocPath Like "*.x*" Then
With Workbooks.Open(WDDocPath)
.Activate
Dim ws As Worksheet
Debug.Print WDDocPath

For Each ws In ActiveWorkbook.Worksheets
ws.Activate

Debug.Print ActiveSheet.Name

For Each oShape In ws.Shapes ' TYPE MISMATCH ERROR
Debug.Print oShape.Type
If oShape.Type = 12 Then
Debug.Print TypeName(oShape.OLEFormat.Object.Object)
End If

If oShape.Type = msoLinkedPicture Then
If ModifyFloatingShape(oShape, Path, NewWidth, NewHeight) Then

End If
End If
Next oShape
Next ws


.Close True
End With

'Debug.Print (WDDocPath)
Else

snb
02-19-2018, 08:31 AM
Avoid declaring variables.
Avoid 'select' and 'activate' in VBA.
Do not nest Word & Excel
Use indentation to make your code readable.


For Each it In sheets
for Each it1 In it.Shapes
select case it1.type
case 11

case 12

end select
Next
Next

Dave
02-19-2018, 08:47 AM
Maybe this bit of code will get U started. HTH. Dave

Sub test()
Dim Sh As Shape
With Sheets("Sheet1")
For Each Sh In .Shapes
If Application.Version > 12 Then
If Sh.Type = 11 Then
MsgBox Sh.Name
End If
Else
If Sh.Type = 13 Then
MsgBox Sh.Name
End If
End If
Next Sh
End With
End Sub