Canevas (P1)

.
Présentation

Aujourd'hui je vous propose une nouvelle étape dans la découverte de la programmation VBA (Visual Basic pour Applications), avec une réalisation qui se poursuivra sur plusieurs articles. Néanmoins, dès ce premier volet, le code sera utilisable, car devoir attendre la fin d'une série avant de pouvoir en profiter est frustrant.

Il s'agit d'une idée qui m'a été soufflée par une collègue accro au point de croix découvrant BitMap_Mono : générer à partir d'images en couleurs des canevas servant de modèles à cette forme de broderie.

Principe de Fonctionnement

Ce programme travaillera avec des images (BitMap) en couleurs réelles (sur 24 bits), et en effectuera un agrandissement. Chaque pixel de l'image source sera converti en un rectangle de la même couleur, encadré par une fine bordure. Les bordures des rectangles contigus seront confondues, formant ainsi une Grille. L'image ainsi obtenue (le Canevas) sera enregistré au même endroit que l'image source.

Le Code

Dans cette première partie, le code ci-dessous est utilisable quel que soit l'hôte (word, excel, etc..), et peut être installé n'importe où (ThisDocument, ThisWorkbook, Feuilles, etc..) cependant je vous suggère déjà de le coller dans un Nouveau Module. Pour ce faire, un clic droit dans l'Explorateur de projets de l'éditeur VBA, puis Nouveau, et Module..

Vous pouvez lancer ce code en l'état, depuis l'interface VBA. Repérez la procédure nommée "C_Charge_Click". Placez le curseur n'importe où dedans (entre Private Sub et End Sub) et cliquez sur Play (ou touche F5)..

..ou effectuer un premier habillage, en créant sur la Page Word, ou la Feuille Excel, un Bouton nommé "C_Charge", puis en déplaçant la procédure "C_Charge_Click" dans l'objet associé (ThisDocument, Feuil1, etc..)

' -----------------
' Zone Déclarations
' -----------------
Const TRT = "Traitement impossible [", Src = "Création Canevas"
Const ZX = 5, ZY = 5 ' Facteurs d'Agrandissement
Const CCL = &H808080 ' Couleur de la Grille
Dim PT&(1 To 2), P As String * 1 ' Pointeurs et Buffer

' ----------------
' Bouton "Charger"
' ----------------
Private Sub C_Charge_Click()
Dim FD As FileDialog
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
    .AllowMultiSelect = False: .ButtonName = "Charger"
    .Filters.Clear: .Filters.Add "BMP (24bits)", "*.BMP": .Show
End With
If FD.SelectedItems.Count Then Canevas FD.SelectedItems(1)
End Sub

' ------------------------
' SUB: Création du Canevas
' ------------------------
Sub Canevas(ByVal Fic$, Optional ByVal FX& = ZX, Optional ByVal FY& = ZY, _
            Optional CL& = CCL)
' Coefficients Zoom (Zoom maxi arbitraire)
If FX& < 3 Or FX& > 12 Or FY& < 3 Or FY& > 12 Then _
    MsgBox TRT + "Fact Zoom]", vbCritical, Src: Exit Sub
