'
' PasteLink - простой макрос на VBA для Excel для вставки в ячейку гипперссылки
' на файл, лежащий в буфере обмена.
'
' Для установки необходимо добавить новый модуль в шаблоне по умолчанию (PERSONAL.XLSB),
' скопировать в него данный код и повесить на удобное сочетание клавиш макрос PasleOneLinkFromClipdoard()
' (я использую сочетание Ctrl+E).
'
' При вызове макроса (нажатии выбранного сочетания клавиш) в текущую ячейку будет вставлена
' гиперссылка (если в ячейке есть текст - добавлена ссылка, если нет - будет вставлен
' путь к файлу в буфере и гиперссылка.
'
' Wyfinger (removed@mail.ru)
'
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()
'
' Вставить в текущую ячейку гиперссылку на файл/каталог, скопированный в буфер обмена, если он один
'
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