How to insert a picture's address as hyperlink to a cell?

[Sam Kuo]

I use the script below to allow user to click on a command button to open the
"Insert Picture" pop-up window and pick a picture to be inserted into a
particular merged cell.

I wonder if it's possible to also dynamically insert the picture's address
as a hyperlink to a different cell after the picture is inserted, and how?

Thanks in advance

**************
' This is a simplified version of my script, without the irrelevant lines to
this question

Sub CommandButton_Click()
Const MY_PIC As String = "MyPic"
Dim ImageCell As Range
Set ImageCell = Sheet3.Range("B10").MergeArea

ImageCell.Select

Application.Dialogs(xlDialogInsertPicture).Show
If TypeName(Selection) <> "Picture" Then Exit Sub

On Error Resume Next
ActiveSheet.Shapes(MY_PIC).Delete
On Error GoTo 0

With Selection
.Name = MY_PIC
End With
End Sub

 

[Tim Williams]

Sub Tester()
Dim v, s

v = Application.GetOpenFilename()
If v = False Then Exit Sub
If Dir(v) = "" Then Exit Sub


Set s = ActiveSheet.Pictures.Insert(v)

With s
.Width = 200
.Height = 200
.Name = "blah"
.Top = ActiveSheet.Range("B10").Top
.Left = ActiveSheet.Range("B10").Left
End With

With ActiveSheet
.Hyperlinks.Add .Range("B9"), v
End With

End Sub


Tim

 

[Sam Kuo]

Thanks again Tim

Can we have an error protection added in - so that if any non-picture file
is selected from the Open dialogue, pop-up a reminder to notify the user -
because it currently returns a "run-time error 1004".

Also, because I need to password-protect the worksheet to lock certains
cells from editing. And if I do that, the Excel then does not allow inserting
picture and returns an error 1004 at the line "Set s =
ActiveSheet.Pictures.Insert (v)". Can this be overcome?

Sam

 

[Sam Kuo]

Hi Tim,

1) I've sorted out the error handling issue with non-picture file by adding
FileFilter (which limits the acceptable file format to specified picture
files only) in the GetOpenFileName method you suggest. i.e.

v = Application.GetOpenFilename("Image Files (*.jpg; *.jpeg; *.bmp; *.tiff;
*.tif),*.jpg; *.jpeg; *.bmp; *.tiff; *.tif)")

2) But the problems with protected worksheet still trouble me...I'll
probably open a new thread if I still cannot figure out how.

Many thanks for your assistance so far

Sam

 

[Tim Williams]

shtPic.Unprotect sPassword
'code to insert pic
shtPic.Protect sPassword

Tim

 

[Sam Kuo]

Thanks Tim. But "run-time error 1004" occurs at a line (just before the sheet
protection command) that defines a range value, after adding the sheet
protection command. Here is my code:

Sub cbInsertImage_Click()
Const MY_PIC As String = "MyPic"
Dim ImageCell As Range
Dim rH As Double, rW As Double
Dim fH As Double, fW As Double
Dim fMod As Double
Dim v, s

Set ImageCell = ActiveSheet.Range("B11").MergeArea
rH = ImageCell.Height: rW = ImageCell.Width

' Go to "screen dump" input merged cell (B11:AK31)
ImageCell.Select

' Open "Open" pop-up window and allow specified image files only
v = Application.GetOpenFilename("Image Files (*.jpg; *.jpeg; *.bmp;
*.tiff; *.tif),*.jpg; *.jpeg; *.bmp; *.tiff; *.tif)")
If v = False Then Exit Sub
If Dir(v) = "" Then Exit Sub

' Unprotect sheet to allow editing (password = 1)
ActiveSheet.Unprotect (1)

' Insert selected picture
Set s = ActiveSheet.Pictures.Insert(v)

' Delete the existing picture if one exists, otherwise skip deleting and
continue next step
On Error Resume Next
ActiveSheet.Shapes(MY_PIC).Delete
On Error GoTo 0

' Size the image selection to fit within merged cell, while keeping the
images aspect ratio
fH = s.Height / rH
fW = s.Width / rW
fMod = IIf(fH > fW, fH, fW)

With s
.Left = ImageCell.Left
.Top = ImageCell.Top
.Width = .Width / fMod
.Height = .Height / fMod
.Placement = xlMoveAndSize
.Name = MY_PIC
End With

' Add picture's address as hyperlink to merged hyperlink input cell
(Cell I32:AK32)
With ActiveSheet
.Hyperlinks.Add .Range("I32").MergeArea, v
End With

