Enregistrement automatique du chemin d'accès

Bonjour ;

Comment Indiquer le chemin d'accès du dossier Png sans modifier le cheminement (dans VBA ) à chaque changement de dossier ou d'ordinateur ?

Sachant que le fichier et le dossier dans Même dossier père.

Comment standardiser le chemin d’accès ou Adapter le chemin automatiquement lors changement du disque ou d’ordinateur car je suis obligé d'adapter les chemins d'accès.

Voila mon code vba:

Sub CreateQrcode()
Dim URL As String
Dim codetext As String
Dim folderPath As String
Dim filePath As String
Dim lastRow As Long
Dim i As Long
Dim Fic As String

    Fic = Dir("C:\Users\Zine TS\Desktop\Certificat V2 Final\QRCodes\*.png")
    Do While Fic <> ""
    Kill "C:\Users\Zine TS\Desktop\Certificat V2 Final\QRCodes\" & Fic
    Fic = Dir
    Loop
   URL = "https://chart.googleapis.com/chart?chs=125x125&cht=qr&chl="
   folderPath = "C:\Users\Zine TS\Desktop\Certificat V2 Final\QRCodes\"
   lastRow = Sheets("Base").Cells(Rows.Count, "D").End(xlUp).Row
   If Dir(filePath, vbDirectory) = " " Then
   MkDir folderPath
   End If

For i = 6 To lastRow
codetext = Sheets("Base").Cells(i, "D").Value
codetext = WorksheetFunction.EncodeURL(codetext)

URL = "https://chart.googleapis.com/chart?chs=125x125&cht=qr&chl=" & codetext
filePath = folderPath & Cells(i, "D").Value & ".png"
DownloadFile URL, filePath
Next i
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\Zine TS\Desktop\Certificat V2 Final\QRCodes")

i = 1

End Sub
Sub DownloadFile(URL As String, filePath As String)
Dim WinHttpReq  As Object
Dim oStream As Object
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
Set oStream = CreateObject("ADODB.Stream")
WinHttpReq.Open "GET", URL, False
WinHttpReq.send
If WinHttpReq.Status = 200 Then
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile filePath, 2
oStream.Close
End If
Set oStream = Nothing
Set WinHttpReq = Nothing
End Sub
Sub SupprContenu()
Dim Fic As String
Application.ScreenUpdating = False
With Range("N6:N800").ClearContents
Fic = Dir("C:\Users\Zine TS\Desktop\Certificat v2 Final\QRCodes\*.png")
Do While Fic <> ""
Kill "C:\Users\Zine TS\Desktop\Certificat v2 Final\QRCodes\" & Fic
Fic = Dir
Loop
End With
End Sub

Public Sub CheminFichier()
'Dim lastRow As Long, lRow As Long
Dim sFolder As String
Dim sFullFileName As String
Const EXT As String = ".png"
    With ActiveSheet
        sFolder = .Range("Chemin_").Value
        If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("N6:N" & lastRow).ClearContents
        For lRow = 6 To lastRow
            sFullFileName = sFolder & .Cells(lRow, 4).Value & EXT
            .Cells(lRow, 14) = sFullFileName
        Next lRow
    End With

MsgBox "Les codes qr sont créés avec succès ", vbInformation

End Sub

Je vous remercie à l'avance !

Cordialement,

bonsoir,

pas sûr d'avoir compris exactement la demande, mais si tu veux pouvoir adapter le chemin sans modifier ta macro, tu peux faire référence à une cellule de ton classeur qui contient le chemin d'accès.

Bonjour le fil

@zinelamri, si j'ai bien compris

Sub CreateQrcode()
  Dim URL As String
  Dim codetext As String
  Dim folderPath As String
  Dim filePath As String
  Dim lastRow As Long
  Dim i As Long
  Dim Fic As String
  Dim DesktopPath As String
  ' Chemin du dossier BUREAU de l'utilisateur
  DesktopPath = CreateObject("WScript.Shell").specialFolders("Desktop") & "\"
  Fic = Dir(DesktopPath & "\Certificat V2 Final\QRCodes\*.png")
  ' Etc ....
End Sub

A+

Bonjour tout le monde,
Bonjour h2so4 ,BrunoM45

Tout d'abord merci pour vos réponses.

Par Crée un chemin d'accès universel qui sa d’adapte automatiquement avec tous les supports de sauvegarde

Je vous remercie de votre aide par avance.

Amicalement

Re,

A part sur le C:\ Un chemin d'accès universel, ça n'existe pas

Pourquoi ne pas demander simplement à l'utilisateur l'endroit ou il veut sauvegarder
Avec une fonction par exemple

Function ChoixDossier(DefautPath As String, sTitre As String)
  Dim fd As FileDialog
  Set fd = Application.FileDialog(msoFileDialogFolderPicker)
  With fd
    .Title = sTitre
    .InitialFileName = DefautPath
    If .Show = -1 Then
      ChoixDossier = fd.SelectedItems(1)
    End If
  End With
  Set fd = Nothing
End Function

A+