' Séparation Chemin-Nom
T1 = InStr(Fic$, "\"): While T1: T2 = T1: T1 = InStr(T2 + 1, Fic$, "\"): Wend
If T2 Then D$ = Left$(Fic$, T2): Fic$ = Mid$(Fic$, T2 + 1) Else D$ = ""
Open D$ + Fic$ For Random As #1 Len = 1
' Récupération de l'En-Tête Source
If HDR(Fic$, 1, 1, TT&, TE&, TP&, TD&, TB&, TI&, TX&, TY&) = False Then
    MsgBox TRT + "Lect HDR]", vbCritical, Src
Else
    If TP& <> 0 Or TB& <> 24 Or TI& <> 1 Then
        MsgBox TRT + "Cont HDR]", vbCritical, Src
    Else
        ' Calculs Source et Canevas
        TX2& = TX& * FX& + 1: TX3& = 4 * ((3 * TX2& + 3) \ 4): TY2& = TY& * FY& + 1
        TM& = TE& + TP& + 1: TM2& = TM&: TX1& = 4 * ((3 * TX& + 3) \ 4)
        TD2& = TX3& * TY2&
        ' Dimensions Maximales Source et Canevas (brides arbitraires)
        If TX& > 1024 Or TY& > 1024 Then
            MsgBox TRT + "Taille SRC]", vbCritical, Src
        ElseIf TX2& > 9001 Or TY2& > 9001 Then
            MsgBox TRT + "Taille CAN]", vbCritical, Src
        Else
            ' Création de l'En-tête Canevas
            Open D$ + "Can_" + Fic$ For Random As #2 Len = 1
            P = Chr$(0): For T1 = 1 To 54: Put #2, T1, P: Next T1
            Ecr 19778, 1, 2: Ecr TD2& + TE& + TP&, 3, 4
            Ecr TM& - 1, 11, 2: Ecr TD2&, 35, 4: Ecr TB&, 29, 2: Ecr TI&, 27, 2
            Ecr TX2&, 19, 2: Ecr TY2&, 23, 2: Ecr 40, 15, 2
            ' Ligne Séparatrice Basse
            PT&(2) = TM2&
            For T1 = 1 To TX2&: Ecr CL&, 0, 3: Next T1: GoSub SSRemp
            ' Ecriture Données
            For Y = TY& To 1 Step -1: Debug.Print "Encore" + Str$(Y) + " Ligne(s)"
                ' Ecriture Ligne Image
                For Y2 = 1 To FY& - 1
                    PT&(1) = TM&
                    For X = 1 To TX&
                        Ecr CL&, 0, 3: V& = Valr(0, 3)
                        For X2 = 2 To FX&: Ecr V&, 0, 3: Next X2
                    Next X
                    Ecr CL&, 0, 3: GoSub SSRemp
                Next Y2
                ' Ecriture Ligne Séparatrice
                PT&(2) = TM2&
                For T1 = 1 To TX2&: Ecr CL&, 0, 3: Next T1: GoSub SSRemp
                TM& = TM& + TX1&
            Next Y: Debug.Print "Terminé.."
            ' Fin
            Close #2
            MsgBox "OK", vbInformation, Src
        End If
    End If
End If
Close #1
Exit Sub
' SSub: Termine au besoin la ligne par du zéro..
SSRemp:
P = Chr$(0): TM2& = TM2& + TX3&: For T1 = PT&(2) To TM2& - 1: Put #2, T1, P: Next T1: PT&(2) = TM2&
Return
End Sub

' ----------------------------------------------------
' FCT: Récupère le Numérique sur Nb Octets depuis Posi
' ----------------------------------------------------
Function Valr(Posi, Nb, Optional Luno As Integer = 1)
V& = 0: If Posi > 0 Then PT&(Luno) = Posi
For N& = (CLng(PT&(Luno)) + Nb - 1) To CLng(PT&(Luno)) Step -1
    Get #Luno, N&, P: V& = V& * 256& + Asc(P)
Next N&
Valr = V&: PT&(Luno) = PT&(Luno) + Nb
End Function

' ----------------------------------------------------
' FCT: Ecrit le Numérique V& sur Nb Octets depuis Posi
' ----------------------------------------------------
Function Ecr(ByVal V&, Posi, Nb, Optional Luno As Integer = 2)
If Posi > 0 Then PT&(Luno) = Posi
For N& = CLng(PT&(Luno)) To (CLng(PT&(Luno)) + Nb - 1)
    P = Chr$(V& Mod 256): Put #Luno, N&, P: V& = V& \ 256&
Next N&
PT&(Luno) = PT&(Luno) + Nb
End Function

' -------------------------------------
' FCT: Renvoie les Infos de l'en-tête..
' -------------------------------------
Private Function HDR(Fic$, Luno As Integer, Aff As Boolean, _
        TT&, TE&, TP&, TD&, TB&, TI&, TX&, TY&) As Boolean
On Error Resume Next
Err.Number = 0
' Acquisition de l'En-Tête
TT& = Valr(3, 4, Luno): TE& = 54: TP& = Valr(11, 2, Luno) - 54
TD& = Valr(35, 4, Luno): TB& = Valr(29, 2, Luno): TI& = Valr(27, 2, Luno)
TX& = Valr(19, 2, Luno): TY& = Valr(23, 2, Luno)
' Afficher le Message d'Informations ?
If Aff Then
    If Err.Number Then
        MsgBox "Erreur HDR", vbCritical, "Fichier: " + Fic$
    Else
        MsgBox "Taille Totale:" + Str$(TT&) + " Octets" + vbCrLf _
            + "Taille En-Tête:" + Str$(TE&) + " Octets" + vbCrLf _
            + "Taille Palette:" + Str$(TP&) + " Octets" + vbCrLf _
            + "Taille de la Data:" + Str$(TD&) + " Octets" + vbCrLf _
            + "Bits par Couleur:" + Str$(TB&) + vbCrLf _
            + "Nombre de Plans:" + Str$(TI&) + vbCrLf _
            + "Dimension X:" + Str$(TX&) + " Pixels" + vbCrLf _
            + "Dimension Y:" + Str$(TY&) + " Pixels" + vbCrLf, _
            vbInformation, "Fichier: " + Fic$
    End If
End If
' Sortie
HDR = (Err.Number = 0)
End Function

Explications

Certes, ce code est plus long que d'habitude. Nous allons l'éplucher. Par la suite, il n'évoluera presque pas..

Commençons par le point d'entrée, la procédure "C_Charge_Click". Elle déclare et paramètre un FileDialog de type FileDialogFilePicker, nommé FD. C'est la boîte de sélection de fichiers d'Office. Elle n'autorise ici qu'un seul fichier à la fois, et invoque la procédure "Canevas", à laquelle elle transmet les Chemin+Nom dudit fichier.

Enchaînons avec les deux procédures de petite taille, "Valr" et "Ecr". Elles servent respectivement à la lecture et à l'écriture dans un Fichier.

Function Valr(Posi, Nb, Optional Luno As Integer = 1)
Il s'agit d'une Fonction, à laquelle on fournit 3 paramètres, le dernier étant optionnel. Posi correspond à l'octet de départ, Nb au nombre d'octets consécutifs à lire, et Luno le numéro de Canal associé au Fichier à lire, par défaut 1 ici. Valr renvoie une valeur numérique, assemblant les valeurs des octets lus ainsi:
Valr = 1 x Octet{Posi} + 256 x Octet{Posi+1}+ 256² x Octet{Posi+2}, etc..

Function Ecr(ByVal V&, Posi, Nb, Optional Luno As Integer = 2)
Certes cette procédure est une fonction, mais elle ne renvoie rien. Un Sub déguisé, en somme.. C'est le pendant de Valr, qui écrit suivant la même logique la décomposition de V& dans les Nb octets à partir de Posi.

Ces deux Fonctions serviront tout au long du reste du programme..

Une troisième fonction va nous servir à lire l'En-Tête de l'image source, et récupérer tous les paramètres descriptifs qu'il contient. C'est "HDR":

Private Function HDR(Fic$, Luno As Integer, Aff As Boolean, _
TT&, TE&, TP&, TD&, TB&, TI&, TX&, TY&) As Boolean
Les trois premiers paramètres sont en entrée, Fic$ est le nom de fichier qui sera éventuellement affiché, Luno le numéro de Canal associé à l'image source, et Aff un booléen: à True, HDR affichera une fenêtre récapitulant les paramètres descriptifs de l'image, à False non..

HDR renvoie les 8 paramètres descriptifs suivants:
TT&: Taille Totale (Octets)
TE&: Taille En-Tête (Octets)
TP&: Taille Palette (Octets)
TD&: Taille de la Data (Octets)
TB&: Bits par Couleur
TI&: Nombre de Plans
TX&: Dimension X (Pixels)
TY&: Dimension Y (Pixels)
ainsi qu'un résultat booléen, valant True si la lecture de l'En-Tête s'est déroulée sans erreur..

Rappel: dans un BitMap, le Fichier commence par un En-Tête de 54 octets, suivi éventuellement d'une Palette, puis de la zone Data, dans laquelle les lignes de l'image sont stockées de bas en haut sans forme de compression. Le nombre de plans signifie qu'un BitMap est capable de contenir plus d'une image, concrètement je ne l'ai jamais vu appliqué..

Maintenant on peut commencer :P

Sub Canevas(ByVal Fic$, Optional ByVal FX& = ZX, Optional ByVal FY& = ZY, Optional CL& = CCL)
Cette procédure (Sub) est le coeur de notre programme. Tous les paramètres sont en entrée. Fic$ contient les Chemin+Nom de l'image source, le "ByVal" signifie que "Canevas" recevra une copie de cette variable, donc que toute modification ne sera pas répercutée vers l'appelante (c'est un paramètre en entrée seulement). FX& et FY& sont les coefficients d'agrandissement horizontal et vertical. Ils sont optionnels, et en cas d'omission la copie créée (ByVal) prendra la valeur de la Constante ZX ou ZY correspondante. De même pour CL& qui précise la couleur de la Grille (constante CCL).

Canevas commence par vérifier que FX& et FY& (les zooms) sont compris entre 3 et (arbitrairement) 12. Ensuite nous recherchons le dernier séparateur "\" dans Fic$ pour dissocier le Chemin et le Nom de l'image source.

Open D$ + Fic$ For Random As #1 Len = 1
Cette instruction "ouvre" le fichier de l'Image Source en Lecture/Ecriture à Accès Direct (Random), en l'associant au Canal #1, avec des Enregistrements (zones accessibles individuellement) de taille (Len) 1 octet. En clair, le numéro de l'enregistrement devient le numéro de position de l'octet.

If HDR(Fic$, 1, 1, TT&, TE&, TP&, TD&, TB&, TI&, TX&, TY&) = False [..]
Cette ligne effectue deux actions: elle invoque d'abord "HDR" (sur le Canal 1, image source, et avec demande d'affichage du résumé). HDR renvoie un booléen, True si réussi, False sinon. Dans le cas d'échec (False), afficher un message d'erreur.

If TP& <> 0 Or TB& <> 24 Or TI& <> 1 [..]
Autre test: l'image source ne doit pas avoir de Palette (TP&=0), doit être en couleurs réelles 24 bits (TB&=24), et ne doit contenir qu'un seul plan (TI&=1).

La source validée, calculons les paramètres descriptifs du Canevas à générer:
TX2&: La Largeur en X
TX3&: Il s'avère que dans un BitMap, les Lignes sont complétées à droite jusqu'à concurrence d'une largeur multiple de 4 octets..
TY2&: La Taille en Y
TM&: Point de Départ de la Lecture d'une Ligne Source, initialement le premier octet suivant l'En-Tête et la Palette (source).
TM2&: Idem TM&, mais pour l'Ecriture dans le Fichier Canevas.
TX1&: Idem TX3&, mais pour l'Ecriture dans le Fichier Canevas.
TD2&: Taille de la Zone Data du Fichier Canevas.

If TX& > 1024 Or TY& > 1024 Then [..]
[..] ElseIf TX2& > 9001 Or TY2& > 9001 Then [..]
Deux autres tests, les dimensions maximales sont bridées (arbitrairement) à 1024 pour la Source, et 9001 pour le Canevas.

Open D$ + "Can_" + Fic$ For Random As #2 Len = 1
Comme l'autre "Open", cette instruction ouvre (et crée au besoin) le Fichier Canevas, sur le Canal #2, dans le même répertoire que la Source, et de même nom, cependant préfixé par "Can_".

P = Chr$(0): For T1 = 1 To 54: Put #2, T1, P: Next T1
Cette boucle initialise les 54 octets de l'en-tête avec du zéro. "P" est ici notre Buffer (tampon). Excepté celui qui charge "BM" dans les deux premiers octets (signature d'un BitMap), les "ECR" répondent aux "VALR" de "HDR"..