' Change the font size of the inserted hyperlink to 8 and keep
horizontal alignment to left
ActiveSheet.Range("I32").MergeArea.Font.Size = 8
ActiveSheet.Range("I32").MergeArea.HorizontalAlignment = xlLeft

' Change "cbInsertImage" caption to "CHANGE IMAGE"
ActiveSheet.cbInsertImage.Caption = "CHANGE IMAGE"

' Unhide and enable "cbDeleteImage"
ActiveSheet.cbDeleteImage.Visible = True
ActiveSheet.cbDeleteImage.Enabled = True

' Add text
ActiveSheet.Range("B10") = "Click the DELETE button to remove image OR
click the CHANGE IMAGE button to select a different image"

' ****the line below invokes error 1004****
ActiveSheet.Range("B32") = "Link to the above image:"

' Protect sheet to prevent unauthorised editing (password = 1)
ActiveSheet.Protect (1)

End Sub

 

[Sam Kuo]

Tim, thanks for staying with me on this topic.

Sorry but I think I really should have asked this question in the first
instance:
Would you know how to insert a .dwg file (such as AutoCAD drawing) in Excel?

i.e. Ultimately, I'd like to show the "appearance" of a .dwg file in Excel
(whether it's inserted in Excel as .dwg or image file doesn't really matter)
together with it's address as hyperlink in a different cell.
As you can see, I'm now manually converting an AutoCAD drawing to an image
file (by taking a screenshot of the drawing and save it as an image file
using Paint) before inserting it in Excel. But this process would be
completely redundant if I could just insert a .dwg file straight into Excel...

Sam

 

[Sam Kuo]

Hi Tim

Problem solved just after I posted the questions
I record a macro, manipulate it a bit, and it all seems to work fine now
(although it now takes a few seconds to execute the sub). Run-time error 1004
also disappears somehow.

It's difficult for me coming from very little programming background. Really
appreciate you help in completing this task!

Here's the finish script in case any VBA newbie (like myself ) is
interested in:
*******
Sub cbInsertImage_Click()
Const MY_PIC As String = "MyPic"
Dim ImageCell As Range
Dim rH As Double, rW As Double
Dim fH As Double, fW As Double
Dim fMod As Double
Dim v
Dim s As OLEObject

Set ImageCell = ActiveSheet.Range("B11").MergeArea
rH = ImageCell.Height: rW = ImageCell.Width

' Go to "screen dump" input merged cell (B11:AK31)
ImageCell.Select

' Open "Open" pop-up window and show drawing files (.dwg) only
v = Application.GetOpenFilename("Drawing Files (*.dwg),*.dwg")
If v = False Then Exit Sub
If Dir(v) = "" Then Exit Sub

' Unprotect sheet to allow editing (password = 1)
ActiveSheet.Unprotect (1)

' Insert selected ACAD drawing
Set s = ActiveSheet.OLEObjects.Add(Filename:=v, Link:=False,
DisplayAsIcon:=False)

' Delete the existing picture if one exists, otherwise skip deleting and
continue next step
On Error Resume Next
ActiveSheet.OLEObjects(MY_PIC).Delete
On Error GoTo 0

' Size the image selection to fit within merged cell, while keeping the
images aspect ratio
fH = s.Height / rH
fW = s.Width / rW
fMod = IIf(fH > fW, fH, fW)

With s
.Left = ImageCell.Left
.Top = ImageCell.Top
.Width = .Width / fMod
.Height = .Height / fMod
.Placement = xlMoveAndSize
.Name = MY_PIC
End With

' Add ACAD drawing's address as hyperlink to merged hyperlink input cell
(Cell I32:AK32)
With ActiveSheet
.Hyperlinks.Add .Range("I32").MergeArea, v
End With

' Change the font size of the inserted hyperlink to 8 and keep
horizontal alignment to left
ActiveSheet.Range("I32").MergeArea.Font.Size = 8
ActiveSheet.Range("I32").MergeArea.HorizontalAlignment = xlLeft

' Change "cbInsertImage" caption to "CHANGE IMAGE"
ActiveSheet.cbInsertImage.Caption = "CHANGE IMAGE"

' Unhide and enable "cbDeleteImage"
ActiveSheet.cbDeleteImage.Visible = True
ActiveSheet.cbDeleteImage.Enabled = True

' Add text
ActiveSheet.Range("B10") = "Click the DELETE button to remove image OR
click the CHANGE IMAGE button to select a different image"
ActiveSheet.Range("B32") = "Link to the above image:"

' Protect sheet to prevent unauthorised editing (password = 1)
ActiveSheet.Protect (1)

End Sub