Macro Or Command To Change Photo In Excel - Urgent Weekend Help Needed

We have a critical spreadsheet that we call SHIPPER and it takes Metal Building data from a design program and then eventually converts it into an XML to load into the machines to roll form the material.


The primary sheet has our logo but to save time for the designers, I've created separate sheets for our "private label" customers for when we do a private label job.


The problem I have now is we have so many versions now with 5-6 private labels, that any time I need to make a change the VBA code or conditional formatting, I have to go into each workbook to do it.


So basically, this spreadsheet has our company logo on each of the 14 tabs...and it spans across A-C and 1-10.


I need this Macro to open a file selector prompt, the user choose the proper logo/jpg and it update all 14 tabs with the chosen logo within A-C and 1-10.


And sadly, now I am expected to have it ready Tuesday morning on a 3 day holiday weekend...when this was a backburner projects for many months.


Should this be done with a Macro or is there other more modern ways to do this?

And if someone can help me, I'd be so glad to help you with a "Buy Me a Coffee" link or PayPal as a small token of my appreciation on this 3 day weekend.

first thing to do before you apply what is in the demo.
you click on each "Logo" on each sheet (your workbook), and name each image logo as "Logo" (without the quote).
then copy the Module from the demo.
add a button (like in the demo) and add Assign ImagePicker As the Macro.
see the demo now.

Quote:

---

Originally Posted by arnelgp

first thing to do before you apply what is in the demo.
you click on each "Logo" on each sheet (your workbook), and name each image logo as "Logo" (without the quote).
then copy the Module from the demo.
add a button (like in the demo) and add Assign ImagePicker As the Macro.
see the demo now.

---

Thank you so much for the response.

How do I "name" the photo(s)? I see ALT TEXT option but not 100% sure where to do the proper renaming of the photo. I researched about renaming the "shape" but can't find it.


Attachment 30116

Another update...

It seems to stop at Set shp = sht.Shapes("logo")

Attachment 30117

And shp = nothing

Are you famliar with VBA ?
Hire a programmer.

"critical spreadsheet that we call SHIPPER" & "primary sheet". Are these the same sheets?
"separate sheets". What are these named? Or are this the 14 tabs? If so, are these tabs the only tabs in the workbook? If not, where are they situated? The last 14? Or maybe the first leftmost 14?
"with 5-6 private labels" Where does this come in with your problem to be solved? Where do we need to watch for this?
"go into each workbook" Which workbooks are that?
"this spreadsheet" Which sheet is that?
"a Macro or is there other more modern ways" How old are your macros if they are compared to "more modern ways"
BTW, what do you consider "more modern ways?


Or is it that you want to select a picture from FileDialogFilePicker, insert it in every sheet in the active workbook and size it to cover A1:C10?

The code that "arnelgp" kindly provided, I believe is going to work...just having issue with "Shapes" and/or naming the image "logo"...

Code:

---

Option Explicit

Public Sub ImagePicker()
Dim sht As Worksheet, shp As Shape
Dim file As String
Dim fd As FileDialog
Dim t As Single, l As Single, w As Single, h As Single
' get some images
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
    .AllowMultiSelect = False
    With .Filters
        .Clear
        .Add "Images", "*.ani;*.bmp;*.gif;*.ico;*.jpe;*.jpeg;*.jpg;*.pcx;*.png;*.psd;*.tga;*.tif;*.tiff;*.webp;*.wmf"
    End With
    If .Show = -1 Then
        file = .SelectedItems(1)
    End If
End With
'change images on each sheets
If Len(file) <> 0 Then
    For Each sht In ThisWorkbook.Sheets
        sht.Activate
        Set shp = sht.Shapes("logo")
       
        With shp
            t = .Top
            l = .Left
            w = .Width
            h = .Height
            .Delete
        End With
        sht.Pictures.Insert(file).Select
        With Selection
            .Name = "logo"
            .Top = t
            .Left = l
            .Width = w
            .Height = h
        End With
    Next
End If
Sheets(1).Activate
End Sub