Boucles d’Image:

Nous allons parcourir la Zone Data de l’Image Source linéairement, en ne sautant que les remplissages de fins de lignes. Cela signifie que nous allons parcourir l’image de la dernière ligne (celle du bas) à la première (celle du haut). Pour chaque ligne source, la lecture se fera de gauche à droite, pixel par pixel, donc par 3 octets à la fois, via Valr( [..] , 3 ).

Ce sont les boucles "1" (lignes) et "3" (pixels):
"1": For Y = TY& To 1 Step -1
"3": For X = 1 To TX&

Pour chaque pixel source, nous devons créer un rectangle de FX& x FY& pixels dans le canevas. Afin de confondre les lignes de grille, seuls deux des côtés du rectangle seront bordés. Arbitrairement, ce seront les bords gauche et haut, les deux autres "récupérant" ceux de leurs voisins. Il nous faudra traiter séparément les extrémités droite et basse de l’image, exceptions à ce principe car n’ayant plus de voisins..

Accessoirement, notez la présence de "SSRemp". Il complète si nécessaire la ligne écrite par du zéro à droite, car la largeur, rappelez-vous, se doit d’être multiple de 4 octets. "SSRemp" sera invoqué à chaque écriture de ligne dans le Canevas.

Nous aurions pu opter pour l’écriture rectangle par rectangle, j’ai préféré celle ligne par ligne, plus simple à comprendre. Puisque nous partons du bas, démarrons par une ligne de grille (complétée par "SSRemp").

