Tout point d'amélioration est le bienvenue .Le besoin est de pouvoir fournir une photo de faible dimension au format CI pour des licences de pétanques (entre autre)
bonjour a tousBonjour Patrick, le Forum,
Merci pour ton formidable travail et surtout te tenacité
J'ai suivi tous les fils et c'est tellement intéressant !
J'ai téléchargé ton fichier mais chez moi ça beug ici :
Private Sub CommandButton2_Click()
Dim filetoopen As Variant, ratio, sizeimg, coeff#
ChDir "C:\Users\Public\Pictures\Sample Pictures"
Bonne journée à toi et à toutes et à tous,
Amicalement,
lionel
Sub crop_with_calque() 'fonction de coupage
Dim P_ToPx&, Calque As Shape, L#, R#, T#, B#
Dim Origin As Shape, RH#, RT#, RL#, RW#
Set Calque = Me.Shapes("calque")
Set Origin = Me.Shapes("origin")
'Application.CommandBars.ExecuteMso ("PictureCrop")' pas vraiment besoins
With Origin
RH = Calque.Height / Origin.Height ' rapport hauteur calque/ hauteur image
RW = Calque.Width / Origin.Width ' rapport largeur calque/ largeur image
RT = (Calque.Top - Origin.Top) / Origin.Height ' rapport top calque/ top image
RL = (Calque.Left - Origin.Left) / Origin.Width ' rapport left calque/ left image
.ScaleWidth 1, True ' indispensable pour travailler sur les dimensions réelles
.ScaleHeight 1, True 'indispensable pour travailler sur les dimensions réelles
With Calque
.Height = Origin.Height * RH
.Width = Origin.Width * RW
.Top = Origin.Top + Origin.Height * RT
.Left = Origin.Left + Origin.Width * RL
End With
With .PictureFormat
L = Calque.Left - Origin.Left
R = Origin.Width - (L + Calque.Width)
T = Calque.Top - Origin.Top
B = Origin.Height - (T + Calque.Height)
.CropTop = T
.CropBottom = B
.CropLeft = L
.CropRight = R
End With
.Height = [d3:d12].Height: .Left = [d3].Left + ([d3:f3].Width - .Width) / 2: .Top = [d3].Top
End With
With Calque: .ZOrder msoBringToFront: .Top = [c2].Top: .Left = [c2].Left: .Width = 1: .Height = 1: End With
CommandButton2.Enabled = False: CommandButton3.Enabled = False: CommandButton4.Enabled = False
[d3:F11].Select
End Sub
Mince, je suis en retard sur le fil, je vais tester ta nouvelle version Patrick,
mais c'est dommage que tu ne vois pas le crop natif d'excel 2016 ( à partir de 2010 ) ..
....
....
End With
.Height = [d3:d12].Height: .Left = [d3].Left + ([d3:f3].Width - .Width) / 2: .Top = [d3].Top
End With
With Calque: .ZOrder msoBringToFront: .Top = [c2].Top: .Left = [c2].Left: .Width = 1: .Height = 1: End With
CommandButton2.Enabled = False: CommandButton3.Enabled = False: CommandButton4.Enabled = False
[d3:F11].Select
End Sub
ha oui ça j'y ai pas penséOn tombe aléatoirement (je n'ai pas vraiment déterminé le quand et pourquoi ) sur une division par zéro , mais particulièrement quand l'image originale est plus petite que le calque
Sub crop_with_calque() 'fonction de coupage
Dim percentLeft#, percentTop#, percentRight#, percentBottom#, origWidth#, origHeight#, pict As Picture, Calque As Shape
Dim temp
Set pict = ActiveSheet.Pictures("origin"): Set Calque = ActiveSheet.Shapes("calque")
'******************************************
'correctif depassement du calque si un de ses bord est en dhors de l'image
If Calque.Left < pict.Left Then temp = pict.Left - Calque.Left: Calque.Left = pict.Left: Calque.Width = Calque.Width - temp
If Calque.Top < pict.Top Then temp = pict.Top - Calque.Top: Calque.Top = pict.Top: Calque.Height = Calque.Height - temp
If Calque.Left + Calque.Width > (pict.Left + pict.Width) Then
Calque.Width = Calque.Width - ((Calque.Left + Calque.Width) - (pict.Left + pict.Width))
End If
If Calque.Top + Calque.Height > (pict.Top + pict.Height) Then
Calque.Height = Calque.Height - ((Calque.Top + Calque.Height) - (pict.Top + pict.Height))
End If
'***********************************************
'correctif "divizion by zero" coome ca
If Calque.Left - pict.Left > 0 Then percentLeft = 100 / (pict.Width / (Calque.Left - pict.Left)) Else percentLeft = 0
If Calque.Top - pict.Top > 0 Then percentTop = 100 / (pict.Height / (Calque.Top - pict.Top)) Else percentTop = 0
'ou comme ca
percentRight = 100 - (100 / (pict.Width / (Application.Max((1 / 100000000000#), Calque.Left - pict.Left) + Calque.Width)))
percentBottom = 100 - (100 / (pict.Height / (Application.Max((1 / 100000000000#), Calque.Top - pict.Top) + Calque.Height)))
With pict.ShapeRange '(1)
'on fait une copie temporaire pour récupérer les dimention originales!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
With .Duplicate: .ScaleWidth 1, True: origWidth = .Width: origHeight = .Height: .Delete: End With
With .PictureFormat
'Crop-->(Left,Top,Right,Bottom) = original Size(width ou height) * pourcentage / 100
.CropLeft = origWidth * (percentLeft / 100)
.CropRight = origWidth * (percentRight / 100)
.CropTop = origHeight * (percentTop / 100)
.CropBottom = origHeight * (percentBottom / 100)
End With
.Left = (([d3:F11].Width - .Width) / 2) + [d3:F11].Left
.Top = (([d3:F11].Height - .Height) / 2) + [d3:F11].Top
End With
With Feuil1.Shapes("calque"): .ZOrder msoBringToFront: .Top = [c2].Top: .Left = [c2].Left: .Width = 1: .Height = 1: End With
Feuil1.CommandButton2.Enabled = False: Feuil1.CommandButton3.Enabled = False: Feuil1.CommandButton4.Enabled = False
Feuil1.CommandButton5.Enabled = True
[d3:F11].Select
End Sub