Fill Button

[Bomba]

I have this code in ThisWorkbook (below) and I need to add a shape named "Rounded Rectangle 3" which is in sheet "CHIT1&2", shape named "Rounded Rectangle 2" which is in sheet "CHIT3&4 and shape named "Rounded Rectangle 7" which is in sheet "CHIT5&6". I need the colour to be RGB(176,245,254).
Any help?

Code: Select all

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

Sheets("CHIT5&6").Range("E24,K8,J9,J12,E28,E29").Interior.ColorIndex = 6
Sheets("CHIT3&4").Range("E24,K8,J9,J12,E28,E29").Interior.ColorIndex = 6
Sheets("CHIT1&2").Range("E24,K8,J9,J12,E28,E29").Interior.ColorIndex = 6

Thanks

[HansV]

Where should the shapes be placed?

[Bomba]

Sorry, I didn't understand your question.

[HansV]

You want to create shapes. They should be placed somewhere on the worksheet, for example covering cell B2, or covering cells C3:E4, or similar. Where would you prefer to have them?

[rory]

You basically need code like:

Code: Select all

Sheets("CHIT1&2").shapes("Rounded Rectangle 3").fill.forecolor.rgb = rgb(176,245,254)

repeated for each shape.

[Bomba]

Thank you for understand me. Yes that what I needed.
Actually I need another code that every time I click these buttons, these shapes become No Fill. Is it possible?

Thanks in advance

[HansV]

To remove the fill color:

Code: Select all

Sheets("CHIT1&2").Shapes("Rounded Rectangle 3").Fill.Visible = False

[Bomba]

Sorry I forgot to tell you that these buttons are assigned to Macros.
Actually I want to remove the fill color only when I click on the button then after I save, it will appear again with fill color.
Thanks

[HansV]

You can add the line

Code: Select all

    Sheets("CHIT1&2").Shapes("Rounded Rectangle 3").Fill.Visible = False

to the macro assigned to Rounded Rectangle 3 on CHIT1&2, and you can add the line

Code: Select all

    Sheets("CHIT1&2").Shapes("Rounded Rectangle 3").Fill.ForeColor.RGB = RGB(176, 245, 254)

to the Workbook_BeforeSave event procedure in the ThisWorkbook module.

[Bomba]

Thanks a lot Master

[Bomba]

Hi Master I can't managed to do it. I think I am not putting those lines in their right place. Will I give you a link of the file so that you can try it?
Thanks

[HansV]

Go ahead...

[Bomba]

This is the first file of 31 in the same folder which are all same. So if you need all the files, please let me know.
https://www.dropbox.com/s/jek60uj3eextgrx/1.xlsm?dl=0
Thanks

[HansV]

I'm confused now. You stated that "I want to remove the fill color only when I click on the button then after I save, it will appear again with fill color".

But in the macro assigned to the shape, you save the workbook. So the fill color would be removed by clicking, then immediately applied again because you save the workbook...

Can you explain?

[Bomba]

Sorry Master, I forgot to remove "ActiveWorkbook.SAVE" from module 4 before I sent it to you.

[HansV]

In ThisWorkbook:

Code: Select all

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Sheets("CHIT5&6").Range("E24,K8,J9,J12,E28,E29").Interior.ColorIndex = 6
    Sheets("CHIT3&4").Range("E24,K8,J9,J12,E28,E29").Interior.ColorIndex = 6
    Sheets("CHIT1&2").Range("E24,K8,J9,J12,E28,E29").Interior.ColorIndex = 6

    Sheets("CHIT1&2").Range("E21").Value = Sheets("CHIT1&2").Range("E20").Value
    Sheets("CHIT1&2").Range("E22").Value = 0

    Sheets("CHIT1&2").Range("H21").Value = Sheets("CHIT1&2").Range("H20").Value
    Sheets("CHIT1&2").Range("H22").Value = 0

    Sheets("CHIT5&6").Range("E21").Value = Sheets("CHIT5&6").Range("E20").Value
    Sheets("CHIT5&6").Range("E22").Value = 0

    Sheets("CHIT5&6").Range("H21").Value = Sheets("CHIT5&6").Range("H20").Value
    Sheets("CHIT5&6").Range("H22").Value = 0

    Sheets("CHIT3&4").Range("E21").Value = Sheets("CHIT3&4").Range("E20").Value
    Sheets("CHIT3&4").Range("E22").Value = 0

    Sheets("CHIT3&4").Range("H21").Value = Sheets("CHIT3&4").Range("H20").Value
    Sheets("CHIT3&4").Range("H22").Value = 0

    Sheets("CHIT1&2").Range("B24").Formula = "=NOW()-TODAY()"
    Sheets("CHIT3&4").Range("B24").Formula = "=NOW()-TODAY()"
    Sheets("CHIT5&6").Range("B24").Formula = "=NOW()-TODAY()"

    ' Re-color the buttons
    With Sheets("CHIT1&2").Shapes("Rounded Rectangle 3").Fill
        .Visible = True
        .ForeColor.RGB = RGB(176, 245, 254)
    End With
    With Sheets("CHIT3&4").Shapes("Rounded Rectangle 2").Fill
        .Visible = True
        .ForeColor.RGB = RGB(176, 245, 254)
    End With
    With Sheets("CHIT5&6").Shapes("Rounded Rectangle 7").Fill
        .Visible = True
        .ForeColor.RGB = RGB(176, 245, 254)
    End With
