Double click to insert picture within protected worksheet

[Jason1H]

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

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]

(I wish the 10 minute edit limit was 15 minutes. I would have probably had at least a dozen fewer posts than I do now if that was the case.)

The sheet code module's code presented in the previous post is fine, but when I "decided" to finally put in Option Explicit at the beginning of the code in the standard module, I got two variable declaration errors. So, again, for sake of simplicity, consider this Revision 4!

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
With ActiveSheet.Shapes.AddPicture(filePathOrUrl, False, True, 100, 100, 70, 70)
    .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 = False
    .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