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 Sub inserer_Click()
Dim image(1000) As Picture
For Each cell In Selection
On Error Resume Next
Set image(cell.Row) = Feuil1.Pictures.Insert("\\pila1\BasesTMS\tms\images\" + Feuil1.Cells(cell.Row, cell.Column - 1).Value + ".jpg")
Largeur = image(cell.Row).Width
Hauteur = image(cell.Row).Height
lf = Feuil1.Cells(cell.Row, cell.Column).Width
hf = Feuil1.Cells(cell.Row, cell.Column).Height
Kh = 130 / Hauteur
Kl = 300 / Largeur
If Kl > Kh Then
k = Kh
Else
k = Kl
End If
With image(cell.Row)
.Left = Feuil1.Cells(cell.Row, cell.Column).Left + ((Feuil1.Cells(cell.Row, cell.Column).Left + Feuil1.Cells(cell.Row, cell.Column).Width - Feuil1.Cells(cell.Row, cell.Column).Left - (image(cell.Row).Width * k)) / 2)
.Top = Feuil1.Cells(cell.Row, cell.Column).Top + 20 + ((Feuil1.Cells(cell.Row, cell.Column).Top - 20 + Feuil1.Cells(cell.Row, cell.Column).Height - Feuil1.Cells(cell.Row, cell.Column).Top - (image(cell.Row).Height * k)) / 2)
.ShapeRange.ScaleWidth k, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleHeight k, msoFalse, msoScaleFromTopLeft
.Placement = xlMoveAndSize
End With
Next
End Sub
Private Sub CommandButton2_Click()
' Effacement eventuel des images de l'affichage précédent
On Error Resume Next
For i = 1 To 1000
nom$ = "Picture " + Trim$(Str$(i))
Feuil1.Shapes(nom$).Delete
Next i
End Sub |
Partager