---

A quick and dirty possibility.

Code:

---

Sub Maybe()
Dim img As Object, i As Long, a As String
a = ActiveSheet.Name
ChDir "C:\E-Mail Downloads"    '<---- Folder where logos are stored
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .ButtonName = "Submit"
        .Title = "Select an image file"
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "JPEG File Interchange Format", "*.JPEG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "Tag Image File Format", "*.TIFF"
        .Filters.Add "All Pictures", "*.*"
If .Show = -1 Then
Set img = ActiveSheet.Pictures.Insert(.SelectedItems(1))
With img
    .ShapeRange.LockAspectRatio = False
    .Name = "Logo_One"
    .Left = Cells(1, 1).Left
    .Top = Cells(1, 1).Top
    .Width = Cells(1, 4).Left
    .Height = Cells(11, 1).Top
End With
End If
End With
Application.ScreenUpdating = False
ActiveSheet.Shapes("Logo_One").Copy
    For i = 2 To ThisWorkbook.Worksheets.Count
        Sheets(i).Select
        Cells(1, 1).PasteSpecial
    Next i
Sheets(a).Select
Application.ScreenUpdating = True
End Sub

---

Attachment 30118

A shorter version.

Code:

---

Sub Or_Maybe_So()
Dim x, a As String, i As Long
a = ActiveSheet.Name
    With Application.FileDialog(msoFileDialogFilePicker)
        .Show
        x = .SelectedItems(1)
    End With
ActiveSheet.Shapes.AddPicture(x, False, True, Cells(1, 1).Left, Cells(1, 1).Top, Cells(1, 4).Left, Cells(11, 1).Top).Name = "Logo"
Application.ScreenUpdating = False
ActiveSheet.Shapes("Logo").Copy
    For i = 2 To ThisWorkbook.Worksheets.Count
        With Sheets(i)
            .Select
            .Cells(1, 1).PasteSpecial
        End With
    Next i
Sheets(a).Select
Application.ScreenUpdating = True
End Sub

---

Quote:

---

converts it into an XML to load into the machines to roll form the material.

---

I don't see why the machine needs any logo in an XML (???) file.

@joli:

Code:

---

Sub M_snb()
  Application.Dialogs(342).Show
   
  If Shapes.Count > 0 Then
    With Shapes(1)
      .Name = "logo"
      .Top = 1
      .Left = 1
      .Height = Rows(11).Top
      .Copy
    End With
       
    For Each it In Sheets
      If it.Shapes.Count = 0 Then it.Paste
    Next
  End If
End Sub

---

@snb.
Looks interesting but I have not been able to get it to work (yet).

Quote:

---

Originally Posted by jolivanes

"critical spreadsheet that we call SHIPPER" & "primary sheet". Are these the same sheets?
"separate sheets". What are these named? Or are this the 14 tabs? If so, are these tabs the only tabs in the workbook? If not, where are they situated? The last 14? Or maybe the first leftmost 14?
"with 5-6 private labels" Where does this come in with your problem to be solved? Where do we need to watch for this?
"go into each workbook" Which workbooks are that?
"this spreadsheet" Which sheet is that?
"a Macro or is there other more modern ways" How old are your macros if they are compared to "more modern ways"
BTW, what do you consider "more modern ways?


Or is it that you want to select a picture from FileDialogFilePicker, insert it in every sheet in the active workbook and size it to cover A1:C10?

---

Shipper is the name of the entire project...I should have said on each Worksheet (Not Primary SHeet), there is a logo...there are 14 tabs/worksheets. They have unique names.

The file picker will help the user find the private label JPG.

Again, sorry...only one workbook...should have said worksheet.

Well, not sure if I could use Office Scripting or that new feature that came out but this SHIPPER is so VBA heave, that I might as well keep it.

So, I tried the code ARNELGP provided and it gets stuck on the shape reference.

Quote:

---

Originally Posted by garak0410

Another update...

It seems to stop at Set shp = sht.Shapes("logo")

Attachment 30117

And shp = nothing

