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)
Sub test()
Feuil1.Pictures(1).Select
Application.CommandBars.ExecuteMso ("PictureCrop")
With Selection.ShapeRange
'.LockAspectRatio = msoTrue
.Height = 173.25
.Width = 230.25
.Rotation = 0#
.PictureFormat.CropLeft = 100
.PictureFormat.CropRight = 70
.PictureFormat.CropTop =40
.PictureFormat.CropBottom = 30
'.ZOrder msoSendToBack
End With
End Sub
Const Hci = 127.56 ' photo identité hauteur 3.5 cm en points
Const Wci = 99.21 ' photo identité largeur 4.5 cm en points
Sub test()
Feuil1.Pictures(1).Select
Application.CommandBars.ExecuteMso ("PictureCrop")
With Selection.ShapeRange
'.LockAspectRatio = msoTrue
.Height = 173.25
.Width = 230.25
.Rotation = 0#
.PictureFormat.Crop.ShapeHeight = Hci
.PictureFormat.Crop.ShapeWidth = Wci
.PictureFormat.Crop.ShapeLeft = .Left _
+ ((.PictureFormat.Crop.PictureWidth - Wci) / 2)
.PictureFormat.Crop.ShapeTop = .Top _
+ ((.PictureFormat.Crop.PictureHeight - Hci) / 2)
' .PictureFormat.CropLeft = 100
' .PictureFormat.CropRight = 70
' .PictureFormat.CropTop = 40
' .PictureFormat.CropBottom = 30
'.ZOrder msoSendToBack
End With
End Sub
Problème résolu, j'ai modifié les lignes concernées en faisant un replace du % par rien .
Sub crop_with_calque() 'fonction de coupage
Dim P_ToPx&, Calque As Shape, L#, R#, T#, B#
Set Calque = Feuil1.Shapes("calque")
Feuil1.Pictures("origin").Select
'Application.CommandBars.ExecuteMso ("PictureCrop")' pas vraiment besoins
With Selection.ShapeRange
.LockAspectRatio = msoFalse
L = (Calque.Left - .Left)
R = .Width - (L + Calque.Width)
T = Calque.Top - .Top
B = .Height - (T + Calque.Height)
With .PictureFormat: .CropRight = R: .CropTop = T: .CropBottom = B: .CropLeft = L: 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
CommandButton2.Enabled = False: CommandButton3.Enabled = False: CommandButton4.Enabled = False
[d3:F11].Select
End Sub
'deplace le Cpr
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
Image1.Move Image1.Left + (X - XX), Image1.Top + (Y - YY)
keepOnCadre
End If
End Sub
Sub keepOnCadre()
If Image1.Left > 0 Then Image1.Left = 0
If Image1.Top > 0 Then Image1.Top = 0
If Image1.Height + Image1.Top < fram.Height Then Image1.Top = fram.Height - Image1.Height
If Image1.Width + Image1.Left < fram.Width Then Image1.Left = fram.Width - Image1.Width
End Sub
Private Sub ScrollBar1_Change()
titreZ = "Zoom:" & ScrollBar1: zooming
keepOnCadre
End Sub
Private Sub ScrollBar1_Scroll()
titreZ = "Zoom:" & ScrollBar1: zooming
keepOnCadre
End Sub
Sub Crop_Image_By_MJ()
adr = ActiveCell.Address
ActiveSheet.Shapes(1).Top = [A1].Top
ActiveSheet.Shapes(1).Left = [A1].Left
ActiveSheet.Shapes.Range(Array("Image")).Select 'Array("Picture 3")
ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
largRect = Selection.Width
hautRect = Selection.Height
With Feuil1.Shapes(1)
'Debug.Print .Left, .Top, .Width, .Height
largimg = .Width
hautimg = .Height
posImgx = .Left
posImgy = .Top
End With
With Feuil1.Shapes("Rectangle 1")
'Debug.Print .Left, .Top, .Width, .Height
largRec = .Width
hautrec = .Height
posrecx = .Left
PosRecy = .Top
End With
'Stop
ActiveSheet.Shapes(1).Select
With ActiveSheet.Shapes(1)
Cropbot = hautimg - (PosRecy + hautrec)
.PictureFormat.CropBottom = Cropbot
CropTop = PosRecy
.PictureFormat.CropTop = CropTop
croprig = largimg - (posImgx + posrecx + largRec)
.PictureFormat.CropRight = croprig
croplef = posrecx
.PictureFormat.CropLeft = croplef
End With
ActiveSheet.Shapes(1).Copy
Range("F21").Select
ActiveSheet.PasteSpecial Format:="Image (métafichier amélioré)", Link:= _
False, DisplayAsIcon:=False
Selection.Name = "NomImgdest"
'Stop
DossierDest = Cells(2, 13)
NDFS = DossierDest & "\" & NomFichier
Selection.Copy
With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
' .Name = "GraphiqueImg"
ActiveSheet.Shapes("NomImgdest").Copy
ActiveSheet.ChartObjects(1).Activate
Sleep (500)
DoEvents
Sleep (500)
.Paste
.Export NDFS, "JPG"
End With
' Supprime_Images_ChartObjects
Range(adr).Select
ActiveWindow.SmallScroll Down:=-50
End Sub