PasteLink - простой макрос на VBA для Excel для вставки в ячейку гипперссылки на файл в буфере обмена.

[wyfinger]

Сделал для себя небольшой скрипт - очень выручает в повседневной работе.

'
' PasteLink - простой макрос на VBA для Excel для вставки в ячейку гипперссылки
' на файл, лежащий в буфере обмена.
' 
' Для установки необходимо добавить новый модуль в шаблоне по умолчанию (PERSONAL.XLSB),
' скопировать в него данный код и повесить на удобное сочетание клавиш макрос PasleOneLinkFromClipdoard()
' (я использую сочетание Ctrl+E).
'
' При вызове макроса (нажатии выбранного сочетания клавиш) в текущую ячейку будет вставлена
' гиперссылка (если в ячейке есть текст - добавлена ссылка, если нет - будет вставлен
' путь к файлу в буфере и гиперссылка.
'
' Wyfinger (wyfinger@yandex.ru)
' 

Attribute VB_Name = "PasteLink"
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal uFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal drop_handle As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long

Private Const CF_HDROP As Long = 15

Private Function GetFiles(ByRef fileCount As Long) As String()
'
' Получить имена файлов, скопированнных в буфер обмена
'
    Dim hDrop As Long, i As Long
    Dim aFiles() As String, sFileName As String * 1024

    fileCount = 0

    If Not CBool(IsClipboardFormatAvailable(CF_HDROP)) Then Exit Function
    If Not CBool(OpenClipboard(0&)) Then Exit Function

    hDrop = GetClipboardData(CF_HDROP)
    If Not CBool(hDrop) Then GoTo done

    fileCount = DragQueryFile(hDrop, -1, vbNullString, 0)

    ReDim aFiles(fileCount - 1)
    For i = 0 To fileCount - 1
        DragQueryFile hDrop, i, sFileName, Len(sFileName)
        aFiles(i) = Left$(sFileName, InStr(sFileName, vbNullChar) - 1)
    Next
    GetFiles = aFiles
done:
    CloseClipboard
End Function

Private Function GetFilenameFromPath(ByVal strPath As String) As String
'
' Получение имени файла из имени и пути
'
    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
        GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End If
End Function

Sub PasleOneLinkFromClipdoard()
Attribute PasleOneLinkFromClipdoard.VB_ProcData.VB_Invoke_Func = "e\n14"
'
' Вставить в текущую ячейку гиперссылку на файл/каталог, скопированный в буфер обмена, если он один
'
    Dim A() As String, fileCount As Long, i As Long
    A = GetFiles(fileCount)
    If (fileCount <> 1) Then
        MsgBox "Эй, чувак! Нет файлов или каталогов в буфере обмена или их больше одного."
    End If
    
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=A(0) ', TextToDisplay:=GetFilenameFromPath(a(0))
End Sub

Вопросы и замечания принимаются.

[staniiislav]

у меня ругается вот на эти строки:

Attribute VB_Name = "PasteLink"
Attribute PasleOneLinkFromClipdoard.VB_ProcData.VB_Invoke_Func = "e\n14"

[doober]

staniiislav
А если скопировать все в текстовик и сохранить как PasteLink.bas.
И потом этот файл импортировать в проект VBA
Все заработает

[staniiislav]

doober
Понятно . Я пользуюсь VBA только в экселе, отдельно программы VBA не устанавливал... Да и вообще я нуб в VBA

[wyfinger]

Выложил этот макрос на гитхабе: https://github.com/wyfinger/Excel_PasteLink.