XL 2016 Copier et coller une plage en image

[garnote]

Bonjour, bonsoir ou bonne nuit, selon le cas,

Je dois sélectionner une plage contenant des cellules noires ou blanches pour en faire des images auxquelles je fais faire diverses rotations avec VBA, mais ses sacrées images ne s'alignent pas avec une précision absolue avec les cellules qu'elles contiennent. Vous connaissez un truc pour m'enlever cette épine du pied sans être obligé d'essayer d'y arriver manuellement pour chacune des images pivotées ?
S'il était possible de faire pivoter une plage sans passer par une image, ce serait le pied!

Merci de votre attention et salutations distinguées!
Serge

 

[TooFatBoy]

Bonjour,

Commence peut-être par utiliser des cellules carrées ?

Sinon, il y a ici un immense spécialiste du zoom, du positionnement au pixel près, et autres trucs dans le même genre, c'est patricktoulon.
Il doit pouvoir te résoudre ça en une seconde trois quarts.

 

[patricktoulon]

Bonsoir
alors on regarde bien
rng=range à copier en image
rng2=range ou on va placer la copie image

Sub copyImg(rng As Range, rng2 As Range)
     rng.copy: rng.Parent.Pictures.Paste
      Set shap = rng.Parent.Pictures(rng.Parent.Pictures.Count)
       shap.ShapeRange.Fill.Visible = True ' opacifie les partie transparentes de l'image
      d = GetDimPositionShapeCenterRange(rng2, shap)

    'on place et dimentionne l'image dans la plage de destination
    With shap
        .Left = d(0)
        .Top = d(1)
        .Width = d(2)
        .Height = d(3)
        .ShapeRange.Line.Visible = True    'pour que l'on puisse bien voir sa position dans la plage de cellule
    End With
End Sub


Function GetDimPositionShapeCenterRange(rng As Range, shap, Optional PercentMarge As Long = 100, Optional NoRedim As Boolean = False)    'la marge exprime un pourcentage de 1 à x%
'collection fonctions perso Catégorie [IMAGES] by patricktoulon sur exceldownloads
    Dim Ratio#, Wx#, Hy#, Tp#, LfT#
    Ratio = Application.Min(rng.Width / shap.Width, rng.Height / shap.Height)
    If NoRedimXY Then Ratio = 1: PercentMarge = 100
    Wx = (shap.Width * Ratio) * (PercentMarge / 100)
    Hy = (shap.Height * Ratio) * (PercentMarge / 100)
    Tp = rng.Top + ((rng.Height - Hy) / 2)
    LfT = rng.Left + ((rng.Width - Wx) / 2)
    GetDimPositionShapeCenterRange = Array(LfT, Tp, Wx, Hy)
End Function

voilà

 

[patricktoulon]

re
si ta plage de réception ou ta plage copier n'est pas carré forcement ta rotation va faire de bulles
pour cela il te faut calculer le ration non pas par rapport aux cotés plage copié et plage reception mais le ratio diagonale --> plage réception
ce qui implique l'image ne pourra pas prendre tout la place de la reception mais elle sera centré dans la reception et tu pourra la faire pivoter degré par degré sans jamais qu'elle dépasse de la plage de réception

 

[TooFatBoy]

ce qui implique l'image ne pourra pas prendre tout la place de la reception mais elle sera centré dans la reception et tu pourra la faire pivoter degré par degré sans jamais qu'elle dépasse de la plage de réception

Il suffit de redimensionner l'image lors du collage. Nan ?

 

[garnote]

@TooFatBoy et @patricktoulon
Salut !
Bien sûr, il me faut, pour ce que je veux faire, des cellules parfaitement carrées.
Où avais-je la tête?
Quant au reste, demain, j'étudierai attentivement vos sages propositions.
Bonne journée!
Serge

 

[patricktoulon]

Attention ma méthode gade l'aspect ratio de l'image
ce qui implique que si ce n'est pas carré des deux coté( image/plage de réception) l'image est redimensionnée automatiquement en gardant l'aspect ratio elle ne rempli pas toute la plage
si les rotions sont des multiple de 90 il n'y a pas de soucis par contre si les rotations ne sont pas des multiple de 90 alors il faudra redimensionner l'image avec la dimensions de la dialgonale et calcul ratio image/plage de réception pour que de 0 à 360 elle ne sorte jamais de la surface de réception

 

[garnote]

