Copy/Paste/Insert image into different size textbox in multiple sheets

[QualEng]

Hi

I have a large workbook with a variety of documents the majority of whichhave my company logos as standard but I need to be able to insert the customerlogo into these sheets. The position and size of the logo is different from onesheet to another so pasting to a specific cell is not going to work. I’m hopingsomeone can tell me how to insert the customers logo into a text box on all therequired sheets using VBA, I have tried a number of ways including the codebelow (which is a test for one sheet only) which I have tried to place the logointo a textbox. But I have a number of issues.

1. I can’t get the image to resize to the textbox - makes it the textbox bigger and no longer fits the sheet layout
2. As there a large number of sheets I think I need a common name forthe text box on each sheet so that I can use a “For Each wsheet ….Next wsheet” routine to insert the logo into eachsheet that has the named text box (without changing the text box size). I have triedplacing a text box on a number of sheets with the same name but excel doesn’tseem to allow this?

This workbook is to be used by a number of users in different locationswho may have their folders ordered/named differently. So copy paste from a sheetin the workbook would be my preference. I have tried copy/paste from a sheet inthe workbook rather than from a file location but that wasn’t successful either.

Any suggestions? I would be very grateful for any assistance Thanks

Sub ShapePicture()
Dim TextboxName As String
Dim xSh As Shape
Dim xPic As IPictureDisp
Dim xFileName As String
TextboxName = "TextBox4"
xFileName = "F:\Logos& Graphics\CustomerLogo.JPG"
Set xPic =LoadPicture(xFileName)
Set xSh =Sheets("Section Divider (11)").Shapes(TextboxName)
xSh.Height = xPic.Height /xPic.Width * xSh.Width
Set xPic =LoadPicture("")
Set xPic = Nothing
xSh.Fill.UserPicturexFileName
End Sub

 

[QualEng]

Sorry but maybe I’m not explaining my problem very clearly. Myworkbook has over 100 sheets, of which, most need a logo so having a button oneach sheet is not very efficient. The logos are of varying sizes and positions.I have placed the ActiveX boxes where they are required and they all have thesame name.
The main code which I sent last time attempts to go througha loop. I have used these routines in other parts of the workbook successfullybut I cannot get them to work together and carry on looping it stops after onepicture being loaded
Start at sheet 1
Unprotect sheet
Enter design mode
Load the picture into the ActiveX box
Exit design mode
Protect sheet
Go to next sheet

I’m on holiday for a week from tonight so will have continuewith this issue when I get back
Thanks again for your help

 

[Yongle]

have a good holiday

 

[Yongle]

This will loop all sheets (- same code as before but in a loop)
If an image is not selected the code continues to next sheet

Line added selecting each sheet and the name of the sheet is the TITLE in the File Dialog (user needs to know sheet name)


Put in standard module

Sub GetImages()

    Dim img As OLEObject, fpath As String, ws As Worksheet

    For Each ws In ThisWorkbook.Worksheets
        ws.Activate
'ask user to select image
        fpath = ChooseFile
        If fpath = "Cancelled" Then GoTo CarryOn

'identify image conrol
        Set img = ws.OLEObjects("Image1")
    
'insert image
        With img.Object
            .Picture = LoadPicture(fpath)
            .PictureSizeMode = fmPictureSizeModeZoom
        End With
CarryOn:
    Next ws
    
End Sub

Function ChooseFile() As String

    Dim fname As String, fChosen As Integer
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = Application.DefaultFilePath
        [COLOR=#008080].Title = UCase(ActiveSheet.Name)[/COLOR]
        fChosen = .Show
        .Filters.Clear
        .Filters.Add "JPG files", "*.jpg"
         If fChosen <> -1 Then
            ChooseFile = "Cancelled"
         Else
            ChooseFile = .SelectedItems(1)
        End If
    End With
End Function

 

[QualEng]

Thanks very much, I will. I'll try this new code on my return.

 

[QualEng]

Hi I managed to find time to try the code before I finish but it didn’twork, throwing up error message as follows
Run-time error ‘1004’
Method ‘OLEObjects’ of object ‘_Worksheet’ failed.

Code highlighted as below

Sub GetImages()

Dim img As OLEObject, fpathAs String, ws As Worksheet

For Each ws InThisWorkbook.Worksheets
ws.Activate
'ask user to select image
fpath = ChooseFile
If fpath ="Cancelled" Then GoTo CarryOn

'identify image conrol
Set img = ws.OLEObjects("Image1")

'insert image
With img.Object
.Picture =LoadPicture(fpath)
.PictureSizeMode =fmPictureSizeModeZoom
End With
CarryOn:
Next ws

End Sub

Any ideas? Thanks

 

[Yongle]

How about using code tags around your code.
click on the # icon and paste code between the tags

 

[Yongle]

Run-time error ‘1004’
Method ‘OLEObjects’ of object ‘_Worksheet’ failed.
...
Any ideas?

One of your worksheets does not contain the object and the code has stopped
It is the active sheet when the code stops

How do you want VBA to deal with that?

 

[QualEng]

Ignore sheets without the object and go to next. What will using code tags achieve... I don't now what they are.

Thanks again. I'll be going offline in a few minutes so maybe be in touch again the week after next.

 

[Yongle]

What will using code tags achieve

1 It follows forum rules
2 More importantly, it formats the code like it is VBA itself, which makes it much easier to read
(compare the look of your code vs mine)

Ignore sheets without the object and go to next.

For the moment simply put this line early in the code

On Error Resume Next

We will look at handling errors properly when you return from holiday