---

Unless it is more involved than this...I think if I resolve this right here, it will work. My deadline is approaching so hope to get it fixed this morning (CDT)...

Do you have buttons on each sheet or is the image (logo) the only shape on each tab?

Do you display the image inside of a shape or does the image just sit in the spreadsheet in the specified range?

Have you named each shape where the picture is to reside 'Logo'?

it would be much easier if you Upload your excel workbook here.

Quote:

---

Originally Posted by georgiboy

Do you have buttons on each sheet or is the image (logo) the only shape on each tab?

Do you display the image inside of a shape or does the image just sit in the spreadsheet in the specified range?

Have you named each shape where the picture is to reside 'Logo'?

---

Each sheet has this logo at the top left...

Attachment 30127

There are some buttons on each sheet that are used to check calculations and then send to XML files...

Attachment 30128

How can I verify if it is displayed as a shape? I think it is just an image sitting there most likely.

I've gone through and named it logo on each page...

Attachment 30129

But I am thinking since the code he shared is looking for a shape named logo, perhaps I need to we do all of the existing logos as shapes with photos in them and then name them, you think?

Quote:

---

Originally Posted by arnelgp

it would be much easier if you Upload your excel workbook here.

---

I can try...it may not open correctly without the XLA file that it attaches but I am not putting this code in that XLA file so it may open...and there are no trade secrets in this so it is safe...

you Upload your Excel file, not some picture if you want this to be resolved the soonest.

Here's the project without the XLA file, so you may get a few errors on opening...

Attachment 30130

Quote:

---

Originally Posted by garak0410

Here's the project without the XLA file, so you may get a few errors on opening...

Attachment 30130

---

That should work...and as you can see, I added the button to the COVER page and the module for the code you kindly provided.

all the Sheets are Locked that is why you cannot changed the "image".
you try this, it will unlock first the sheet then change the image and Lock it again.
i cannot test it, i am using x64 office.

Quote:

---

Originally Posted by arnelgp

all the Sheets are Locked that is why you cannot changed the "image".
you try this, it will unlock first the sheet then change the image and Lock it again.
i cannot test it, i am using x64 office.

---

It sadly still fails here...

Attachment 30132

All the sheets look like old fashioned register cards.
If you prefer to work with Excel you should design these data as a database in only 1 sheet.
The 'Logo problem' melts away in that case.
It saves you a lot of time/trouble.

i change the name to CoLogo.
there are some "pictures" that i accidentally spoiled, please check each sheet
and compare to the original what images i accidentally replaced.
i tested and now it is changing.

just post back if anything is wrong.

Quote:

---

Originally Posted by arnelgp

i change the name to CoLogo.
there are some "pictures" that i accidentally spoiled, please check each sheet
and compare to the original what images i accidentally replaced.
i tested and now it is changing.

just post back if anything is wrong.

---

I got your copy to work...I went into production copy, renamed all as CoLogo and the Macro worked...

The only issues left is that it protected a "hidden sheet"...one called IMPORT...there may be a few other "staging" pages that are protected...

And a once functional Button/Macro now stops with this error:
Attachment 30136

When it goes to run this subroutine.

Code:

---

Sub Export_Panel(wksName As String)    Dim strWrkSheet As String
    Dim sJobNum As String
    Dim sCustomer As String
    ' Adding String for XML Conversion (BW 20200124)
    Dim sName As String
    Dim sOut As String
    Dim sXtra As String
    Dim fh As Long
    Dim i As Integer, iu As Integer
    Dim j As Integer
    Dim k As Integer
    Dim l As Integer
    Dim intRowLast As Integer
    Dim wkSheet As Worksheet
    Dim blnVisible As Boolean
    Dim lQty As Long
    Dim lRC_Qty As Long
    Dim dLength As Double
    Dim sProfile As String
    Dim dWeight As Double


    Set colSheetNames = New Collection
    Workbooks(wksName).Activate
    strWrkSheet = ActiveSheet.Name


