Create HyperlinkObject on Sheet

The following code will help you create a drawing object on the sheet and the location, url, and link name can be customised as user will input those details.

– Selva V Pasupathy, HSBC Global Resourcing, Hyderabad1

Option Explicit
Private myCell As Range
Private myLeft, myTop, myWidth, myHeight
'     ________________________________________________________________________________
'     Written by  :        Selva V Pasupathy
'     Description :        The following macro will help you create 
'                              a hyperlink object for you and link that 
'                              object to url that you want.
'     site        : 
'     ________________________________________________________________________________

Sub CreateMenuButton_link()
   Set myCell = Application.InputBox( _
    prompt:="Select a cell", Type:=8)
    myLeft = ActiveSheet.Range(myCell.Address).Left
    myTop = Range(myCell.Address).Top
    myWidth = Range(myCell.Address).Width
    myHeight = Range(myCell.Address).Height
    ActiveSheet.Shapes.AddShape( _
            msoShapeFlowchartTerminator, _
            myLeft, _
            myTop, _
            myWidth, _
            myHeight _
    Selection.Characters.Text = Link_Caption
    ActiveSheet.Hyperlinks.Add Anchor:= _
            Selection.ShapeRange.Item(1), _
    With Selection
        .Font.Name = "Arial"
        .Font.Size = 8
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .ReadingOrder = xlContext
        .Orientation = xlHorizontal
        .AutoSize = False
    End With
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Line.Visible = msoFalse
    On Error Resume Next
    ActiveSheet.Cells(1, 1).Select
End Sub
Function Link_Caption() As String
   Link_Caption = Application.InputBox("Enter the caption for the link")
End Function
Function Link_Url() As String
   Link_Url = Application.InputBox("Enter url for the link")
   If Left(UCase$(Link_Url), 7)  "HTTP://" Then
      MsgBox "Plesae enter a valid URL that starts with <> "
      GoTo Url_Again
   End If
End Function


Leave a Reply

Please log in using one of these methods to post your comment: Logo

You are commenting using your account. Log Out /  Change )

Google+ photo

You are commenting using your Google+ account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )


Connecting to %s

%d bloggers like this: