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.

15test.xlsm (357.51 Ko)

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

Rechercher des sujets similaires à "hperlien fichier selectionne copie dossier"