Pour chaque ligne source (que nous relirons donc autant de fois que nécessaire), nous allons créer (FY& - 1) lignes de Canevas (identiques), où chaque pixel source donnera lieu à un pixel (gauche) suivi de (FX& - 1) pixels de la couleur de celui source. Chacune de ces lignes sera complétée par le pixel de grille (l’extrémité droite) puis "SSRemp".

Ce sont les boucles "2" (nombre de lignes) et "4" (parcours de ligne):
"2": For Y2 = 1 To FY& - 1
"4": For X2 = 2 To FX&

Ces quatre boucles sont évidemment entrelacées: "pour chaque ligne source (1) créer plusieurs lignes canevas (2) dans lesquelles pour chaque pixel source (3) créer plusieurs pixels canevas (4)".

Pour chaque ligne source nous devons ajouter une ligne séparatrice (celle du haut), donc ..sous celles de nos rectangles.

Voilou :)

Dans la seconde partie { article Canevas (P2) }, nous offrirons à ce code (que nous ne modifierons que très peu) une IHM (interface humain-machine) un peu plus digne d’un programme "professionnel" (rigolez pas..). Ce sera une fenêtre permettant de paramétrer et de lancer "Canevas" sans passer pas l’éditeur VBA.. Un troisième article { Canevas (P3) } étoffera notre interface d’un gadget "amusant" de sélection de couleur de grille..

-MyLzz59-