End Sub

In Module4:

Code: Select all

Sub SAVE()
    Dim strPath As String
    strPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        strPath & "\Save chits\" & Range("J8").Value & ".pdf", Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    ActiveSheet.PrintOut
    ' Remove fill color from button
    ActiveSheet.Shapes(Application.Caller).Fill.Visible = False
End Sub

[Bomba]

It was hard to me to do it.
Thanks a lot Master.

[Bomba]

Master Hans,
I have 366 files to modify. I used the code below to modify Module4 and had no problems. The problem is the one in ThisWorkbook because when I tried to do it like I did to modify Module4, it gave me a lot of errors. Do you think I have to do them file by file or there is an easier way?
Thanks.

Code: Select all

Sub ReplaceText()
    Const OldText = "Write old text"
    Const NewText = "Write new text"
    Dim Folder As String
    Dim File As String
    Dim Wbk As Workbook
    Dim NumLines As Long
    Dim Lines As String
    With Application.FileDialog(4) ' msoFileDialogFolderPicker
        If .Show Then
            Folder = .SelectedItems(1)
        Else
            MsgBox "You didn't select a folder!", vbExclamation
            Exit Sub
        End If
    End With
    Application.ScreenUpdating = False
    Folder = Folder & "\"
    File = Dir(Folder & "*.xlsm")
    Do While File <> ""
        If UCase(File) <> UCase(ThisWorkbook.Name) Then
            Set Wbk = Workbooks.Open(Folder & File)
            With Wbk.VBProject.VBComponents("Module1").CodeModule
                NumLines = .CountOfLines
                Lines = .Lines(1, NumLines)
                Lines = Replace(Lines, OldText, NewText)
                .DeleteLines 1, NumLines
                .AddFromString Lines
            End With
            Wbk.Close SaveChanges:=True
        End If
        File = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox Ct & " Module 1 updated"
End Sub

[HansV]

What was the code you tried for ThisWorkbook?

[Bomba]

This code but I changed "Module1" to "ThisWorkbook"

Code: Select all

Sub ReplaceText()
    Const OldText = "Write old text"
    Const NewText = "Write new text"
    Dim Folder As String
    Dim File As String
    Dim Wbk As Workbook
    Dim NumLines As Long
    Dim Lines As String
    With Application.FileDialog(4) ' msoFileDialogFolderPicker
        If .Show Then
            Folder = .SelectedItems(1)
        Else
            MsgBox "You didn't select a folder!", vbExclamation
            Exit Sub
        End If
    End With
    Application.ScreenUpdating = False
    Folder = Folder & "\"
    File = Dir(Folder & "*.xlsm")
    Do While File <> ""
        If UCase(File) <> UCase(ThisWorkbook.Name) Then
            Set Wbk = Workbooks.Open(Folder & File)
            With Wbk.VBProject.VBComponents("Module1").CodeModule
                NumLines = .CountOfLines
                Lines = .Lines(1, NumLines)
                Lines = Replace(Lines, OldText, NewText)
                .DeleteLines 1, NumLines
                .AddFromString Lines
            End With
            Wbk.Close SaveChanges:=True
        End If
        File = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox Ct & " Module 1 updated"
End Sub