Add image and resize on protected sheet

[amorales75pr]

Hi;

First I will like you to excuse me for my English cause it is not my first language. I am trying to add and image in a form so the user can click on a button and browse the computer for the image. I have add the button and a macro for temporarily unlock and lock the form and browsing for the image in the computer but because not all images are the same size, when add it some block other cells in the form.

I will like the image to be added with in a range of cells so it will always be in the same place and to have the same size always, does not matter if the are out of proportion(does not have to maintain proportion).

Thanks and this is what I have so far:

---

Sub Insert_Picture() Sheet1.Unprotect Password:="xxxxx"
Dim MyWidth As Double
Dim MyHeight As Double
Dim Image As Object
' Para definir la imagen

'----------------------------------------------------------
'- check for existing picture
If ActiveSheet.Pictures.Count > 0 Then
rsp = MsgBox("There is an existing picture. " & vbCr _
& "Ya hay una imagen. ¿Desea sustituirla?", vbYesNoCancel)
If rsp = vbCancel Then Exit Sub
If rsp = vbYes Then
ActiveSheet.Pictures(1).Delete
End If
End If
'-----------------------------------------------------------
'- get new picture
Application.Dialogs(xlDialogInsertPicture).Show
'- may not have inserted a picture
If ActiveSheet.Pictures.Count > 0 Then
'- resize
MyWidth = ActiveSheet.Range("b8:b25").Left
MyHeight = ActiveSheet.Range("b8:w8").Top
Selection.Top = 110
Selection.Left = 20
Selection.Width = 170
Selection.Height = 75

Else
MsgBox ("Ninguna imagen ha sido añadida.")
End If
Sheet1.Protect Password:="xxxxx"
End Sub

 

[BQardi]

Something like this:

Sub Insert_Picture()Sheet1.Unprotect Password:="xxxxx"
Dim MyWidth As Double
Dim MyHeight As Double
Dim Image As Object
' Para definir la imagen


'----------------------------------------------------------
'- check for existing picture
If ActiveSheet.Pictures.Count > 0 Then
rsp = MsgBox("There is an existing picture. " & vbCr _
& "Ya hay una imagen. ¿Desea sustituirla?", vbYesNoCancel)
If rsp = vbCancel Then Exit Sub
If rsp = vbYes Then
ActiveSheet.Pictures(1).Delete
End If
End If
'-----------------------------------------------------------
'- get new picture
Application.Dialogs(xlDialogInsertPicture).Show
'- may not have inserted a picture
If ActiveSheet.Pictures.Count > 0 Then
'- resize
MyWidth = ActiveSheet.Range("b8:w8").Width
MyHeight = Sheet1.Range("b8:b25").Height
Selection.Top = ActiveSheet.Range("b8").Top
Selection.Left = ActiveSheet.Range("b8").Left
Selection.Width = MyWidth
Selection.Height = MyHeight


Else
MsgBox ("Ninguna imagen ha sido añadida.")
End If
Sheet1.Protect Password:="xxxxx"
End Sub

 

[amorales75pr]

Thanks for your interest and help it almost... works for Height but does not control Width. I try using your code and changing "MyWidth = ActiveSheet.Range("b8:w8").Width" to "MyWidth = Sheet1.Range("b8:w8").Width" but id did not work either.

We are closer to the solution I believe.

 

[BQardi]

This should work. I added the LockAspectRatio = msoFalse, which should stretch the image to your desired Width and Height

Sub Insert_Picture()
Sheet1.Unprotect Password:="xxxxx"
Dim MyWidth As Double
Dim MyHeight As Double
Dim Image As Object
' Para definir la imagen




'----------------------------------------------------------
'- check for existing picture
If ActiveSheet.Pictures.Count > 0 Then
rsp = MsgBox("There is an existing picture. " & vbCr _
& "Ya hay una imagen. ¿Desea sustituirla?", vbYesNoCancel)
If rsp = vbCancel Then Exit Sub
If rsp = vbYes Then
ActiveSheet.Pictures(1).Delete
End If
End If
'-----------------------------------------------------------
'- get new picture
Application.Dialogs(xlDialogInsertPicture).Show
'- may not have inserted a picture
If ActiveSheet.Pictures.Count > 0 Then
'- resize
MyWidth = ActiveSheet.Range("b8:w8").Width
MyHeight = ActiveSheet.Range("b8:b25").Height
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = ActiveSheet.Range("b8").Top
Selection.Left = ActiveSheet.Range("b8").Left
Selection.Width = MyWidth
Selection.Height = MyHeight




Else
MsgBox ("Ninguna imagen ha sido añadida.")
End If
Sheet1.Protect Password:="xxxxx"
End Sub

 

[amorales75pr]

Yesss.... It works perfect...as it should...

Thanks for your help... I appreciate a lot.

 

[BQardi]

You're welcome. Glad I could help...