Insert file with hyperlink - multiple choice!

With double or right-click can files - also several - with hyperlink be inserted. The API function "GetCurrentDirectory" and "SetCurrentDirectory" prevents change over the current directory since as indicated in the VBA help "Application.FileDialog" always change the current directory. In the second code the file with path is written into the comment. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged In "Sheet1"

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
Alias "GetCurrentDirectoryA" (ByVal nBufferLength&, _
ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
Alias "SetCurrentDirectoryA" (ByVal lpPathName$) As Long
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim strDirOld As String
Dim strFile As String
On Error GoTo Worksheet_Change_Error
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, InStr(1, strDirOld$, vbNullChar) - 1)
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "C:\"
.Title = "Selection of files"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strFile = .SelectedItems(1)
Else
MsgBox "No file was selected!"
Cancel = True
Exit Sub
End If
End With
Target.Value = Dir(strFile)
Target.Hyperlinks.Add Anchor:=Target, Address:=strFile
Target.Columns.AutoFit
Cancel = True
Call SetCurrentDirectory(strDirOld$)
On Error GoTo 0
Exit Sub
Worksheet_Change_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Call SetCurrentDirectory(strDirOld$)
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, _
Cancel As Boolean)
Dim strDirOld As String
Dim lngFiles As Long
On Error GoTo Worksheet_Change_Error
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, InStr(1, strDirOld$, vbNullChar) - 1)
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "C:\"
.Title = "Selection of files"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
.AllowMultiSelect = True
If .Show = -1 Then
For lngFiles = 1 To .SelectedItems.Count
Target.Offset(lngFiles - 1, 0).Value = _
Dir(.SelectedItems(lngFiles))
Target.Offset(lngFiles - 1, 0).Hyperlinks.Add _
Anchor:=Target.Offset(lngFiles - 1, 0), _
Address:=.SelectedItems(lngFiles)
Next lngFiles
Else
MsgBox "No file was selected!"
Cancel = True
Exit Sub
End If
End With
Target.Columns.AutoFit
Cancel = True
Call SetCurrentDirectory(strDirOld$)
On Error GoTo 0
Exit Sub
Worksheet_Change_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Call SetCurrentDirectory(strDirOld$)
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Application.CommandBars("Web").Visible = False
End Sub

The following code belonged In "Sheet2"

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
Alias "GetCurrentDirectoryA" (ByVal nBufferLength&, _
ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
Alias "SetCurrentDirectoryA" (ByVal lpPathName$) As Long
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim strDirOld As String
Dim strFile As String
On Error GoTo Worksheet_Change_Error
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, InStr(1, strDirOld$, vbNullChar) - 1)
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "C:\"
.Title = "Selection of files"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strFile = .SelectedItems(1)
Else
MsgBox "No file was selected!"
Cancel = True
Exit Sub
End If
End With
Target.Value = Dir(strFile)
Target.AddComment.Text strFile
Target.Comment.Shape.TextFrame.AutoSize = True
Target.Hyperlinks.Add Anchor:=Target, Address:=strFile
Target.Columns.AutoFit
Cancel = True
Call SetCurrentDirectory(strDirOld$)
On Error GoTo 0
Exit Sub
Worksheet_Change_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Call SetCurrentDirectory(strDirOld$)
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, _
Cancel As Boolean)
Dim strDirOld As String
Dim lngFiles As Long
On Error GoTo Worksheet_Change_Error
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, InStr(1, strDirOld$, vbNullChar) - 1)
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "C:\"
.Title = "Selection of files"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
.AllowMultiSelect = True
If .Show = -1 Then
For lngFiles = 1 To .SelectedItems.Count
Target.Offset(lngFiles - 1, 0).Value = Dir(.SelectedItems(lngFiles))
Target.Offset(lngFiles - 1, 0).AddComment.Text .SelectedItems(lngFiles)
Target.Offset(lngFiles - 1, 0).Comment.Shape.TextFrame.AutoSize = True
Target.Offset(lngFiles - 1, 0).Hyperlinks.Add _
Anchor:=Target.Offset(lngFiles - 1, 0), _
Address:=.SelectedItems(lngFiles)
Next lngFiles
Else
MsgBox "No file was selected!"
Cancel = True
Exit Sub
End If
End With
Target.Columns.AutoFit
Cancel = True
Call SetCurrentDirectory(strDirOld$)
On Error GoTo 0
Exit Sub
Worksheet_Change_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Call SetCurrentDirectory(strDirOld$)
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Application.CommandBars("Web").Visible = False
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...