Double click to insert picture within protected worksheet

Jason1H · Oct 2, 2021

Good Morning.

I have a worksheet set up with some code via BeforeDoubleClick to insert/remove "✓" in certain cells. Below is the current code to do so. It works flawlessly. I also have the worksheet protected so my users can not alter the layout etc...

VBA Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Sheet1.Unprotect "8unch2015@"
    If Not Intersect(Target, Range("f29,j29,n29,H30,l30,p30,i31,m31,q31,i32,m32,q32")) Is Nothing Then
        Application.EnableEvents = False
        If ActiveCell.Value = ChrW(&H2713) Then
            ActiveCell.ClearContents
        Else
            ActiveCell.Value = ChrW(&H2713)
        End If
        Cancel = True
    End If
    Application.EnableEvents = True
       Range("f29,j29,n29,H30,l30,p30,i31,m31,q31,i32,m32,q32").HorizontalAlignment = xlCenter
    Sheet1.Protect "8unch2015@"
 End Sub

Is there a way to add a sub-routine within the BeforeDoubleClick function to allow my users to insert a picture in a completely different cell and save the picture with the file and not the link? Or do we need to use a different function like BeforeRightClick? I have cells AJ8:BA13, this size is not written in stone and may alter based on readability of picture. However this merged cell is where I would like to have the users insert the picture. I do not know the file path layout of where my users save the pictures on their computers. So this will need to be an undefined file path. The inserted picture should have the aspect ratio locked to maintain readability. I've attached a screen shot of the sheet as the mini sheet upload function does not display the cell sizing the same. Cell width and height are both set to 0.38cm in my file. Is there a way to upload the file itself. If there is a better way to write the insert/remove code, by all means I am open to suggestions as I am new to the coding.

DCS# 7.3.16.1 UPS Checklist.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Z

AA

AB

AC

AD

AE

AF

AG

AH

AI

AJ

AK

AL

AM

AN

AO

AP

AQ

AR

AS

AT

AU

AV

AW

AX

AY

AZ

BA

3

Uniterruptible Power Supply (UPS) Inspection

4

Date:

10/02/2021

Client:

Paramount Resouces

Client Job No.:

N/A

5

Job No.:

21-26165

Project:

Mult-Well Pad Expansion

Location:

5-16 West

6

7

UPS Description

8

Building No.:

Circuit No.:

Pic of Name Plate Here (optional)

9

Equipment Tag:

AC Voltage:

10

Make:

AC Current:

11

Model no.:

AC Phase:

12

Serial No.:

DC Voltage:

13

Distribution Panel:

DC Current:

14

15

Visual Inspection

Initials

16

Has the UPS nameplate been checked against approved vendor drawings and project specifications and details

17

Is the equipment CSA approved?

18

Circuit breaker is sized in accordance with job specification and codes

19

Wire is sized to carry rated amperage of the circuit breaker

20

Perform visual checks of UPS systems major components (Rectifier, Inverter, Static, and Manual Transfer Switch)

21

for proper installation, grounding, wiring and connections

22

UPS circuit breaker is identified correctly on lighting panel schedule

23

UPS has been terminated correctly as per specification and codes and connections are secured

24

UPS transformers are sized as per job specification and codes

25

Check battery as per Battery Test Report, DCS# 7.3.16.2

26

If there is any missing items or deficiencies, are they listed on the E & I Punch List DCS# 7.3.2.3 as well as recorded in the test results below?

27

28

Test

29

AC Fail:

Yes

✓

No

N/A

DC Voltage Displayed:

Float Voltage:

30

Rectifier Fail:

Yes

No

N/A

DC Voltage Measured:

Start Charge Voltage:

31

DC Low Voltage:

Yes

No

N/A

DC Current Displayed:

Stop Charge Voltage:

32

End of Discharge:

Yes

No

N/A

DC Current Measured:

Sheet1

