Microsoft 365 VBA Excel Création de raccourcis Windows à partir d'URL dans un colonne

INFSON

XLDnaute Nouveau
Bonjour

Question pour un spécialisate en VBA EXCEL

J’ai adapté une macro VBA trouvé sur un site

Elle ne fonctionne pas comme je le souhaite

Soit le fichier excel en pièce jointe

Col A = Nom Souhaité d’url
Col B = Destination pour les raccourcis à Générer
( user \BRUNO2\ à changer dans cette colonne )
Col C = Url Youtube

1/ Cette routine ne fonctionne que si on la laisse liée au fichier excel
si je la déplace dans le fichier PERSONAL.XLSB des macros communes elle plante
motif Microsoft Visual Basic
Erreur d'exécution '-2147024891 (80070005):
Impossible d'enreqistrer le raccourci "C :\.Ink".

Pourquoi ?
Est-ce normal en raison du fait que la routine agit hors d' excel ?

2/ j’aurai souhaité récupérer une extension type .url et non .ink
afin que le raccourci puisse fonctionner dans l'environnement android
est-ce possible ?

si je remplace usb par ink dans la routine elle plante
motif Erreur d'exécution '438'
Propriété ou méthode non gérée par cet objet

Quel OBJET faut il utiliser ?

Merci d’avance

Le code repris ci-dessous du fichier https://www.cjoint.com/c/KFdrmAfpfHT
dans le fichier Excel e

Sub LinkCreateTranspo()
Dim ScrHst As Object, Raccourci As Object
Dim LastLig As Long, i As Long
Dim Emplacement As String

