XL 2016 Webcam pour une photo type carte identité

[fanch55]

Salut à tous, mais cela est dirigé vers PatrickToulon dont je suis pas mal de fils intéressants (partout) et dont je me suis inspiré pour cette source .
Je joint contrairement à mon habitude un fichier complet en XLSM ( gare aux autorisations, mais je le certifie sans malveillance aucune [ de ma part] ) .
Ce fichier effectue une capture photo à partir de la webcam ( ou un fichier image ) et le réduit/redimensionne au format carte identité ou tout au moins aux dimensions 3.5 cm x 4.5 cm .
La partie intéressante est de transformer la photo rognée en une image conforme au but, c'est à dire de ne pas conserver l'image originale trop volumineuse .

Le besoin est de pouvoir fournir une photo de faible dimension au format CI pour des licences de pétanques (entre autre)

Tout point d'amélioration est le bienvenue .
Pour ceux qui n'ont pas de webcam sur le poste fixe, j'ai testé avec Droidcam sur le smartphone et Droidcam Client sur Pc, c'est opérationnel (j'en suis bluffé).

 

[patricktoulon]

re
bon j'ai fait des recherches et voici ce qui fonctionne

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

 

[fanch55]

Oki, tu ne vois pas de propriété Crop dans l'espion ?
Désolé, j'ai attrapé une grippe carabinée, j'ai du me coucher tôt avant d'avoir les traces du clavier sur mon front ...

 

[patricktoulon]

re
bonjour franch55
ben non dans les variables locales apres l'erreur il semblerais que vba essai d'appliquer des propriétés des (pictures ou shape) à un range c'est bizarre ya une confusion avec "Selection"

cela dit ce matin j'ai fait exactement la même chose que mon userform mais sur un sheet avec le crop d'excel
çà donne ceci

par contre ça fonctionne pas correctement pour toutes les images quand elles ont un format différent
donc le multiplicateur 4.135 n'est pas bon je saisi pas comment trouver le multiplicateur commun

je joint le fichier

 

[fanch55]

 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

Ton code ci-dessus modifié fonctionne correctement chez moi .
Après avoir bien galèré avec les cropleft/cropright/croptop/cropbottom qui semblent dépendre d'un ratio que je n'ai pas identifié et en plus le modifier ( si tu en change l'ordre, le résultat diffère ) , je les ai abandonné pour utiliser les crop.* bien plus simples à manipuler .

Je vais tester ton dernier code

 

[patricktoulon]

re
on le gere pas sur 2007 le crop.shapeleft etc
ton code ne peut fonctionner chez moi ca plante directe a l'exécution du bouton mso PictureCrop
et le crop.xxxxx non plus
c'est pour ca que je cherche le coeff

 

[fanch55]

Testé ton dernier envoi.
Pas mal, tu brûles, hyper-intéressant ...
mais tu t'es heurté manifestement aux cropleft/cropright/croptop/cropbottom

je t'ai mis dans la vidéo les volets de propriétés des images, ce que les utilisateurs ne sont pas censés voir ...

Donc en fait mon code ne fonctionne qu'à partir de la version d'Office 2010 ou moins mais en tout cas supérieure à 2007 .

Quand on voit que Office 2010 est annoncé en fin de support en octobre 2020 , faut-il faire un palliatif pour cela ?

 

[patricktoulon]

re
et oui c'est ca
j'essai de trouver mais rien n'y fait
je le demande comment obtenir ce coeff
j'ai taté du coté de centimeterstopoints mais c'est pas ca
tu m'a parlé d'ordre aussi c'est quoi l'ordre de coupe

 

[patricktoulon]

en attendant que je trouve sur feuille voici la version beta dans un serform
tu peux la zoomer et la déplacer
meme zoomée la coupe est a taille réelle

 

[fanch55]

Cropseur d'image.xlsm :

C'est étonnant, le val fonctionne sur ton excel ?

Quand à l'ordre des cropleft etc..., j'ai abandonné au bout de 3 heures, pas de résultat logique ou tout au moins intuitif .

 

[patricktoulon]

re
ben non c'est normal qu'il fonctionne
msgbox val("224.456agdncgfhtyfjfh")
les variables locales elle te disent quoi ?
ajoute ".Value" peut etre que sur 2016 c'est moins permissif avec vba 7

 

[fanch55]

Cropseur d'image.xlsm :
J'ai bien rajouté .value aussitôt, même erreur .
Amusant, je découvre une particularité à val() sur mon excel 2016 ? :

Problème résolu, j'ai modifié les lignes concernées en faisant un replace du % par rien .
Y resterait encore pas mal de boulot: adapter tout ça en cm, interdire au calque de sortir de l'image.

Crops sur feuille.xlsm :
J'ai modifié la partie ci-dessous , cela fonctionne, c'est tordu mais semble logique, pas besoin de ratio :

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

'Application.CommandBars.ExecuteMso ("PictureCrop")' pas vraiment besoins
Dans ce cas précis, c'est vrai car tu as déjà fait le boulot de déplacement du Calque auparavant, mais c'est aussi bien .
Il faudrait interdire de redimensionner le calque ( c'est un shape ), à suivre ...

 

[patricktoulon]

re
et ben non ça ne crop pas limage correctement tout du moins par rapport au shape " calque"
essaie plusieurs images de différent format

pour le model userform
on peut toujours zoomer mais on ne sort plus du cadre
j'ajoute une sub et l’appelle du mousedown et les deux scroll
c'est un premier jet je vais certainement simplifier

'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

 

[patricktoulon]

re
j'ai supprimé les "%" des textbox et les ai mis dans des labels
j'ai bloqué l'image et le label CpR dans la frame ils ne peuvent plus sortir
j'ai fait le jeu de enabled entre les boutons pour ne plus pouvoir cliquer sur le bouton enregistrer quand ca a été fait avant de reloader une image et si CpR est visible

 

[patricktoulon]

re
allez voila on a maintenant la photo d'identité de 3.5 par 4.5 cm
pour cela ,après avoir cliquer sur crop coche le checkbox le CpR va se dimensionner au ratio
zoom l'image et place CpR a ta convenance pour la photo et klick sur enregistrer la photo et pas le bouton enregistrer la portion de toute façon en mode photo coché ce bouton est disabled

résultat après avoir insérer la capture manuellement dans le sheets

c'est l'avantage de travailler au pourcentage je n'ai pas a me soucier de la formule de calcul
c'est bien WIA non et ca marche chez toi et chez moi
je récapitule donc

1. l'image est zoomable
2. elle ne peut plus sortir du cadre
3. le claque"Cpr"(le label) lui aussi ne peut plus sortir du cadre
4. on peut enregistrer la portion a l’échelle réelle
5. on peu enregistrer la portion au format 3.5 par 4.5(photo d'identité)

 

[MJ13]

Bonjour à tous

Cette semaine j'ai développé une appli pour découper des images avec ce code qui rejoint un peu le vôtre, mais je découpe l'image sur la feuille qui doit être positionnée en A1.

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