CODEWITHSUNDEEP
excelvbahyperlink
Waleed
Waleed

Reputation: 919

Adding a custom Right_click menu, to open hyperlinks (.Doc .pdf .Xls .Jpg .Zip , extension files) using VBA or API methods

With regarding to this question Link
So, instead of the normal way of clicking on hyperlink, I need the following:
1- add a custom right_click menu, to open hyperlinks using VBA methods.
2- The document in discussion are (.Doc .pdf .Xls .Jpg .Zip extension files) to avoid any warning messages raised by hyperlink clicking.
3- if possible that custom menu appears only while right click on specific columns.
4- if possible the command of open the document appears on the main right_click menu (not as a sub menu).
5- using right-click to open multiple Hyperlinks (surely,each cell will contain one Hyperlink)

Private Sub Workbook_Open()
 
    Dim MyMenu As Object
 
    Set MyMenu = Application.ShortcutMenus(xlWorksheetCell) _
        .MenuItems.AddMenu("Open document", 1)
 
    With MyMenu.MenuItems
        .Add "MyMacro1", "MyMacro1", , 1, , ""
    End With
 
    Set MyMenu = Nothing
 
End Sub

Upvotes: 0

Views: 270

Answers (1)

FaneDuru
FaneDuru

Reputation: 42236

Please, try using the next solution:

  1. Copy the next event code in ThisWorkbook code module. If you already use Open event, include in it the single code line from below. It will at a control ("Open document") in the format cell context menu:
Private Sub Workbook_Open()
   Application.ShortcutMenus(xlWorksheetCell).MenuItems.Add "Open document", "OpenDocument", , 1, , ""
End Sub

Take also care of eliminating the option from the context menu:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   Application.ShortcutMenus(xlWorksheetCell).MenuItems("Open document").Delete
End Sub
  1. Copy the called Sub code in a standard module:
Sub OpenDocument()
    If Selection.Columns.count > 1 Then Exit Sub
    Dim cel As Range, El, arrCel, objShell As Object
    
    Set objShell = CreateObject("Shell.Application")
    For Each cel In Selection.cells
        If cel.Hyperlinks.count > 0 Then
            objShell.Open (cel.Hyperlinks(1).address)
        Else
            arrCel = Split(cel.Value, vbLf)
            For Each El In arrCel
                objShell.Open (El)
            Next El
        End If
    Next cel
End Sub

Edited:

This is a new version using ShellExecute, which (maybe) will be able to open the document in the default application:

Sub OpenDocument() 'ShellExecute
    If Selection.Columns.count > 1 Then Exit Sub
    Dim cel As Range, El, arrCel
    
    For Each cel In Selection.cells
        If cel.Hyperlinks.count > 0 Then
            ShellExecute 0, "open", (cel.Hyperlinks(1).address), "", "", 1
        Else
            arrCel = Split(cel.Value, vbLf)
            For Each El In arrCel
                ShellExecute 0, "open", (El), "", "", 1
            Next El
        End If
    Next cel
End Sub

The necessary API declaration (to be placed on top of the module where the above Sub exists:

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As LongPtr, _
        ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
        ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr

The above declaration is for 64 bit installations. It can be easily adapted to work for 32 bit, too, but let us see that it does what you need...

Upvotes: 2

Related Questions