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

[garak0410]

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.

[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.

[garak0410]

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.


30116

[garak0410]

Another update...

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

30117

And shp = nothing

[snb]

Are you famliar with VBA ?
Hire a programmer.

[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?

[garak0410]

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


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

[jolivanes]

A quick and dirty possibility.

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

[arnelgp]

30118

[jolivanes]

A shorter version.

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

[snb]

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:


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

[jolivanes]

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

[garak0410]

"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.

[garak0410]

Another update...

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

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)...

[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'?

[arnelgp]

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

[garak0410]

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...

30127

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

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...

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?

[garak0410]

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...

[arnelgp]

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

[garak0410]

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

30130

[garak0410]

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

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.

[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.

[garak0410]

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...

30132

[snb]

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.

[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.

[garak0410]

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:
30136

When it goes to run this subroutine.

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,Colo r,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...

[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:
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.

[garak0410]

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.

[garak0410]

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!

[garak0410]

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.