Sub ÉcrireFichierBMP()
Tâche "Production de l'image (plan B)", XbmMax * YbmMax
If UCase(Right(ChNomF, 4)) <> ".BMP" Then
Dim Va As Variant
Va = Application.GetSaveAsFilename(Left$(ChNomF, DernierDans(ChNomF, ".") - 1), "BitMaps,*.bmp", Title:=NomTâche)
If Va = False Then AbandonTâche "réf. fichier non fournie": Succès = False: Exit Sub
ChNomF = Va
Range("RéfFicSor").Value = Replace(ChNomF, "\", vbLf, DernierDans(ChNomF, "\"), 1): End If
Open ChNomF For Binary Access Write As #1 Len = 1
Const BM As String * 2 = "BM": Put #1, 1, BM
BitPx = 24: NbCoul = 0
LgL = 4 * ((XbmMax * BitPx + 31) \ 32): LgM = LgL * YbmMax
LgE = 4 * NbCoul + 54: LgF = LgE + LgM
Put #1, 3, LgF: Put #1, 7, 0&: Put #1, 11, LgE: Put #1, 15, 40&
Put #1, 19, XbmMax: Put #1, 23, YbmMax
Put #1, 27, 1: Put #1, 29, BitPx: Put #1, 31, 0&
Put #1, 35, LgM: Put #1, 39, 0&: Put #1, 43, 0&: Put #1, 47, NbCoul: Put #1, 51, 0&
Dim XRempliss As Integer: XRempliss = LgL - 3 * XbmMax
For Ybm = 1 To YbmMax
Seek #1, LgE + LgL * (YbmMax - Ybm) + 1
For Xbm = 1 To XbmMax
Enrg = TE(Xbm, Ybm): Chal = TH(Xbm, Ybm): Gaît = TJ(Xbm, Ybm)
Call CalcÉngEHJ: CalcRVBÉLi
Oct = Round(Bleu): Put #1, , Oct
Oct = Round(Vert): Put #1, , Oct
Oct = Round(Roug): Put #1, , Oct
Call OùÇaEnEst: Next Xbm
Oct = 0: For Xbm = 1 To XRempliss: Put #1, , Oct: Next Xbm
Next Ybm
Close #1
Succès = True
End Sub