Discussion :

[Mattieuc]

Bonjour,

J'ai un tableau d'audit à créer avec des centaines (voir des milliers) de lignes, et sur chaque ligne je dois insérer une photo (à chaque fois différente).

J'ai trouvé le code ci-dessous :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub insere_image_ratio()
Dim ficimg As String, Ad As String
Dim MemW As Long, MemH As Long, T As Integer, L As Integer
Dim Lg As Integer, HT As Integer, RatioCell As Single
Dim CellH As Long, CellW As Long, RatioHz As Single, RatioVt As Single
    Ad = Selection.Address
    CellH = Selection.Height
    CellW = Selection.Width
    ficimg = Application.GetOpenFilename(".jpg,*.jpg,.gif,*.gif,.jpeg,*.jpeg", , "Choisissez l'image") ' choix nom du fichier
   If ficimg = "Faux" Then Exit Sub
    ActiveSheet.Pictures.Insert(ficimg).Select ' insertion
   With Selection.ShapeRange
        MemW = .Width: MemH = .Height
        'adapte les ratio
       If MemH < CellH And MemW < CellW Then
        'l'image < cellule
           RatioHz = MemH / CellH
            RatioVt = MemW / CellW
            If RatioVt < RatioHz Then 'adapter en hauteur
               HT = CellH:  Lg = MemW * (HT / MemH)
                T = 0: L = (CellW - Lg) / 2
            Else 'adapter en largeur
               Lg = CellW: HT = MemH * (CellW / MemW)
                L = 0: T = (CellH - HT) / 2
            End If
        ElseIf MemH > CellH And MemW > CellW Then
        'l'image > cellule
           RatioHz = CellH / MemH
            RatioVt = CellW / MemW
            If RatioVt > RatioHz Then 'adapter en hauteur
               HT = CellH:  Lg = MemW * (HT / MemH)
                T = 0: L = (CellW - Lg) / 2
            Else 'adapter en largeur
               Lg = CellW: HT = MemH * (Lg / MemW)
                L = 0: T = (CellH - HT) / 2
            End If
        ElseIf MemH > CellH And MemW < CellW Then
        'adapter en hauteur
           HT = CellH:  Lg = MemW * (HT / MemH)
            T = 0: L = (CellW - Lg) / 2
        ElseIf MemH < CellH And MemW > CellW Then
        'adapter en largeur
           Lg = CellW: HT = MemH * (Lg / MemW)
            L = 0: T = (CellH - HT) / 2
        Else
            Stop ' pas prévu ?
       End If
 
        .LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
       .Top = Range(Ad).Top + T ' haut de la cellule
       .Left = Range(Ad).Left + L ' gauche de la cellule
       .Height = HT
        .Width = Lg ' largeur des cellules fusionnées
   End With
    With Selection
        .Placement = xlMoveAndSize
        .PrintObject = True
    End With
End Sub

Ce code est presque parfait pour moi, sauf, que lorsque j'ouvre le classeur Excel avec un autre PC, les photos n'apparaissent plus. En fait la fonction Pictures.Insert ne lie pas la photo et le classeur.

J'aimerais également pouvoir limiter la taille de la photo, car le code redimensionne l'image à la taille de la cellule, mais les photos conservent leur résolution d'origine.


Est-ce quelqu'un pourrait m'aider à modifier ce code ?
A moins qu'il n'existe une fonction d'Excel permettant de lier les images déjà insérées dans le classeur avec le PC qui créé le document, et de l'enregistrer pour qu'elle soient visibles avec n'importe quel PC ?


Par contre, je ne ne suis pas informaticien et je ne maîtrise donc pas bien le code.

En vous remerciant par avance,

[arosec]

Bonjour,

Voir le code en gras:
1- Pour ajouter l'image dans le fichier
2- Pour compresser les images

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub AddPicture()
Dim cmbCtrl As CommandBarControl

If Application.Dialogs(xlDialogInsertPicture).Show Then
  With ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count).ShapeRange
    .LockAspectRatio = msoFalse
    .Left = 10
    .Top = 50
    .Height = 100
    .Width = 100
  End With

  Set cmbCtrl = Application.CommandBars("Picture").FindControl(ID:=6382)
  If Not cmbCtrl Is Nothing Then cmbCtrl.Execute
  
End If
 
End Sub

Cdlt,