Cell Formulas
Range	Formula
E4	E4	=TODAY()
E5	E5	='C:\Users\jason.hoetmer\Desktop\QA Master Template\Section #1 (Pre Job)\[DCS# 7.3.1 ITP.xlsx]Sheet1'!$E$5:$M$5
R4	R4	='C:\Users\jason.hoetmer\Desktop\QA Master Template\Section #1 (Pre Job)\[DCS# 7.3.1 ITP.xlsx]Sheet1'!$R$4:$AF$4
R5	R5	='C:\Users\jason.hoetmer\Desktop\QA Master Template\Section #1 (Pre Job)\[DCS# 7.3.1 ITP.xlsx]Sheet1'!$R$5:$AF$5
AM4	AM4	='C:\Users\jason.hoetmer\Desktop\QA Master Template\Section #1 (Pre Job)\[DCS# 7.3.1 ITP.xlsx]Sheet1'!$AM$4:$BA$4
AM5	AM5	='C:\Users\jason.hoetmer\Desktop\QA Master Template\Section #1 (Pre Job)\[DCS# 7.3.1 ITP.xlsx]Sheet1'!$AM$5:$BA$5

cmowla · Oct 3, 2021

It's possible to do everything you want. (You don't have to use right click.) If you have any questions, ask away, but the link can be a url as well (not just a file path on the hard drive) and the image will stay in the file. (I assume that the picture slot is the merged cell R29. But if not, please change it.)

Update your sheet module double click sub to:

VBA Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Sheet1.Unprotect "8unch2015@"
    If Not Intersect(Target, Range("f29,j29,n29,H30,l30,p30,i31,m31,q31,i32,m32,q32")) Is Nothing Then
        Application.EnableEvents = False
        If ActiveCell.Value = ChrW(&H2713) Then
            ActiveCell.ClearContents
        Else
            ActiveCell.Value = ChrW(&H2713)
        End If
        Cancel = True
    ElseIf Target.address = "$R$29"
        Cancel = True
        Call PictureInsert(GetImageFilePath) 'Will put the picture on top of the active cell.
    Else:
        'Do nothing
    End If
    Application.EnableEvents = True
       Range("f29,j29,n29,H30,l30,p30,i31,m31,q31,i32,m32,q32").HorizontalAlignment = xlCenter

    Sheet1.Protect "8unch2015@"
End Sub

And add these new subs to a standard module:

VBA Code:

Sub Test__PictureInsert()
Call PictureInsert("https://www.mrexcel.com/board/styles/mrexcel/mrexcel-logo2x.png")
End Sub
Sub PictureInsert(filePathOrUrl As String)
On Error GoTo User_Cancelled_Or_File_Not_Found
'https://docs.microsoft.com/en-us/office/vba/api/excel.shapes.addpicture
Set shp = ActiveSheet.Shapes.AddPicture(filePathOrUrl, False, True, 100, 100, 70, 70)
With shp
    .Name = "Pic" & Replace(ActiveCell.Address, "$", "")
    .ScaleHeight Factor:=1, RelativeToOriginalSize:=True
    .ScaleWidth Factor:=1, RelativeToOriginalSize:=True
    .Left = ActiveCell.Left + 0
    .Top = ActiveCell.Top + 0
End With
User_Cancelled_Or_File_Not_Found:
End Sub


Sub Test__GetFilePath()
MsgBox GetImageFilePath
End Sub
Function GetImageFilePath()
'code for filters from here https://wellsr.com/vba/2018/excel/vba-filedialog-open-msofiledialogopen/
'code for everthing else, from here https://stackoverflow.com/questions/12687536/how-to-get-selected-path-and-name-of-the-file-opened-with-file-dialog
Dim selected_File As String
With Application.FileDialog(msoFileDialogOpen)
    .Title = "Choose File"
    .AllowMultiSelect = multiple_File_Selection
    .Filters.Clear
    .Filters.Add "Image", "*.jpg, *.jpeg, *.gif, *.png, *.bmp"

    'If the user cancelled,
    If .Show <> -1 Then Exit Function
    GetImageFilePath = .SelectedItems(1)
End With

End Function

Jason1H · Oct 3, 2021

Afternoon *cmowla. Thank you for the effort you put into this for me. I cut and pasted both sets of code as you suggested. However I am getting a syntax error in one line

VBA Code:

ElseIf Target.address = "$R$29"