Bonjour @patricktoulon
Mystère et boule de rhum! J'ai copié ta macro dans un module et quand je clique Macros/Afficher les macros, elle n'apparaît pas dans la liste des macros! Quant à mes transformations, je ne fais que des rotations de 90°, 180°, 270° et des retournements horizontaux ou verticaux. Quant aux cellules "vraiment" carrées, je donne le même nombre de pixels à la hauteur des lignes et la largeur des colonnes. Ai-je ainsi des vraies de vraies cellules carrées?
Et j'ai réussi à faire lesdites rotations pour une plage de 4 x 4 sans passer par une image.
Bonne journée et merci pour ton aide.
Serge

 

[TooFatBoy]

Quant aux cellules "vraiment" carrées, je donne le même nombre de pixels à la hauteur des lignes et la largeur des colonnes. Ai-je ainsi des vraies de vraies cellules carrées?

Comment fais-tu cela ???

Rien n'est moins sûr...

 

[Staple1600]

Bonsoir le fil

Je ne suis pas John
Je ne suis pas Leu
Mais suis-je Carré ?

Sub Grille(x)
Cells(1).Resize(x, x).ColumnWidth = 0.08
Cells(1).Resize(x, x).RowHeight = 0.75
End Sub
Sub test()
Grille Asc("Staple") + 1517
End Sub

NB: veuillez excusez cette petite futilité égomaniaque avec Asc
Mais il parait que lorsqu'on rit, on économise un steak
En ces temps troublés, c'est déjà cela de pris

 

[patricktoulon]

bonsoir
à l'anciennedes carré de 30 points

Sub test()
    sizeToCARRE [A1:F10], 30
End Sub
Function sizeToCARRE(Rng, taille)
    With Rng.Cells(1)
        .ColumnWidth = taille / 2
        .RowHeight = taille * 2
        Do While .Height > 30 And .Width > 30
            If .Width > 30 Then .ColumnWidth = .ColumnWidth - 0.1
            If .Height > 30 Then .RowHeight = .RowHeight - 0.1
        Loop
   With Rng
   .RowHeight = Rng.Cells(2).RowHeight
   .ColumnWidth = Rng.Cells(2).ColumnWidth
   End With
   End With

End Function

 

[garnote]

Ça donne des "carrés" de 80 pixels de large et de 79 pixels de haut. Et pour continuer notre emballement pour les fractales, voici le début d'une que j'ai baptisée Fractale F.

 

[TooFatBoy]

Quant aux cellules "vraiment" carrées, je donne le même nombre de pixels à la hauteur des lignes et la largeur des colonnes. Ai-je ainsi des vraies de vraies cellules carrées?

Comment fais-tu cela ???

 

[garnote]

Comment fais-tu cela ???

Je sélectionne toutes (pas obligatoire) les cellules d'une feuille et je tiens mon "clic" sur les lignes séparant les colonnes ou les lignes et je vois, entre parenthèses, le nombre de pixels. Curieusement, la dernière macro, nommée Test de @patricktoulon semble faire apparaître de vrais carrés. J'avais choisi 80 pixels par 80 avec ma méthode manuelle, mais ses carrés sont de 80 pixels de large et 79 de haut semblent plus carrés. ???
Mystère et boule de rhum!

 

[TooFatBoy]

Merci pour ta réponse très précise !

Je sélectionne toutes (pas obligatoire) les cellules d'une feuille et je tiens mon "clic" sur les lignes séparant les colonnes ou les lignes et je vois, entre parenthèses, le nombre de pixels.

Pas mal du tout ta méthode : la cellule parait bien carrée à l'écran.

Curieusement, la dernière macro, nommée Test de @patricktoulon semble faire apparaître de vrais carrés. J'avais choisi 80 pixels par 80 avec ma méthode manuelle, mais ses carrés sont de 80 pixels de large et 79 de haut semblent plus carrés !
Mystère et boule de rhum!

Chez moi ses cellules ne font pas 80 mais 100 pixels de large sur 79 pixels de haut, et visuellement ne sont pas du tout carrées.

[edit]
Bizarre, je viens de lancer la macro sur un fichier vierge, et cette fois-ci j'obtiens bien des cellules de 80 sur 79, comme toi.
[/edit]

[edit2]
Encore plus bizarre : avec un troisième fichier ça me donne des cellules de 46 sur 79 pixels.
Il doit y avoir un "léger" problème dans la logique de la macro...
[/edit2]