XL 2016 Webcam pour une photo type carte identité

fanch55

XLDnaute Barbatruc
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é).
 

Pièces jointes

  • Camera.xlsm
    107.9 KB · Affichages: 84

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour 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 :)
 

patricktoulon

XLDnaute Barbatruc
Bonjour 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 :)
bonjour a tous
@arthour973 enlève le ça ne t'est pas utile c’était juste pour positionner le dialog sur le dossier d'image window

@MJ13 non c'est pas ca du tout
en fait le crop se fait sur le pictureformat du shaperange d'une picture
et il se fait en se basant sur le WIDTH ORIGINAL! et le HEIGHT ORIGINAL! ET surtout en pourcentage et non en point ou cm ou pixel
j'ai cravaché comme un âne pour le comprendre avec des calculs ramenant a size original
et quand j'ai trouvé ma formule j'ai cherché dans ce sens sur le net et j'ai trouvé tout de suite
comme quoi quand on sait pas :oops: :oops: :oops: :oops: :p

@tous
en fait franch55 et moi avions tout faux quand au calcul a opérer c'est pour cela que l'on trouvait pas de logique
le crop doit se faire comme suit
'Crop-->(Left,Top,Right,Bottom) = original Size(width ou height) * pourcentage / 100
exemple
.cropLeft =1024*50/100
'les 1024 étant le width d'origine!!!!!!!! ((((meme si elle a été redimentionnée)))) ce qui nous donne une image coupé a gauche de 50%
quand je pense que je me suis pris la tète:confused::oops::rolleyes:

nous voila donc avec ma version 2.0 sur feuille qui opère de cette façon et le résultat est parfait

elle est belle ma demo :p
demo3.gif


pffffiu puré!!!!
képrizdetete!!!

bon maintenant je vais regarder ce qu'a fait MJ13
un fichier aurait été bien venu ;)
 

Pièces jointes

  • crops sur feuille V 2.0.xlsm
    27.9 KB · Affichages: 14

MJ13

XLDnaute Barbatruc
Re Patrick

Tu as raison, cela ne fonctionne pas avec tout types d'images, juste avec celle qui font 2048 de large, c’était mon besoin au départ.

Il y a quand même des choses bizarres qui me dépassent avec le traitement d'images sur Excel. :)
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
bizarre non il suffit de connaître la formule qui est assez simple en fait
contrairement a beaucoup dans excel ici on exprime un calcul en % et le prorata se fait en interne par rapport aux dims actuelles par aux dims d'origines

eu t il fallu que je le susse :p ;) la version 2.0 est nickel tu peux tester
et voici la version 2.1 avec tout simplement le bouton pour enregistrer la coupe
 

Pièces jointes

  • crop image sur feuille V 2.1.xlsm
    35.7 KB · Affichages: 15

fanch55

XLDnaute Barbatruc
Crops sur feuille :
modifié le code comme ci-dessous :
VB:
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
Ca a l'air de fonctionner, à moins que qqchose m'ait échappé ..
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
bonsoir franch55 oui j'ai pas tester mais ça a l'air d’être ça en fait ça se fait comme je le fait dans mon userform (en pourcentage)
tes formule sont simplifiée je testerais tout a l'heure

ça fonctionne sinon chez toi non?avec crpLeft et non crop.ShapeLeft etc ....
 

fanch55

XLDnaute Barbatruc
Crop image sur feuille V 2.1 :

Brut de décoffrage:
Tout bon, mais souffre de qq défauts :
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
1582233265407.png


Sinon, j'ai été confronté à une image sauvegardée dans une taille ne correspondant pas à la taille CI, mais j'ai été incapable de le reproduire .... je vais creuser
En tout cas c'est plus "agréable" à manipuler que le crop natif ... mais ça nécessite plus de calculs ...:p

Pour le code que je t'ai soumis :
Si tu l'as laissé tel quel, c'est normal, puisque l'image a été "resizée" pour visu à la ligne ci-dessous en gras :

....
....
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
 

patricktoulon

XLDnaute Barbatruc
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
ha oui ça j'y ai pas pensé
je vais faire la même chose que le userform
1 peut pas sortir du cadre de l'image et pas plus grand sous la forme d'un avertissement

bon je n'arrive pas a tomber sur division by zero mais en effet quand le calque sort du cadre de limage le crop coupe bien les bords interieurs dans l'image mais crée les reste en transparent
démonstration
demo3.gif

il va falloir donc corriger ce point
j'ai deja mon idée le faire en silencieux lors du click sur crop ;)

ps: ca yest j'ai trouvé l'erreur "division by zero" c'est quand cote de l'un est egal a l'autre
exemple
percentLeft = 100 / (pict.Width / (Calque.Left - pict.Left )) si les deux left sont identique on est dedans
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
et voila c'est corrigé
VB:
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
 

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 846
dernier inscrit
Silhabib