I had to add a "then" statement at the end of this line to get rid of the syntax error. I also changed the absolute cell of R29 to that of AJ8. When I double click on AJ8 I do not get the syntax error now but the file open prompt does not show up. I see there are multiple subs in the module. Are these alternate options that I need to disable one or two of the three for the third to work? Should the parenthesis in the following line be before the "as string" not after?

VBA Code:

Sub PictureInsert(filePathOrUrl As String)

cmowla · Oct 3, 2021

Sorry about forgetting the Then (It somehow got lost in translation when copying the code from my Workbook to my post!)

Jason1H said:
Should the parenthesis in the following line be before the "as string" not after?

VBA Code:

Sub PictureInsert(filePathOrUrl As String)

No, that's a Sub, not a Function.

Your problem probably is you need to have $AJ$8 not AJ8 in the IF statement. (The $ signs need to be there.)

VBA Code:

 ElseIf Target.address = "$AJ$8" Then

Jason1H · Oct 4, 2021

Morning. I double check the for the $ and they are there. I only get the hour glass showing up momentarily when I double click the cell.

cmowla · Oct 4, 2021

Jason1H said:
I only get the hour glass showing up momentarily when I double click the cell.

Thanks for letting me know

How about try the following and let me know if it works. If so, I will explain the options you have regarding the password protection and more.

Replace the entire double click sub code with the following:

VBA Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim passwrd As String
passwrd = "8unch2015@"

Call Protect_Sheet(, passwrd)
    If Not Intersect(Target, Range("f29,j29,n29,H30,l30,p30,i31,m31,q31,i32,m32,q32")) Is Nothing Then
        Cancel = True
        Application.EnableEvents = False
        If ActiveCell.Value = ChrW(&H2713) Then
            ActiveCell.ClearContents
        Else
            ActiveCell.Value = ChrW(&H2713)
        End If
        Application.EnableEvents = True
    ElseIf Target.Address = "$AJ$8" Then
        Cancel = True
        Application.EnableEvents = True
        Call Delete_Previous_Image_On_This_Cell_If_It_Exists(ActiveSheet.Name, Replace(Target.Address, "$", ""))
        Call PictureInsert(GetImageFilePath) 'Will put the picture on top of the cell double clicked on.
    Else:
        '(Do nothing)
    End If

Range("f29,j29,n29,H30,l30,p30,i31,m31,q31,i32,m32,q32").HorizontalAlignment = xlCenter
Call Protect_Sheet(, passwrd)
Application.EnableEvents = True

End Sub

And also replace all of the previous normal module code that I gave you with the following. (I added two more sub.)

VBA Code:

Sub Test__PictureInsert()
Call PictureInsert("https://www.mrexcel.com/board/styles/mrexcel/mrexcel-logo2x.png")
End Sub
Sub PictureInsert(filePathOrUrl As String)
'On Error GoTo User_Cancelled_Or_File_Not_Found
'https://docs.microsoft.com/en-us/office/vba/api/excel.shapes.addpicture
Set shp = ActiveSheet.Shapes.AddPicture(filePathOrUrl, False, True, 100, 100, 70, 70)
With shp
    .Name = "Pic" & Replace(ActiveCell.Address, "$", "")
    .ScaleHeight Factor:=1, RelativeToOriginalSize:=True
    .ScaleWidth Factor:=1, RelativeToOriginalSize:=True
    .Left = ActiveCell.Left + 0
    .Top = ActiveCell.Top + 0
End With
User_Cancelled_Or_File_Not_Found:
End Sub


Sub Test__GetFilePath()
MsgBox GetImageFilePath
End Sub
Function GetImageFilePath()
'code for filters from here https://wellsr.com/vba/2018/excel/vba-filedialog-open-msofiledialogopen/
'code for everthing else, from here https://stackoverflow.com/questions/12687536/how-to-get-selected-path-and-name-of-the-file-opened-with-file-dialog
Dim selected_File As String
With Application.FileDialog(msoFileDialogOpen)
    .title = "Choose File"
    .AllowMultiSelect = multiple_File_Selection
    .Filters.Clear
    .Filters.Add "Image", "*.jpg, *.jpeg, *.gif, *.png, *.bmp"

    'If the user cancelled,
    If .Show <> -1 Then Exit Function
    GetImageFilePath = .SelectedItems(1)
