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

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

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

logo_02.jpg

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

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

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

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.