Comprimez les images des document inclus dans dossier

[Fredheg]

Bonjour a tous

Nouveau en VBA Word (je suis bon debutant en VBA excel), j'aimerai faire une macro qui m'ouvre tout les doc d'un repertoire et sous repertoire et qui me "scanne" les fichiers a la recherche d'images puis puis qu'il les compresse (en 200DPi).
En effet j'ai dans un repertoire sur le reseau quelque millier de doc. Et chaque doc comporte au moins 2 images. la taille du doc avant compression de l'image est de 1500 Ko et apres 200 Ko.

Pour ouvrir un repertoire et faire des actions sur les fichier j'ai deja une macros mais tiré d'excel je ne sais pas si elle fonctionnent.

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
43
44
Sub OpenFichiers()
'F. xxxxxxxx - Septembre 2006
Dim Dossier As Object, fichier As Object
Dim TabDossiers As Variant, Rep As Variant
Dim c As Range
Dim chemin As String
Dim L As Long, D As Long
'Application.DisplayAlerts = False       'Desactive les alertes de Excell
Rep = Application.InputBox("entrez le nom du répertoire à explorer", "Chemin du répertoire", _
    "exemple", Type:=2)
      If Rep = False Then Exit Sub
      If Not Rep Like "*\?*" Then
            MsgBox "Veuillez indiquer un dossier (pas un disque)!"
            Exit Sub
      End If
      Application.ScreenUpdating = False
      'Création du tableau des sous-dossiers existants
      TabDossiers = lstDossiers_(Rep, True)
      For D = 1 To UBound(TabDossiers)
            'Chemin du dossier (ou sous-dossier) à analyser
            chemin = TabDossiers(D) & "\"
            'Analyse du dossier (ou sous-dossier)
            Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(chemin)
            For Each fichier In Dossier.Files
                  'Liste les fichiers Excel
                  If fichier.Name Like "*.txt" Then
Rem                      Workbooks.Open Filename:=fichier
       Workbooks.OpenText Filename:=fichier, Origin:=xlWindows, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
        TrailingMinusNumbers:=True
                      ' a mettre ici les actions a effectuer
                      Rem Serie_Arbeit
                      ' jusqu'ici
                      L = L + 1
                  End If
            Next
      Next D
      Set Dossier = Nothing
      Application.ScreenUpdating = True
      MsgBox "Traitement terminé !" & vbLf & L & " Fichier(s) modifié(s)"
'Application.DisplayAlerts = True       'Active les alertes de Excell
End Sub

Pour compresse une image je ne sais pas encore comment faire. J'ai trouvé ca sur le forum pour modifier une images,mais je ne sais pas l'apliqué

Code :

1
2
3
4
5
6
Set objShape = Selection.InlineShapes.AddPicture(FileName:="C:\developpez\logo_developpez.gif", LinkToFile:=False, SaveWithDocument:=True)
With objShape
    .LockAspectRatio = msoTrue
    .Height = .Height * 0.5
    .Width = .Width * 0.5
End With

Voila j'espere que la description est clair sinon n'hesité pas.

J'ai essayer de vous mettre une pieces jointe mais elle est trop grosse

Merci de votre aide et @+

[Heureux-oli]

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
 
Sub OpenFichiers()
'F. xxxxxxxx - Septembre 2006
'******************************
Dim oDoc As Document
Dim sh As Shape   
'******************************
Dim Dossier As Object, fichier As Object
Dim TabDossiers As Variant, Rep As Variant
Dim c As Range
Dim chemin As String
Dim L As Long, D As Long
'Application.DisplayAlerts = False       'Desactive les alertes de Excell
Rep = Application.InputBox("entrez le nom du répertoire à explorer", "Chemin du répertoire", _
    "exemple", Type:=2)
      If Rep = False Then Exit Sub
      If Not Rep Like "*\?*" Then
            MsgBox "Veuillez indiquer un dossier (pas un disque)!"
            Exit Sub
      End If
      Application.ScreenUpdating = False
      'Création du tableau des sous-dossiers existants
      TabDossiers = lstDossiers_(Rep, True)
      For D = 1 To UBound(TabDossiers)
            'Chemin du dossier (ou sous-dossier) à analyser
            chemin = TabDossiers(D) & "\"
            'Analyse du dossier (ou sous-dossier)
            Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(chemin)
            For Each fichier In Dossier.Files
                Set oDoc = Documents.Add FileName:=fichier
                   For Each sh in oDoc.Shapes
                          If sh.pictureformat = 3 Then 'code à exécuter si image
                   Next sh
                oDoc.close
            next fichier

Seul hic, j'ai pas trouvé pour compresser les images par code.

[Fredheg]

Bonjour Heureu-oli

Merci de repondre.

J'ai essayé ton code mais j'ai l'impression qu'il manque la fin

Pas de end if
End Sub

etc...

[Heureux-oli]

Oui, je n'ai pas repris la fin du tien, j'ai pris le début pour indiquer par où je commence.

[Sepia]

Salut,