End With

End Function


Sub Test__Delete_Previous_Image_On_This_Cell_If_It_Exists()
Call Delete_Previous_Image_On_This_Cell_If_It_Exists(ActiveSheet.Name, ActiveCell.Address)
End Sub
Sub Delete_Previous_Image_On_This_Cell_If_It_Exists(sheetName As String, rangeAddress As String)
On Error Resume Next
Sheets(sheetName).Shapes.Range(Array("Pic" & Replace(rangeAddress, "$", ""))).Delete
End Sub

Sub Test__Protect_Sheet()
Call Protect_Sheet(, "8unch2015@")
End Sub
Sub Protect_Sheet(Optional ByVal sheetName As String = "", Optional ByVal pswd As String = "")
If sheetName = "" Then sheetName = ActiveSheet.Name

Sheets(sheetName).Protect _
Password:=pswd, _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
UserInterFaceOnly:=True, _
AllowFormattingCells:=False, _
AllowFormattingColumns:=False, _
AllowFormattingRows:=False, _
AllowInsertingColumns:=False, _
AllowInsertingRows:=False, _
AllowInsertingHyperlinks:=False, _
AllowDeletingColumns:=False, _
AllowDeletingRows:=False, _
AllowSorting:=False, _
AllowFiltering:=False, _
AllowUsingPivotTables:=False

'Defaults  'https://docs.microsoft.com/en-us/office/vba/api/excel.worksheet.protect
'Sheets(sheetName).Protect _
'Password:=pswd, _
'DrawingObjects:=True, _
'Contents:=True, _
'Scenarios:=True, _
'UserInterFaceOnly:=True, _
'AllowFormattingCells:=False, _
'AllowFormattingColumns:=False, _
'AllowFormattingRows:=False, _
'AllowInsertingColumns:=False, _
'AllowInsertingRows:=False, _
'AllowInsertingHyperlinks:=False, _
'AllowDeletingColumns:=False, _
'AllowDeletingRows:=False, _
'AllowSorting:=False, _
'AllowFiltering:=False, _
'AllowUsingPivotTables:=False

End Sub

Jason1H · Oct 6, 2021

Afternoon, I had to unmerge cells AJ8:BA13 in order for the code to work. The picture is only being sized as follows AJ8:AN12 instead of AJ8:BA13, with aspect ration still being considered of course. The insert/remove of check marks still works too.

Jason1H · Oct 6, 2021

Playing around with your both your first and second code rendition, both require cells AJ8:BA13 to be unmerged. Once unmerged picture insert works for cell AJ8.

cmowla · Oct 6, 2021

Jason1H said:
Playing around with your both your first and second code rendition, both require cells AJ8:BA13 to be unmerged. Once unmerged picture insert works for cell AJ8.

If that's the case (I seemed to think about every possibility but that . . . ), this should work even if the cells are merged as you want. But they have to double click towards the center of the merged cell block, not near the borders, otherwise it won't work.

VBA Code:

ElseIf Target.Address = "$AJ$8:$BA$13" Then

Also, I commented out the On Error line in the sub in my second revision (which I recommend you use instead of the original code . . . for potential reasons that I will state in the rest of this post):

VBA Code:

Sub PictureInsert(filePathOrUrl As String)
'On Error GoTo User_Cancelled_Or_File_Not_Found

so please change that part to (uncomment it):

VBA Code:

Sub PictureInsert(filePathOrUrl As String)
On Error GoTo User_Cancelled_Or_File_Not_Found

so that if you/they press the escape key, it will not throw an error message. (I uncommented this in the second revision to help you see what the error message it was giving was, but it turned out not to help. But regardless, we need to put that On Error line of code back in!)