'JobNumber,CustomerName,LineID,RequestedQty,CoilPartNum,LENGTH,Profile,Color,PieceMark,Description,BundleMark,Weight


    For Each wkSheet In ActiveWorkbook.Worksheets
        If Left(wkSheet.Name, 8) = "PINN PAN" Then
            colSheetNames.Add (wkSheet.Name)
        End If
    Next wkSheet


    If ConfirmWeights("Panel") = False Then Exit Sub
'    PrepareImportPage4Panel (wksName)
'****************************************************
'Stop 'For Debugging Prep code! Rem when not in use.*
'****************************************************
    fh = FreeFile
    Sheets("PINN PANEL").Select
    sJobNum = Cells(2, 5).Value
    If Val(Left$(sJobNum, 1)) = 0 Then
      sJobNum = Format$(Now(), "yy") & sJobNum
    ElseIf Left$(sJobNum, 1) > 6 Then
      sJobNum = "0" & sJobNum
    End If
    If InStr(sJobNum, ",") <> 0 Then sJobNum = Replace(sJobNum, ",", "")
'    Open "\\BR_Panel\Panel$\" & sJobNum & "-Panel.csv" For Output As #fh <--- ORIGINAL Line
'    Open "C:\" & sJobNum & "-Panel.csv" For Output As #fh
    Open "\\fileserver\Bradbury-Xfer\Panel\" & sJobNum & "-Panel.csv" For Output As #fh
    ' variable for XML conversion (BW 20200124)
    sName = "\\fileserver\Bradbury-Xfer\Panel\" & sJobNum & "-Panel"
    sOut = "JobNumber,CustomerName,LineID,RequestedQty,CoilPartNum,Length,Profile,Color,PieceMark,Description,BundleMark,Weight"
    Print #fh, sOut ' Header
    sCustomer = Replace(Cells(3, 5).Value, ",", "")
    sOut = sJobNum & "," & sCustomer
    l = 1


    For i = 1 To colSheetNames.Count
        If blnVisible = True Then blnVisible = False
        If Sheets(colSheetNames(i)).Visible = False Then
            Sheets(colSheetNames(i)).Visible = True
            blnVisible = True
        End If
        Sheets(colSheetNames(i)).Select
        ActiveSheet.Range("A65536").End(xlUp).Select
        intRowLast = Int(Right(ActiveCell.Address, Len(ActiveCell.Address) - 3))


        For j = 12 To intRowLast
            If Val(Cells(j, 1).Value) <> 0 _
              And InStr(UCase(Cells(j, 4).Value), "LITE") = 0 _
              And InStr(UCase(Cells(j, 4).Value), "SKY") = 0 Then
                lQty = Cells(j, 1).Value
                sProfile = Mid$(Cells(j, 4).Value, 4)
                dLength = CInches(Cells(j, 6).Value) / 12                  ' Length in feet (decimal)
                sOut = sOut & ",Panel"                                    ' LineID
                If sProfile = "RC" Then
                  lRC_Qty = -1 * Int(-1 * lQty * dLength / 10)            ' Quantity of 10' sheets
                  sOut = sOut & ("," & CStr(lRC_Qty))                      ' Quantity (4 RCs per sheet)
                  sOut = sOut & ",00.000X00G"                              ' CoilPartNumber (bogus for Panel)
                  sOut = sOut & ",120"                                    ' Length in inches (decimal)
                  dWeight = lRC_Qty * 28.2                                ' 2'-6" RC weighs 7.05 pounds
                Else
                  sOut = sOut & ("," & Cells(j, 1).Value)                  ' Part quantity
                  sOut = sOut & ",00.000X00G"                              ' CoilPartNumber (bogus for Panel)
                  sOut = sOut & ("," & CInches(Cells(j, 6).Value))        ' Length in inches (decimal)
                End If
                sOut = sOut & ("," & Trim$(Cells(j, 4).Value))            ' Profile
                sOut = sOut & ("," & Left$(Cells(j, 5).Value, 15))        ' Color
                'We are having a problem with the Piece Marks and the CTC. The following code
                'is simply to work around the issue.
                If InStr(UCase(Cells(j, 2).Value), "XTRA") > 0 Then
                    k = InStr(UCase(Cells(j, 2).Value), "XTRA")
                    'I do not expect to see 10 or more extra parts, but if it happens we are ready.
                    Do Until k = 0
                        If Asc(Mid(UCase(Cells(j, 2).Value), k, 1)) > 47 And _
                          Asc(Mid(UCase(Cells(j, 2).Value), k, 1)) < 58 Then
                            sXtra = Mid(UCase(Cells(j, 2).Value), k, 1) & sXtra
                        End If
                        k = k - 1
                    Loop
                    sOut = sOut & ("," & sXtra & "Xtra")                    ' Piece mark (modified)
                Else
                    sOut = sOut & ("," & Left$(Cells(j, 2).Value, 25))      ' Piece mark
                End If
                sOut = sOut & ("," & Left$(Cells(j, 3).Value, 25))          ' Description
                sOut = sOut & (",Bundle1")                                  ' Bundle mark
                If sProfile = "RC" Then
                  sOut = sOut & ("," & Format$(dWeight, "#.0###"))          ' RC Weight (total)
                Else
                  sOut = sOut & ("," & Format$(Cells(j, 7).Value, "#.0###")) ' Weight (total)
                End If
                l = l + 1
                Print #fh, sOut
                sOut = ","
            End If
        Next j
        If blnVisible = True Then Sheets(colSheetNames(i)).Visible = False
    Next i
    Sheets(strWrkSheet).Select
    Range("K10").Select
    If Range("K10").Value = "" Then
        With Selection
            .HorizontalAlignment = xlRight
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
            .Value = "Released"
        End With
        With Selection.Interior
            .ColorIndex = 4
            .Pattern = xlSolid
        End With
    Else
        With Selection
            .HorizontalAlignment = xlRight
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
            .Value = "Again"
        End With
        With Selection.Interior
            .ColorIndex = 50
            .Pattern = xlSolid
        End With
    End If
    Close #fh
    ' command to convert CSV to XML (BW 20200124)
    Shell """C:\ShipperXML\Panel\CsvToXml.exe"" """ & sName & ".csv"" """ & sName & ".xml""", vbNormalFocus
    ' New XML Conversion
  '  Shell "C:\Program Files\CSVtoXML\CsvToXml.exe """ & inputFile & """ """ & outputFile, vbNormalFocus
  ' orginal attempt at converting to xml
  ' Dim bSaved  As Boolean
  ' bSaved = CSV2XML("\\fileserver\Bradbury-Xfer\Panel\Test", "test.csv", "ConvertedCSV.xml")
  ' Application.ScreenUpdating = True
  ' Application.ScreenUpdating = True
  ' Set colSheetNames = Nothing
End Sub

---

Wondering of this a protection error that doesn't specifically say it is. We are SO CLOSE...

Quote:

---

Originally Posted by garak0410

I got your copy to work...I went into production copy, renamed all as CoLogo and the Macro worked...

The only issues left is that it protected a "hidden sheet"...one called IMPORT...there may be a few other "staging" pages that are protected...

And a once functional Button/Macro now stops with this error:
Attachment 30136

Wondering of this a protection error that doesn't specifically say it is. We are SO CLOSE...

---

If I am right, should I add a statement to say if sheet is hidden or not yet created, to change to UNPROTECTED? When this sheet does it's other subroutines and such, it does create staging pages for the data and that's where I am running into the issues now. If I need to post the project back, I can.

Update - I've mostly fixed it by putting in a few more unprotect commands. Going to test it in production in the morning. Will update then.

Thank you for all of the help...

I do have one more question...

How do I set the PATH for the File Picker?

It needs to go to \\fileserver\drafting\logos

Thanks!

I wanted to update everyone...the logo changing is working great...and thank you for all of your help.

Because I needed the sheet to be unprotected on several occasions, I am currently trying to track down the one unprotect I don't need...and it isn't even related to the change logo code.