Il existe un utilitaire (hélas peu paramétrable ) dans Word qui permet de comprimer des images par interface. Je ne connais pas le code pour y accéder mais en revanche dans une macro VBA, il est possible directement d'appeler une boîte de dialogue de l'application (voir sur le site les très bons exemples fournis par Heureux-oli, entre autres). Il suffit d'appeler et de lui envoyer OK (sendKey vbCr) pour avoir le "compresseur" d'images dans Word.

[Fredheg]

Bonsoir sepia

merci de repondre

Effectivement par l'interface je connais (, mais je ne vais pas faire cela sur plusieur millier de fichier.....)
je vais chercher les exemples de Heureux-oli.

Le code que je fournit puis modifier par Heureux-oli pour ouvrir les fichier dans un repertoire ne fonctionne pas sous Word....

Arghh

[Heureux-oli]

En fait, je n'ai pas voulu réécrire tout le code, j'ai donc simplement utilisé la partie que tu avais faite et mis les lignes pour ouvrir un fichier Word.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
Sub RecupFichier()
Dim oFSO As New FileSystemObject
Dim oFil As File
Dim oFold As Folder
 
Set oFold = oFSO.GetFolder("F:\Temp\")
 
For Each oFil In oFold.Files
    If Right(oFil.Name, 3) = "doc" Then
        wApp.Documents.Open FileName:="f:\temp\" & oFil
    End If
Next oFil
 
Set oFSO = Nothing
 
End Sub

Voilà un code que j'ai utilisé pour tout autre chose.

[Fredheg]

Re heureux-oli

ton 2em code me donne une erreur de compilation (je crois que c'est : type non defini..suis sous Word 2003 en Allemand):
sur la ligne
Dim oFSO As New FileSystemObject
Dois je declaré quelque chose en zone public ou je sais pas ?

[Heureux-oli]

Il faut déclarer la bibliothèque Microsoft Scripting Runtime.

Tools References
Outils Références
Désolé, mais en allemand, je ne connais pas.

[Sepia]

Salut Fredheg,

il ne faut pas oublier que tu peux appeler l'interface de Word par le code VBA, lui transmettre des commandes

Code :

SendKeys vbCR ' pour envoyer <Enter>

et mettre le tout dans une macro qui bouclerait sur les fichiers sur la base du code de Heureux-Oli

[Fredheg]

Bonjour heureux-oli et sepia

merci de repondre

heureux-oli : D'accord mais comment ? Excuse moi si ca te parait des question "stupide" mais en VBA Word je suis debutant.
Dois je stocké mes macros dans un module de normal.dot ?


Sepia : j'en prend note pour eventuellement la suite du code. Pour l'instant je suis bloqué au declaration de heureux-oli.

Merci et@+

[Heureux-oli]

En fait, l'endroit où va se trouver le code n'est pas important.
Si tu stockes ce code dansun module du normale.dot, ce code sera accessible au départ de tous les documents.
Si tu mets ce code dans un autre document, il ne sera disponible que lorsque ce document sera ouvert.

Au vu du code que tu nous avais mis, je pensais que tu étais habitué au VBA.

Je vais donc détailler comment fonctionne le code que j'ai posté.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub RecupFichier()
Dim oFSO As New FileSystemObject
Dim oFil As File
Dim oFold As Folder
 
Set oFold = oFSO.GetFolder("F:\Temp\")
 
For Each oFil In oFold.Files
    If Right(oFil.Name, 3) = "doc" Then
        wApp.Documents.Open FileName:="f:\temp\" & oFil
    End If
Next oFil
 
Set oFSO = Nothing
 
End Sub

On va travailler avec du file scripting.
En VBA, quelque soit le programme utilisé, il estpossible de faire appel à une autre bibliothèque (programme).
Pour pouvoir utiliser une bibliothèque, il faut dire au programme qu'il peut l'utiliser. Outils Références.

Cette ligne de code : Dim oFSO As New FileSystemObject fait appel au programme et le déclare comme objet.
Toutes ses fonctionnalités vont donc être disponibles.

File system permet de travailler sur les fichiers et répertoires, tu trouveras un tuto ici

Dès que j'ai récupéré le nom et le chemin du fichier, je l'ouvre en Word pour effectuer un traitement.

Application.Documents.Open FileName:="f:\temp\" & oFil

Application étant un objet application Word

Attention, dans mon code, je ne ferme pas les objet ouvert, c'était juste un exemple.

Application.Documents.Open FileName:="f:\temp\" & oFil

doit être suivi d'un Document.close après traitement.

Le traitment je ne l'ai pas mis.

[Fredheg]

Bonjour Heureux-oli

Effectivement je connais un peu VBA mais pour EXCELL pour word je nage encore un peu....

merci pour ton explication.
J'ai declaré les ressource.

Par contre je bloque a

Code :

1
2
3
4
5
6
7
8
9
10
11
12
Sub aRecupFichier()
Dim oFSO As New FileSystemObject
Dim oFil As File
Dim oFold As Folder
 
Set oFold = oFSO.GetFolder("D:\Temp\")
 
For Each oFil In oFold.Files
    If Right(oFil.Name, 3) = "doc" Then
        wApp.Documents.Open FileName:="D:\temp\" & oFil
    End If
Next oFil

J'ai bien ofil qui est egal a D:\temp\nom-fichier.doc

Si je corrige
wApp.Documents.Open FileName:="D:\temp\" & oFil
par
Application.Documents.Open FileName:= "D:\temp\" & oFil

alors j'ai une erreur "Microsft Visual basic :" je traduit :
erreur temp depassé : 5273
Document ou chemin incorecte, essayer une des solution suivantes:
controlé le chemin
cliqué sur ouvrir et recherche votre document (d:\temp\nom-fichier.doc)


EDIT : je pense qu'il faut prendre juste oFil
Si je corrige
wApp.Documents.Open FileName:="D:\temp\" & oFil
par
Application.Documents.Open FileName:=oFil

alors j'ai une erreur "Microsft Visual basic :" je traduit :
erreur temp depassé : 13
mauvais typ

Une idées ?

[Heureux-oli]

Combien de fichiers y a-t-il dans le répertoire ?

Essaie de mettre un Debug.Print sur un compteur

Genre

Code :

1
2
3
4
5
6
7
8
9
 
Dim i as integer
 
 
 
 
' dans la boucle
i = i +1
debug.print i

De cette manière, on devrait savoir si la boucle plante dès le début ou si il tourne un peu.

[Fredheg]

Re

voici la liste des fichier du repertoire :
nom fichier taille date heure
200030903-08956-07h17.doc 1411584 2003.9.3 6:18.8
20030807-08667-06h46.doc 1441792 2003.8.7 5:46.20
20030807-08667-14h06.doc 1483264 2003.8.7 13:7.4
20030808-08667-06h27.doc 1509376 2003.8.8 5:27.18
20030808-08667-10h16.doc 1499648 2003.8.8 9:20.44
20030811-08667-06h17.doc 1476096 2003.8.11 5:17.18

donc 5 fichier (pour tester) de environ 1.5 Mo chacun.
J'ai essayer avec des nom de fichier "simple" (genre 1.doc, 2.doc etc...) mais j'ai encore la meme erreur.


voici le code :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub aRecupFichier()
Dim oFSO As New FileSystemObject
Dim oFil As File
Dim oFold As Folder
Dim i As Integer
Set oFold = oFSO.GetFolder("D:\Temp\")
For Each oFil In oFold.Files
    If Right(oFil.Name, 3) = "doc" Then
        i = i + 1
        Debug.Print i
        'Application.Documents.Open FileName:="D:\temp\" & oFil
        Application.Documents.Open FileName:=oFil
    End If
Next oFil
Set oFSO = Nothing
End Su

Que je mette debug.print i avant ou apres Application.Documents.Open FileName:=oFil ca ne change rien ! je n'ai pas d'info ! et le debugueur s'arrete sur Application.Documents.Open FileName:=oFil avec l'erreur 13 :
mauvais type. Le debogeur s'arret dans la boucle et pendant la 1er boucle (arret sur le 1er fichier trouvé).
Serait il possible que la declaration Dim oFil As File soit erroné ?

[Heureux-oli]

Possible, je vais regarder de plus près demain.
Je vais écrire et tester le code, on gagnera un peu de temps.

[Fredheg]

Edit du poste precedent pour plus de precisions..

OK pour la reecriture, c'est vraiment gentil.
A demain

[Heureux-oli]

La routine pour ouvrir les fichiers d'un répertoire.
Il faut ajouter la référence de la bibliothèque Microsoft Scripting RunTime

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub RecupFichier()
Dim oFSO As New FileSystemObject
Dim oFil As File
Dim oFold As Folder
Dim sCh As String
 
sCh = InputBox("Entrez le chemin !")
 
Set oFold = oFSO.GetFolder(sCh)
 
For Each oFil In oFold.Files
    If Right(oFil.Name, 3) = "doc" Then
        CheckFile (sCh & oFil.Name) ' Appel de la fonction pour le traitement du fichier
    End If
Next oFil
 
Set oFSO = Nothing
 
End Sub

La fonction, j'ai simplement mis l'ouverture et la fermeture du fichier mais on peut faire d'autres action.
J'ai testé ce matin et je n'ai pas rencontré de problème

Code :

1
2
3
4
5
6
7
 
 
Public Function CheckFile(sFN As String)
Documents.Open sFN
Documents(sFN).Close
 
End Function

[Fredheg]

Bonjour Heureux-oli
Merci de repondre.
Tes codes marche nickel (seulement si on oubli pas le \ a la fin du chemin).
Donc la 1er etape est resolu.
je vais encore tester avec des sous repertoire...


Par contre il reste l'epineux probleme de la compresion d'image (la deuxieme etape).

La aussi je veut bien de l'aide car je ne sais pas commenr appeler la fonction).

[Fredheg]

Et ben non les sous repertoire ne sont pas pris en compte!

Une idées peut etre ?