The reason I added in the two new subs in the second revision (and may have improved something in the original code, I can't recall right now because I did this two days ago) is because of the following.

The reason I added:

VBA Code:

Sub Delete_Previous_Image_On_This_Cell_If_It_Exists(sheetName As String, rangeAddress As String)
On Error Resume Next
Sheets(sheetName).Shapes.Range(Array("Pic" & Replace(rangeAddress, "$", ""))).Delete
End Sub

is because if they keep inserting an image, VBA is just going to keep putting the new image on top of the old one. Since these are merged cells, the image may not fit in the entire area, so they do have a chance to double click on the cell (if the image is "not in the way") in order for the image to be deleted and replaced with a new image. But if you want to have the only power to delete previously inserted images, then don't use it. (And if you do want to use this, but the images that they insert fit the merged area "too well" . . . that they cannot possibly double click on a part of it to erase the previous image . . . or insert a new one for that matter . . . they you "simply" add another cell available for double click in the mix which deletes the previous image that was placed.)

But this brings me to the main reason I added:

VBA Code:

Sub Protect_Sheet(Optional ByVal sheetName As String = "", Optional ByVal pswd As String = "")

These are the specific settings that you can use to lock the sheet. Specifically, if you want the ability to manually move/delete an image that was inserted, you can if you can just change DrawingObjects:=False, for example. And you can customize the other settings.

VBA Code:

Sheets(sheetName).Protect _
Password:=pswd, _
DrawingObjects:=True, _
Contents:=True, _

In fact, these list of parameters are the same as those in the window that you have to input a password in to lock the sheet.

With the exception of the first two (that you see checked in the above image). That is, Select locked cells and Select unlocked cells are not in that sub Those are mysteriously separate from where I got that code (see the commented url). So just for completeness, I modified that sub so that you can change to encompass all checkboxes. (For another project, though. The setting that I have it at now is the default, which is the only one that will work for this project!) Note that I have a copy of all of that code commented, as that's the defaults that you see in the box. (And currently I have all live code as the defaults too.) You can experiment with turning True to False and False to True on the unobvious parameters to see how they affect the protected sheet if you will.

VBA Code:

Sub Test__Protect_Sheet()
Call Protect_Sheet(, "8unch2015@")
End Sub
Sub Protect_Sheet(Optional ByVal sheetName As String = "", Optional ByVal pswd As String = "")
If sheetName = "" Then sheetName = ActiveSheet.Name

With Sheets(sheetName)
    .EnableSelection = xlNoRestrictions ''Both Select locked cells' AND 'Select unlocked cells' checked.
    '.EnableSelection = xlNoSelection ''Both Select locked cells' AND 'Select unlocked cells' UNchecked.
    '.EnableSelection = xlUnlockedCells ''Select locked cells UNchecked', 'Select unlock cells' checked.
    .Protect _
    Password:=pswd, _
    DrawingObjects:=True, _
    Contents:=True, _
    Scenarios:=True, _
    UserInterFaceOnly:=True, _
    AllowFormattingCells:=False, _
    AllowFormattingColumns:=False, _
    AllowFormattingRows:=False, _
    AllowInsertingColumns:=False, _
    AllowInsertingRows:=False, _
    AllowInsertingHyperlinks:=False, _
    AllowDeletingColumns:=False, _
    AllowDeletingRows:=False, _
    AllowSorting:=False, _
    AllowFiltering:=False, _
    AllowUsingPivotTables:=False
End With

'Defaults
'https://docs.microsoft.com/en-us/office/vba/api/excel.xlenableselection
'https://docs.microsoft.com/en-us/office/vba/api/excel.worksheet.protect
'With Sheets(sheetName)
'    .EnableSelection = xlNoRestrictions ''Both Select locked cells' AND 'Select unlocked cells' checked.
'    '.EnableSelection = xlNoSelection ''Both Select locked cells' AND 'Select unlocked cells' UNchecked.
'    '.EnableSelection = xlUnlockedCells 'Select locked cells UNchecked.
'    .Protect _
'    Password:=pswd, _
'    DrawingObjects:=True, _
'    Contents:=True, _
'    Scenarios:=True, _
'    UserInterFaceOnly:=True, _
'    AllowFormattingCells:=False, _
'    AllowFormattingColumns:=False, _
'    AllowFormattingRows:=False, _
'    AllowInsertingColumns:=False, _
'    AllowInsertingRows:=False, _
'    AllowInsertingHyperlinks:=False, _
'    AllowDeletingColumns:=False, _
'    AllowDeletingRows:=False, _
'    AllowSorting:=False, _
'    AllowFiltering:=False, _
'    AllowUsingPivotTables:=False
'End With

End Sub

cmowla · Oct 6, 2021

Jason1H said:
Afternoon, I had to unmerge cells AJ8:BA13 in order for the code to work. The picture is only being sized as follows AJ8:AN12 instead of AJ8:BA13, with aspect ration still being considered of course. The insert/remove of check marks still works too.

I forgot to say afternoon to you also in my first post, but better late than never!

But anyway, please see the following lines in the image insert sub. You can change the settings there. If you have any questions, I can help you wrestle with it to make it work for your needs. (I have the + 0 to show that you can add a decimal to change where the image is centered. .ScaleHieght and .ScaleWidth can be increased for your case.)

VBA Code:

    .ScaleHeight Factor:=1, RelativeToOriginalSize:=True
    .ScaleWidth Factor:=1, RelativeToOriginalSize:=True
    .Left = ActiveCell.Left + 0
    .Top = ActiveCell.Top + 0

In addition,

cmowla said:
so they do have a chance to double click on the cell (if the image is "not in the way") in order for the image to be deleted and replaced with a new image. But if you want to have the only power to delete previously inserted images, then don't use it. (And if you do want to use this, but the images that they insert fit the merged area "too well" . . . that they cannot possibly double click on a part of it to erase the previous image . . . or insert a new one for that matter . . . they you "simply" add another cell available for double click in the mix which deletes the previous image that was placed.)

I didn't think it through, as with its current implementation, the code to insert the image is going to name the image/shape the wrong thing that the delete image in selected cell sub won't work because it's searching for just the name of the top-left cell in the merged area. The following revision will work for all situations, regardless of whether you choose to put the image into a single cell or a merged area:

So "in short", to make this easy. Consider this Revision 3. (This is all of the up-to-date code.)

In Sheet Code Module:

VBA Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim passwrd As String
passwrd = "8unch2015@"

Call Protect_Sheet(, passwrd)
    If Not Intersect(Target, Range("f29,j29,n29,H30,l30,p30,i31,m31,q31,i32,m32,q32")) Is Nothing Then
        Cancel = True
        Application.EnableEvents = False
        If ActiveCell.Value = ChrW(&H2713) Then
            ActiveCell.ClearContents
        Else
            ActiveCell.Value = ChrW(&H2713)
        End If
        Application.EnableEvents = True
    ElseIf Target.Address = "$AJ$8:$BA$13" Then
        Cancel = True
        Application.EnableEvents = True
        Call Delete_Previous_Image_On_This_Cell_If_It_Exists(ActiveSheet.Name, Replace(Target.Address, "$", ""))
        Call PictureInsert(GetImageFilePath) 'Will put the picture on top of the cell double clicked on.
    Else:
        '(Do nothing)
    End If

Range("f29,j29,n29,H30,l30,p30,i31,m31,q31,i32,m32,q32").HorizontalAlignment = xlCenter
Call Protect_Sheet(, passwrd)
Application.EnableEvents = True

End Sub

In a standard code module:

VBA Code:

Option Explicit

Sub Test__PictureInsert()
Call PictureInsert("https://www.mrexcel.com/board/styles/mrexcel/mrexcel-logo2x.png")
End Sub
Sub PictureInsert(filePathOrUrl As String)
On Error GoTo User_Cancelled_Or_File_Not_Found
'https://docs.microsoft.com/en-us/office/vba/api/excel.shapes.addpicture
Set shp = ActiveSheet.Shapes.AddPicture(filePathOrUrl, False, True, 100, 100, 70, 70)
With shp
    .Name = "Pic" & Replace(ActiveCell.MergeArea.Address, "$", "")
'    .Name = "Pic" & Replace(ActiveCell.Address, "$", "")
    .ScaleHeight Factor:=1, RelativeToOriginalSize:=True
    .ScaleWidth Factor:=1, RelativeToOriginalSize:=True
    .Left = ActiveCell.Left + 0
    .Top = ActiveCell.Top + 0
End With
User_Cancelled_Or_File_Not_Found:
End Sub


Sub Test__GetFilePath()
MsgBox GetImageFilePath
End Sub
Function GetImageFilePath()
'code for filters from here https://wellsr.com/vba/2018/excel/vba-filedialog-open-msofiledialogopen/
'code for everthing else, from here https://stackoverflow.com/questions/12687536/how-to-get-selected-path-and-name-of-the-file-opened-with-file-dialog
Dim selected_File As String
With Application.FileDialog(msoFileDialogOpen)
    .title = "Choose File"
    .AllowMultiSelect = multiple_File_Selection
    .Filters.Clear
    .Filters.Add "Image", "*.jpg, *.jpeg, *.gif, *.png, *.bmp"

    'If the user cancelled,
    If .Show <> -1 Then Exit Function
    GetImageFilePath = .SelectedItems(1)
End With

End Function


Sub Test__Delete_Previous_Image_On_This_Cell_If_It_Exists()
Call Delete_Previous_Image_On_This_Cell_If_It_Exists(ActiveSheet.Name, ActiveCell.Address)
End Sub
Sub Delete_Previous_Image_On_This_Cell_If_It_Exists(sheetName As String, rangeAddress As String)
On Error Resume Next
Sheets(sheetName).Shapes.Range(Array("Pic" & Replace(rangeAddress, "$", ""))).Delete
End Sub


Sub Test__Protect_Sheet()
Call Protect_Sheet(, "8unch2015@")
End Sub
Sub Protect_Sheet(Optional ByVal sheetName As String = "", Optional ByVal pswd As String = "")
If sheetName = "" Then sheetName = ActiveSheet.Name

With Sheets(sheetName)
    .EnableSelection = xlNoRestrictions ''Both Select locked cells' AND 'Select unlocked cells' checked.
    '.EnableSelection = xlNoSelection ''Both Select locked cells' AND 'Select unlocked cells' UNchecked.
    '.EnableSelection = xlUnlockedCells ''Select locked cells UNchecked', 'Select unlock cells' checked.
    .Protect _
    Password:=pswd, _
    DrawingObjects:=True, _
    Contents:=True, _
    Scenarios:=True, _
    UserInterFaceOnly:=True, _
    AllowFormattingCells:=False, _
    AllowFormattingColumns:=False, _
    AllowFormattingRows:=False, _
    AllowInsertingColumns:=False, _
    AllowInsertingRows:=False, _
    AllowInsertingHyperlinks:=False, _
    AllowDeletingColumns:=False, _
    AllowDeletingRows:=False, _
    AllowSorting:=False, _
    AllowFiltering:=False, _
    AllowUsingPivotTables:=False
End With

'Defaults
'https://docs.microsoft.com/en-us/office/vba/api/excel.xlenableselection
'https://docs.microsoft.com/en-us/office/vba/api/excel.worksheet.protect
'With Sheets(sheetName)
'    .EnableSelection = xlNoRestrictions ''Both Select locked cells' AND 'Select unlocked cells' checked.
'    '.EnableSelection = xlNoSelection ''Both Select locked cells' AND 'Select unlocked cells' UNchecked.
'    '.EnableSelection = xlUnlockedCells 'Select locked cells UNchecked.
'    .Protect _
'    Password:=pswd, _
'    DrawingObjects:=True, _
'    Contents:=True, _
'    Scenarios:=True, _
'    UserInterFaceOnly:=True, _
'    AllowFormattingCells:=False, _
'    AllowFormattingColumns:=False, _
'    AllowFormattingRows:=False, _
'    AllowInsertingColumns:=False, _
'    AllowInsertingRows:=False, _
'    AllowInsertingHyperlinks:=False, _
'    AllowDeletingColumns:=False, _
'    AllowDeletingRows:=False, _
'    AllowSorting:=False, _
'    AllowFiltering:=False, _
'    AllowUsingPivotTables:=False
'End With

End Sub

Double click to insert picture within protected worksheet

Jason1H

New Member

Excel Facts

cmowla

Well-known Member

Jason1H

New Member

cmowla

Well-known Member

Jason1H

New Member

cmowla

Well-known Member

Jason1H

New Member

Jason1H

New Member

cmowla

Well-known Member

cmowla

Well-known Member

Similar threads

Forum statistics

Share this page

Double click to insert picture within protected worksheet

New Member

Excel Facts

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

New Member

Well-known Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock