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 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
| Sub InsertionImages()
Dim Repertoire As String
Dim Extension As String
Dim Fichier As String
Dim objShell As Object, objFolder As Object, oFolderItem As Object 'Pour répertoire
Dim Chemin As String, Nom As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Vous êtes sur le point d'importer des photos dans le rapport. Spécifiez le répertoire de fichier image à utiliser", &H1&)
On Error Resume Next
Set oFolderItem = objFolder.Items.Item
Chemin = oFolderItem.Path
'Si pas de répertoire ou sous-répertoire sélectionné alors on sort...
If Chemin = "" Then Exit Sub
'Saisie du nom du répertoire
Repertoire = InputBox("Spécifiez le répertoire de fichier images à utiliser", "Répertoire", Chemin & "\")
'Saisie du type d'extension
Extension = InputBox("Type de fichier à utiliser ", "Type de fichier", "jpg")
'Récupération du premier fichier du répertoire
Fichier = Dir(Repertoire & "*" & Extension, vbDirectory)
Do While Fichier <> ""
i = i + 1
'Insertion de l'image
Selection.InlineShapes.AddPicture FileName:=Repertoire & Fichier
'Insertion d'une ligne vide
Selection.TypeParagraph
'changer l'écriture
With Selection.Font
.Name = "Century Gothic"
.Underline = wdUnderlineSingle
.Bold = True
.Size = 10
End With
Selection.TypeText ("Photo " & i & "Titre ")
Selection.TypeParagraph
'Récupération du prochain fichier du répertoire
Fichier = Dir
Selection.Next
Loop
End Sub
Sub redimimages()
'Déclaration des variables
Dim oISh As InlineShape 'variable objet représentant un objet image
'Boucle sur toutes les images du document
For Each oISh In ActiveDocument.InlineShapes
'Sélection de l'image
'Important pour déterminer si l'image se trouve dans une cellule de tableau
oISh.Select
'Test sur la position de l'image
If Selection.Information(wdWithInTable) Then
'Si l'image est dans une cellule on la redimentionne
With oISh
'affectation des dimensions de l'image
'On convertit des centimètres en points
.Height = CentimetersToPoints(11.01)
.Width = CentimetersToPoints(14.76)
End With
End If
Next oISh
End Sub |
Partager