Option Explicit
Dim XX#, YY#
Function P_ToPx()
With ActiveWindow.ActivePane
P_ToPx = (.PointsToScreenPixelsY(Cells.Height) - .PointsToScreenPixelsY(0)) / Cells.Height
End With
End Function
Function Img_pixel_to_point(pathImage)
Dim Img As Object, IP As Object
Set Img = CreateObject("WIA.ImageFile") 'Création conteneur pour l'image
Img.LoadFile pathImage 'Chargement de l'image dans le conteneur WIA
Img_pixel_to_point = Array(Img.Width / P_ToPx, Img.Height / P_ToPx)
End Function
Private Sub CommandButton2_Click()
Dim filetoopen As Variant, ratio, sizeimg, coeff#
ChDir "C:\Users\Public\Pictures\Sample Pictures"
filetoopen = Application.GetOpenFilename("Jpeg Files (*.jpg), *.jpg", 1, "choisir une image")
If filetoopen <> False Then
chemin.Value = filetoopen
Image1.Picture = LoadPicture(chemin.Value)
sizeimg = Img_pixel_to_point(chemin.Value)
ratio = sizeimg(0) / sizeimg(1)
Image1.Width = sizeimg(0) / (sizeimg(0) / fond.Width)
Image1.Height = Image1.Width / ratio
If Image1.Height > fond.Height Then
coeff = Image1.Height / fond.Height
Image1.Height = Image1.Height / coeff
Image1.Width = Image1.Width / coeff
End If
End If
Image1.PictureSizeMode = 1
End Sub
Private Sub CommandButton3_Click()
Dim fname As Variant, imgOut
Dim Img As Object, IP As Object
imgOut = Application.GetSaveAsFilename(InitialFileName:=Environ("userprofile") & "\DeskTop", filefilter:="image Files (*.jpg), *.jpg", Title:="ENREGISTREMENT DE LA CAPTURE")
If imgOut <> False Then
Set Img = CreateObject("WIA.ImageFile")
Set IP = CreateObject("WIA.ImageProcess")
Img.LoadFile chemin.Value
'on crops maintenant
'Ajoute le filtre pour redimensionner l'image (Scale)
IP.Filters.Add IP.FilterInfos("Crop").FilterID
IP.Filters(1).Properties("Left") = (Img.Width / 100) * Val(cropleft)
'definit la position à partir du bord supérieur pour la coupe
IP.Filters(1).Properties("Top") = (Img.Height / 100) * Val(croptop)
'definit la position à partir du bord droit pour la coupe
IP.Filters(1).Properties("Right") = (Img.Width / 100) * Val(cropright)
'definit la position à partir du bord inférieur pour la coupe
IP.Filters(1).Properties("Bottom") = (Img.Height / 100) * Val(cropbottom)
'----------------------------------------------------
'etape finale
'Application du filtre à l'image
Set Img = IP.Apply(Img)
'Enregistre l'image redimensionnée
If Dir(imgOut) <> "" Then Kill imgOut
Img.SaveFile imgOut
Image1.PictureSizeMode = 0
Image1.Picture = LoadPicture(imgOut)
cropsbutton_Click
End If
End Sub
'*******************************************************************************************
'enclenche le movable de Cpr et cache les poignées de redimentionnement
Private Sub Cpr_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
XX = X: YY = Y
End Sub
'deplace le Cpr
Private Sub Cpr_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
CpR.Move CpR.Left + (X - XX), CpR.Top + (Y - YY)
attachpoignée
calculCroppercent
End If
End Sub
'arrete le movable du Cpr
Private Sub attachpoignée()
HG.Move CpR.Left - HG.Width, CpR.Top - HG.Height
HD.Move CpR.Left + CpR.Width, CpR.Top - HG.Height
BG.Move CpR.Left - BG.Width, CpR.Top + CpR.Height
BD.Move CpR.Left + CpR.Width, CpR.Top + CpR.Height
End Sub
Private Sub cropsbutton_Click()
Dim Controle, elem
Controle = Array(CpR, HG, HD, BG, BD)
For Each elem In Controle: elem.Visible = Not elem.Visible: Next
CpR.Move Image1.Left, Image1.Top
attachpoignée
End Sub
Private Sub HG_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
rollcrops Button, X, Y, Array(HG, BG, HD)
End Sub
Private Sub HD_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
rollcrops Button, X, Y, Array(HD, BD, HG)
End Sub
Private Sub BG_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
rollcrops Button, X, Y, Array(BG, HG, BD)
End Sub
Private Sub BD_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
rollcrops Button, X, Y, Array(BD, HD, BG)
End Sub
Sub rollcrops(B, X, Y, Poignées)
If B = 1 Then
If BG.Top - HG.Top < 15 Or HD.Left - HG.Left < 15 Then Exit Sub Else HG.Left = HG.Left
Poignées(0).Move Poignées(0).Left + (X - 3), Poignées(0).Top + (Y - 3)
Poignées(1).Left = Poignées(0).Left: Poignées(2).Top = Poignées(0).Top
If (BG.Top - HG.Top) > 15 And (HD.Left - HG.Left) > 15 Then
CpR.Move HG.Left + HG.Width, HG.Top + HG.Height, HD.Left - (HG.Left + HG.Width), BG.Top - (HG.Top + HG.Height)
Else
HG.Left = HG.Left - 1: HD.Left = HD.Left + 2: BG.Top = BG.Top + 2: HG.Top = HG.Top - 1
attachpoignée
End If
End If
calculCroppercent
End Sub
Sub calculCroppercent()
cropleft = (CpR.Left - Image1.Left) * 100 / Image1.Width & " %"
cropright = 100 - ((CpR.Width + CpR.Left - Image1.Left) * 100 / Image1.Width) & " %"
croptop = (CpR.Top - Image1.Top) * 100 / Image1.Height & " %"
cropbottom = 100 - ((CpR.Height + CpR.Top - Image1.Top) * 100 / Image1.Height) & " %"
End Sub