Set ScrHst = CreateObject("WScript.Shell")
LastLig = Feuil1.Cells(Feuil1.Rows.Count, 3).End(xlUp).Row
For i = 2 To LastLig
Emplacement = Feuil1.Range("B" & i)
Set Raccourci = ScrHst.CreateShortcut(Emplacement & "\" & Feuil1.Range("A" & i) & ".lnk")
With Raccourci
.WorkingDirectory = Emplacement
.TargetPath = Feuil1.Range("C" & i)
.Save
End With
Next i
Set Raccourci = Nothing
Set ScrHst = Nothing
End Sub

Merci d'avance
 

Pièces jointes

  • CREAT_RACCOURCIS 20210531 - Copie - Copie.xlsm
    15.8 KB · Affichages: 23

fanch55

XLDnaute Barbatruc
Bonsoir,
En modifiant légèrement la feuille :
1622998490767.png

Le code ci-dessous devrait le faire :
VB:
Sub LinkCreateTranspo()
Dim Emplacement As String, Word As Variant, Ligne As Range
With Worksheets("Feuil1")
    For Each Ligne In .Rows("2:" & .Cells(.Rows.Count, 3).End(xlUp).Row)
        With CreateObject("WScript.Shell")
            Emplacement = .SpecialFolders("Desktop") & "\"
            For Each Word In Split(Ligne.Cells(2), "\")
                Emplacement = Emplacement & Word & "\"
                If Dir(Emplacement, vbDirectory) = "" Then MkDir Emplacement
            Next
            With .CreateShortcut(Emplacement & "\" & Ligne.Cells(1) & ".url")
                .TargetPath = Ligne.Cells(3)
                .Save
            End With
        End With
    Next
End With
End Sub

Nota: pas de problème particulier en le plaçant dans le personnal.xlsb

Je n'ai pas compris le terme USB ?
 
Dernière édition:

soan

XLDnaute Barbatruc
Inactif
Bonjour INFSON, fanch55,

bienvenue sur le site XLD ! 🙂

tu as écrit : « Impossible d'enregistrer le raccourci "C :\.Ink". » et :

« 2/ j’aurai souhaité récupérer une extension type .url et non .ink »

et : « si je remplace usb par .ink dans la routine elle plante »

manque de pot, pour les raccourcis Windows qui sont des Liens vers des fichiers (en anglais : Link), l'extension est .lnk (avec un L minuscule, bien que .Lnk serait ok aussi) ; j'ai précisé « liens vers des fichiers » pour éviter toute confusion entre « raccourcis fichiers » et « raccourcis clavier ».

et puis surtout, pour ton raccourci "C :\.Ink", même si tu l'écris "C :\.lnk" ça ne peut vraiment pas marcher comme ça ! tu dois mettre par exemple "C :\*.lnk" ou "C:\nom.lnk".

« ink » existe aussi : c'est l'encre des imprimantes. 😁 😄

mébon, j'viens d'voir que dans ton code VBA, tu as bien mis ".lnk" et pas ".ink" ; alors si ça plante quand même, c'est peut-être car une des cellules est vide ? ➯ ça aboutit à : "C :\.lnk" !



@fanch55

tu as écrit : « Je n'ai pas compris le terme USB ? »

pour « USB », je connais les clés USB et les ports USB ; mais dans la phrase d'INFSON « si je remplace usb par ink dans la routine elle plante », j'vois pas quel est le rapport avec les clés USB ou les ports USB ; peut-être que le fichier est sur une clé USB externe, et pas sur le disque dur du PC ?

rappel : USB = « Universal Serial Bus » = bus en série universel ; plus d'infos ICI. 🙂

soan
 
Dernière édition:

INFSON

XLDnaute Nouveau
Bonjour

Merci pour vos réponses
Je vais essayer dans la journée de tester le code proposé

En ce qui concerne

"si je remplace usb par ink dans la routine elle plante"

c'est hélas une erreur de rédaction de ma part

j'aurai du écrire
"si je remplace ink par url dans la routine elle plante"

bref il faut toujours relire attentivement ses posts ;-)

désolé
 

INFSON

XLDnaute Nouveau
J'ai testé sur mon PC la routine s'arrête du l'emplacement en Gras ci-dessous

Bruno

Sub CORRECTION_LinkCreateTranspo()
Dim Emplacement As String, Word As Variant, Row As Range
With Worksheets("Feuil1")
For Each Row In .Rows("2:" & .Cells(.Rows.Count, 3).End(xlUp).Row)
With CreateObject("WScript.Shell")
Emplacement = .SpecialFolders("Desktop") & "\"
For Each Word In Split(Row.Cells(2), "\")
Emplacement = Emplacement & Word & "\"
If Dir(Emplacement, vbDirectory) = "" Then MkDir Emplacement
Next
With .CreateShortcut(Emplacement & "\" & Row.Cells(1) & ".url")
.TargetPath = Row.Cells(3)
.Save
End With
End With
Next
End With
End Sub
 

soan

XLDnaute Barbatruc
Inactif
@fanch55

dans Emplacement, y'a au départ l'dossier spécial du Bureau, avec "\" final :​

Emplacement = .SpecialFolders("Desktop") & "\"

puis dans la boucle For, y'a :​

Emplacement = Emplacement & Word & "\"

et la ligne For est :​

For Each Word In Split(Row.Cells(2), "\")

mais Row.Cells(2) me paraît bizarre !

soan
 
Dernière édition:

fanch55

XLDnaute Barbatruc
@fanch55

dans Emplacement, y'a l'dossier spécial du Bureau :

Emplacement = .SpecialFolders("Desktop") & "\"

soan

Ce devrait être cela effectivement.

Cependant, je viens de remarquer que @INFSON est sur microsoft 365 .

J'ai connu beaucoup de déboires avec la commande DIR qui fonctionne correctement sur les versions < 2019 mais qui semble provoquer systématiquement une erreur sur 365 quand le pathname spécifié n'existe pas.
IL faudrait peut-être mettre un "on error resume next" ...
Je n'ai pas la version 2019 ou Office 365 .
 

fanch55

XLDnaute Barbatruc
La version sans le Dir :
VB:
Option Explicit
Sub LinkCreateTranspo()
Dim Emplacement As String, Word As Variant, Ligne As Range, Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
    With Worksheets("Feuil1")
        For Each Ligne In .Rows("2:" & .Cells(.Rows.Count, 3).End(xlUp).Row)
            With CreateObject("WScript.Shell")
                Emplacement = .SpecialFolders("Desktop") & "\"
                For Each Word In Split(Ligne.Cells(2), "\")
                    Emplacement = Emplacement & Word & "\"
                    If Not Fso.FolderExists(Emplacement) Then
                        On Error Resume Next
                        Fso.CreateFolder Emplacement
                        If Err > 0 Then
                            MsgBox "le dossier " & Emplacement & " est incorrect", vbCritical + vbOKOnly, "Abandon"
                            Exit Sub
                        End If
                    End If
                Next
                With .CreateShortcut(Emplacement & "\" & Ligne.Cells(1) & ".url")
                    .TargetPath = Ligne.Cells(3)
                    .Save
                End With
            End With
        Next
    End With
Set Fso = Nothing
End Sub
 
Dernière édition:

Statistiques des forums

Discussions
313 257
Messages
2 096 608
Membres
106 679
dernier inscrit
emmanuel.bougnon@knowllen