Hperlien vers fichier selectionné et copié dans un dossier
Bonjour,
Dans le fichier joint, un bouton activeX "Hyperlien", crée un bouton dans la cellule active, en lui affectant une macro.
Cette macro établi une connexion (hyperlien) vers un fichier choisi dans un répertoire.
Lors de cette opération, est-il possible que le fichier sélectionné soit copié, par la même occasion, dans un autre répertoire variable?
Je vous remercie pour votre aide.
Bonjour,
à tester,
edit: correction
Sub MacroLienHyper()
Dim finput As FileDialog
Set finput = Application.FileDialog(msoFileDialogFilePicker)
finput.InitialFileName = ActiveWorkbook.Path & "\"
finput.Show
If finput.SelectedItems.Count = 0 Then Exit Sub
With ActiveSheet
If Not finput Is Nothing Then
.Hyperlinks.Add Anchor:=.Shapes(Application.Caller), Address:=finput.SelectedItems(1)
fileX = Split(finput.SelectedItems(1), "\")
sFile = fileX(UBound(fileX))
CopyFile finput.SelectedItems(1), sFile
.Shapes(Application.Caller).OnAction = ""
End If
End With
End Sub
Sub CopyFile(addrFileSource As String, sFile)
Dim addrFileDest As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 1 Then addrFileDest = .SelectedItems(1) Else Exit Sub
End With
FileCopy addrFileSource, addrFileDest & "\" & sFile
End Sub
ps/ très jolie votre horloge 8)
autre choix
Sub MacroLienHyper()
Dim finput As FileDialog
Set finput = Application.FileDialog(msoFileDialogFilePicker)
finput.InitialFileName = ActiveWorkbook.Path & "\"
finput.Show
If finput.SelectedItems.Count = 0 Then Exit Sub
With ActiveSheet
If Not finput Is Nothing Then
.Hyperlinks.Add Anchor:=.Shapes(Application.Caller), Address:=finput.SelectedItems(1)
CopyFile finput.SelectedItems(1)
.Shapes(Application.Caller).OnAction = ""
End If
End With
End Sub
Sub CopyFile(addrFileSource As String)
Dim addrFileDest As String,fileX, sFile As String
fileX = Split(addrFileSource, "\")
sFile = fileX(UBound(fileX))
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 1 Then addrFileDest = .SelectedItems(1) Else Exit Sub
End With
FileCopy addrFileSource, addrFileDest & "\" & sFile
End Sub
Bonjour,
Merci pour ton aide. Merci pour l'horloge.
La macro que tu as revisitée est parfaite à un détail près.
Est-il possible que le lien hypertexte, cible le fichier copié et non celui sélectionné?
Merci beaucoup.
Comme je ne maîtrise pas le langage VBA, j'ai fait une boucle dans ta macro pour relancer partiellement la même macro.
Ainsi, je peux sélectionner le fichier nouvellement copié.
----
Sub MacroLienHyper()
Dim finput As FileDialog
Set finput = Application.FileDialog(msoFileDialogFilePicker)
finput.InitialFileName = ActiveWorkbook.Path & "\"
MsgBox "Choisissez dans le répertoire de votre choix, le fichier que vous voulez copier."
finput.Show
If finput.SelectedItems.Count = 0 Then Exit Sub
With ActiveSheet
If Not finput Is Nothing Then
'.Hyperlinks.Add Anchor:=.Shapes(Application.Caller), Address:=finput.SelectedItems(1)
CopyFile finput.SelectedItems(1)
.Shapes(Application.Caller).OnAction = ""
End If
End With
Call MacroLien
End Sub
Sub MacroLien()
Dim finput As FileDialog
Set finput = Application.FileDialog(msoFileDialogFilePicker)
finput.InitialFileName = ActiveWorkbook.Path & "\"
MsgBox "Le fichier a été déplacé dans le répertoire de votre choix. Sélectionnez-le à nouveau pour créer le lien hypertexte."
finput.Show
If finput.SelectedItems.Count = 0 Then Exit Sub
With ActiveSheet
If Not finput Is Nothing Then
.Hyperlinks.Add Anchor:=.Shapes(Application.Caller), Address:=finput.SelectedItems(1)
.Shapes(Application.Caller).OnAction = ""
End If
End With
End Sub
Sub CopyFile(addrFileSource As String)
Dim addrFileDest As String, fileX, sFile As String
fileX = Split(addrFileSource, "\")
sFile = fileX(UBound(fileX))
With Application.FileDialog(msoFileDialogFolderPicker)
MsgBox "Choisissez le répertoire où vous voulez copier ce fichier."
.Show
If .SelectedItems.Count = 1 Then addrFileDest = .SelectedItems(1) Else Exit Sub
End With
FileCopy addrFileSource, addrFileDest & "\" & sFile
End Sub
Merci de m'avoir apporté la solution.
Pour partager,
Je suis revenu simplement à la proposition de sabV et j'ai rajoutté la macro ci-après qui redirectionne les lien hypertexte vers le ou les nouveaux fichiers copiés.
Sub ModifieAddresse()
NvRepertoire = "C:\Users\xxx\Desktop\Nouveau dossier\"
For Each h In ActiveSheet.Hyperlinks
a = Split(Replace(h.Address, "\", "/"), "/")
nf = a(UBound(a))
h.Address = NvRepertoire & nf
Next h
End Sub