Tranfert de fichiers tif ou pdf via VBA

Version imprimable

Bonjour,

Je souhaiterai céer une macro qui tranfère des fichiers en .tif ou .pdf d'un dossier à un autre sans les ouvrirs.
Ces fichiers sont listés dans une feuille excel, avec leur adresse de destination (qui est différence pour chaque fichier)
Ces fichiers sont présents dans un seul dossier de mon ordinateur.
Dans ma macro, je récupère le nom du fichier et sa future adresse dans le tableur excel. Je le recherche dans le dossier ou il est situé physiquement et je voudrais le déplacer dans la nouvelle adresse sans l'ouvrir.
Est-ce possible. Je n'ai pas trouvé de code

J'ai mis le code de la macro ci-après
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 Sub Macro1() Application.ScreenUpdating = False Sheets("Docs&Links").Select adresse3 = Cells(3, 6).Value For ligne = 9 To 4000 If Cells(ligne, 6) = "" Then GoTo 1 adresse = Cells(ligne, 6).Value adresse1 = Cells(ligne, 8).Value 'cherche le plan dans le fichier source Set fs = Application.FileSearch With fs .LookIn = adresse3 .Filename = adresse With Application.FileSearch For i = 1 To .FoundFiles.Count MsgBox .FoundFiles(i) Next i End With ' je veux transférer les fichier sélectionner dont l'adresse est "adresse3 & adresse" dans "adresse1" 1 Next End Sub
Merci de votre aide

Salut, brut de fonderie , à adapter à ton contexte

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Option Explicit
 
Private Sub CopierDossier(ByVal sDossierACopier As String, ByVal sDossierDestination As String)
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder sDossierACopier, sDossierDestination, True
    Set FSO = Nothing
End Sub
 
Private Sub CopierFichier(ByVal sFichierACopier As String, ByVal sFichierDestination As String)
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFile sFichierACopier, sFichierDestination, True
    Set FSO = Nothing
End Sub

Il existe également des instructions MoveFile et MoveFolder

Auquel on pourra adjoindre la création de dossier

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
 (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Private Sub CreationDossier(sDossier As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
 
    ' Pour valeur retournée dans Rep
    ' Voir http://msdn.microsoft.com/en-us/library/ms681381(VS.85).aspx
End Sub
 
Sub Tst()
Dim Dossier As String
    Dossier = "D:\repA\repB\repC"
    CreationDossier Dossier
End Sub

05/08/2009, 08h54
Thierry1001

1 pièce(s) jointe(s)

Bonjour,

Merci de la réponse mais je n'arrive pas à le faire fonctionner.

J'ai joint le une partie du fichier avec la macro. Si tu peux me donner une idée ou me modifier la macro en cours

Merci de ton aide

Salut,en l'adaptant à ton contexte

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
 (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Option Explicit
 
Private Sub CopierDossier(ByVal sDossierACopier As String, ByVal sDossierDestination As String)
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder sDossierACopier, sDossierDestination, True
    Set FSO = Nothing
End Sub
 
Private Sub CreationDossier(sDossier As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Sub
 
Sub Tst()
Dim Dossier As String
Dim sDossierA As String, sDossierB As String
 
    Dossier = "D:\repA\repB\repC"
    CreationDossier Dossier
 
    sDossierA = "C:\Transfert"
    sDossierB = Dossier
 
    CopierDossier sDossierA, sDossierB
End Sub

Merci pour ton code mais je voudrai transférer fichier par fichier et nom le dossier complet
Voici ma macro avec l'adresse des fichier (adresse1), le nom des fichiers à tranférer (adresse) et l'adresse de destination des fichier (adresse2)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
 (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Option Explicit
 
Private Sub CopierDossier(ByVal sDossierACopier As String, ByVal sDossierDestination As String)
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFolder sDossierACopier, sDossierDestination, True
    Set FSO = Nothing
End Sub
 
Private Sub CreationDossier(sDossier As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Sub
 
Sub Tst()
Dim Dossier As String
Dim sDossierA As String, sDossierB As String
Dim adresse As Variant
Dim adresse1 As Variant
Dim adresse2 As Variant
Dim ligne As Variant
 
Sheets("Docs&Links").Select
adresse2 = Cells(3, 6).Value ' adresse de destination
For ligne = 9 To 4000
If Cells(ligne, 6) = "" Then GoTo 1
adresse = Cells(ligne, 6).Value 'nom du fichier à déplacer
adresse1 = Cells(ligne, 8).Value ' adresse du fichier d'origine
 
    Dossier = adresse1 & adresse
    CreationDossier Dossier
 
    sDossierA = adresse2 & adresse
    sDossierB = Dossier
 
    CopierDossier sDossierA, sDossierB
1
Next
End Sub

Salut, à adapter à ton contexte

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
 (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Option Explicit
 
Private Sub CopierFichier(ByVal sFichierACopier As String, ByVal sFichierDestination As String)
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.CopyFile sFichierACopier, sFichierDestination, True
    Set FSO = Nothing
End Sub
 
Private Sub CreationDossier(sDossier As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Sub
 
Sub Tst()
Dim Dossier As String
Dim sFichier As String
 
    Dossier = "D:\repA\repB\repC"
    CreationDossier Dossier
 
    sFichier = ThisWorkbook.Path & "\" & "IE_Jscript.xls"
    CopierFichier sFichier, Dossier & "\" & "IE_Jscript.xls"
 
End Sub

06/08/2009, 07h59
Thierry1001

Ok je te remercie, ça marche