Automate screenshots of protected cells with a pop up msg of protected cells

[Globaltechpharm]

Dear all,

I am having one excel file with vba in which some cells are protected (white) and others are unprotected (sky blue) within a specified range (print area)

I want to take screenshots by double clicking on each protected cells in the range and which leads to popup msg of protected cells. So, Screenshot will be taken place when a msg popup.

This screenshot should be copy to clipboard and saved as a jpg file at a same path of excel file with a name pattern - like Sr. No. And Time combinations (001-HHMMSS.jpg)

Once the above code runs and finished, the another protected cells should be selected by looping.

Suggeste the code to execute my task.

Thanks.

 

[Globaltechpharm]

Can anybody help me on this issue?

 

[Yongle]

Are you saying that you want a picture of every protected cell saved as a jpg?
What is in the picture - just the cell?
Exactly how does the naming work?

 

[Globaltechpharm]

Hi Yongle,

I mean I have a shhet with protected and unprotected cells. From them I want vba code to do events like double clicking on each protected cells in the range. So, whenever double click done on a protected cells, it shows a popup msg of protected cells. I need the screenshot when my pointer is on that cell and a popup messagebox. So that screenshot can be saved as jpg with a unique name like time or cell address (ex. E5) at a current excel file path.
Same thing should be repeated for each protected cells in the range.
Is it possible?

 

[Yongle]

Sounds like most of that is possible
Will update thread tomorrow including code for you to test.

 

[Globaltechpharm]

Thanks dear..
Awaiting for your response.

 

[Yongle]

Try this..
- which loops through all cells in the current print area, and if the cell is locked, selects that cell, creates an image of the visible screen area as a chart, which is then exported to a jpg file

Test the code without making any changes in a copy of your workbook
- save the workbook before running the code (required to get ActiveWorkbook.Path)

AFTER testing you may want to amend the file name string
- make sure that you only use valid characters in that string
- here are some characters to avoid
< , > , | , / , * , \ , ? , :

Place code in the sheet module
(right-click on sheet tab \ View Code \ paste into that window \ {Alt}{F11} takes you back to Excel)

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Const msg1 = "This is a protected cell" & vbCr & vbCr & "Click OK to create images of all protected cells in print area"
    Const msg2 = "Cancelled by user"
    Dim pArea As String
    pArea = Me.PageSetup.PrintArea
    
    If Target.Locked And pArea <> "" Then
        Cancel = True
        Select Case MsgBox(msg1, vbOKCancel)
            Case vbCancel:      MsgBox msg2
            Case Else:          LoopCells pArea
        End Select
    End If
End Sub

Private Sub LoopCells(pArea As String)
    Dim cel As Range, msg As String, ImageFullPath As String
    Dim fPath As String, timeStamp As String, celRef As String, fName As String
    fPath = ActiveWorkbook.Path
    timeStamp = Format(Now, "_YYYYMMDD_HHMMSS")
    msg = "Files created" & vbCr
    
    For Each cel In Range(pArea)
        If cel.Locked Then
            'build full path and message string
            cel.Activate
            celRef = cel.Address(0, 0)
            fName = celRef & timeStamp & ".jpg"
            ImageFullPath = fPath & "\" & fName
            msg = msg & vbCr & ImageFullPath
            'get screenshot
            CreateAndSaveScreenshot ImageFullPath
        End If
    Next cel
    
    Application.CutCopyMode = False
    MsgBox msg
End Sub

Private Sub CreateAndSaveScreenshot(ImageFullPath As String)
[I][COLOR=#808080]    'credit source of original procedure (now modified to dovetail with other code)
    'https://analystcave.com/excel-image-vba-save-range-workbook-image/[/COLOR][/I]
    
    Dim tmpChart As Chart, sh As Shape
'create temporary chart
    Windows(1).VisibleRange.Select
    Selection.Copy
    Me.Pictures.Paste.Select
    Set sh = Me.Shapes(Me.Shapes.Count)
    Set tmpChart = Charts.Add
    tmpChart.ChartArea.Clear
    Set tmpChart = tmpChart.Location(Where:=xlLocationAsObject, Name:=Me.Name)
    tmpChart.ChartArea.Width = sh.Width
    tmpChart.ChartArea.Height = sh.Height
    tmpChart.Parent.Border.LineStyle = 0
'Paste range as image to chart
    sh.Copy
    tmpChart.ChartArea.Select
    tmpChart.Paste
'Save chart image to file
    tmpChart.Export Filename:=ImageFullPath
'Clean up
    Me.Cells(1, 1).Select
    Me.ChartObjects(Me.ChartObjects.Count).Delete
    sh.Delete
End Sub

 

[Globaltechpharm]

Hi dear.. Thank you for your revert with suggested code.
Will check it out and let you know the outcome.

 

[Yongle]

OOPS I forgot to include the lines for sheet protection
- amend the password to match yours

Private Sub LoopCells(pArea As String)
    Dim cel As Range, msg As String, ImageFullPath As String
    Dim fPath As String, timeStamp As String, celRef As String, fName As String
    fPath = ActiveWorkbook.Path
    timeStamp = Format(Now, "_YYYYMMDD_HHMMSS")
    msg = "Files created" & vbCr
[COLOR=#ff0000]    Me.Unprotect "password"[/COLOR]
    For Each cel In Range(pArea)
        If cel.Locked Then
            'build full path and message string
            cel.Activate
            celRef = cel.Address(0, 0)
            fName = celRef & timeStamp & ".jpg"
            ImageFullPath = fPath & "\" & fName
            msg = msg & vbCr & ImageFullPath
            'get screenshot
            CreateAndSaveScreenshot ImageFullPath
        End If
    Next cel
[COLOR=#ff0000]    Me.Protect "password"[/COLOR]
    Application.CutCopyMode = False
    MsgBox msg
End Sub