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

INFSON

XLDnaute Nouveau
Je ne vois pas sur quelle ligne
Sub TEST3()
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
 

Etoto

XLDnaute Barbatruc
Essaie ça (pas sûr) :
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
                    Emplacement = Left(Emplacement, Len(Emplacement) - 3)
                        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

Mais je sais vraiment pas si ça va marcher.
 

INFSON

XLDnaute Nouveau
Non plantage
plantagePost19.jpg
 

INFSON

XLDnaute Nouveau
c'est bizarre j'ai l'impression qu'il y a 2 canaux de lecture
celui ci
et
 

fanch55

XLDnaute Barbatruc
Bonsoir, désolé, j'étais en déplacement .
Comme je l’indiquai dans le post 2 :
1623177145080.png

Tel que le code est fait, il ne faut pas indiquer le chemin complet en colonnne J, juste les dossiers cibles .
le code:
Emplacement = .SpecialFolders("Desktop") & "\" donne Emplacement = "c:\Users\BRUNO2\Desktop\"
Ensuite
le code va vérifier et créer les dossiers complémentaires pour chaque mot dans la colonne J :
Emplacement = "c:\Users\BRUNO2\Desktop\TEST\"
et finalement:
Emplacement = "c:\Users\BRUNO2\Desktop\TEST\CIBLE\"

Ceci pour permettre qu'il puisse fonctionner sur n'importe quel PC ou User sans avoir à changer ce qui est en colonne J.

Toutefois, si on veut préciser le chemin en entier ( C:\Users\BRUNO2\Desktop\TEST\CIBLE ) en colonne J,
en ce cas il suffit de remplacer la première assignation :
Emplacement = .SpecialFolders("Desktop") & "\" par Emplacement = vbnullstring
Le code va tenter de créer les dossiers indiqués sans se préoccuper du bureau propre à l'utilisateur .

VB:
Sub TEST3()
Dim Emplacement As String, Word As Variant, Ligne As Range, Fso As Object, Debut As Integer
Set Fso = CreateObject("Scripting.FileSystemObject")
    With Worksheets("Feuil1")
        Debut = 2 ' début des lignes à scruter
        For Each Ligne In .Rows(Debut & ":" & .Cells(.Rows.Count, 3).End(xlUp).Row)
            With CreateObject("WScript.Shell")
                Emplacement = vbNullString
                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" & vbLf & _
                                    Err.Description, 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

Si on ne désire pas que le code se charge de créer un quelconque emplacement mais juste le raccourci,
le code ci-dessous suffit :

VB:
Sub TEST4()
Dim Ligne As Range, Debut As Integer
    On Error Resume Next
    With Worksheets("Feuil1")
        Debut = 2 ' début des lignes à scruter
        For Each Ligne In .Rows(Debut & ":" & .Cells(.Rows.Count, 3).End(xlUp).Row)
            With CreateObject("WScript.Shell")
                With .CreateShortcut(Ligne.Cells(2) & "\" & Ligne.Cells(1) & ".url")
                    .TargetPath = Ligne.Cells(3)
                    .Save
                End With
                If Err Then
                    MsgBox "le raccourci est incorrect" & vbLf & _
                            Err.Description, vbCritical + vbOKOnly, "Abandon"
                    Err.Clear
                End If
            End With
        Next
    End With
End Sub
 

fanch55

XLDnaute Barbatruc
c'est bizarre j'ai l'impression qu'il y a 2 canaux de lecture
celui ci
et
Non, la discussion est juste composée de 2 pages ( et peut évoluer )