Calendar Maker 3

[SierraKen]

Whew, after a few days and around 8 hours of programming, I have just finished Calendar Maker 3. It took so long because the original variables are very scattered and it was like a puzzle. What I added for this version is the ability to save up to 12 characters on each day of the month and go back to it anytime on your computer. The hardest part was then keeping that information there as you look at other months. You can add information to a day in the beginning of the program and it will save it as a .txt file on your computer (loadable with Notepad if you wish) and then it makes the month on your screen with that info. Then you can surf around to other months using the left and right arrow keys and to load a month, press the L key and it will bring up a new screen asking which year and month to load. You can only load one month at a time. Version 2 made the ability to print out all 12 months on your printer at once using some U.S. holidays, but none of your saved info will still be on those 12 printouts. Or you can press P on each month and print out those with your loaded info if you wish. The key commands are on the Title Bar so it's fairly easy to use. There is also the version 1 ability to save that month as a .BMP picture file to your computer by pressing S.  Thank you to B+, Steve, euklides, and TempodiBasic for some code years ago. Also thanks to whoever made the code I found online years ago for the Easter date.  
Enjpy

(Code deleted, use code on the next post instead.)

[SierraKen]

Today I decided to add the ability to see the months that are already saved on your computer from the year you choose. That way people can choose to load a month that they see on the list. If there is none on the list, it will tell you and you can go back to the calendar. I also changed the filenames of the months adding a - between the month and year to make it easier to see if people want to find them on their computer. So this version will not be compatible with the one on my first post.

Code: (Select All)

'This is my very first calendar making program!
'Thanks to the guys from the QB64 forum for the help: bplus, SMcNeill, euklides, and TempodiBasic!
'This is a freeware program like all my other programs and games, only free.
'Feel free to use this code in your own programs.
'This version has the ability to save your own month info and come back to it anytime.
'Calendar Maker 1 version made on Sept. 19, 2019.
'Calendar Maker 2 version made on Dec. 29, 2021.
'Calendar Maker 3 version made on June 13, 2022.

start:
_Title "Calendar Maker 3 - by SierraKen"
_Limit 1000
Dim newinfo$(50)
Dim dayinfo(50)
holidays = 0
dd = 0
leap = 0
m = 0
mm = 0
y = 0
yy = 0
w = 0
weekday = 0
days = 0
load = 0
Screen _NewImage(800, 600, 32)
Cls
Print: Print
Print "                                  Monthly Calendar Maker 3"
Print: Print: Print
Print "                                       By SierraKen"
Print
Print
Print "          This program will make a calendar for the year and month you want."
Print "          It will also name some U.S. holidays on their dates if you choose that."
Print "          You also can add holidays or info to any day you wish with up to 12"
Print "          letters, numbers, symbols, or spaces."
Print "          This uses the Gregorian Calendar which became common practice in"
Print "          England in 1753 and we still use it today."
Print
Print "          First make a calendar, then if you want to save it as a .bmp file,"
Print "          press the 'S' key and it will save it as the month and year for its name."
Print "          For example, if you made a calendar for January 2022 and wish to save it,"
Print "          press the 'S' key and it will save it as the picture file 1-2022.bmp"
Print "          If you save the .bmp calendar, it will be put in the same directory as this program."
Print "          If you wish to print your calendar on your printer, press 'P' once."
Print "          Feel free to print each month as many times as you wish. They take up 1 page each."
Print "          To switch to the last month use the left arrow key, to the next month the right arrow key."
Print "          To make a different calendar without saving, press the Space Bar."
Print "          Keyboard commands will be listed on the title bar of the window."
Print
Print "          You also can print a whole year at once, without saving, with some U.S. holidays."
Print "          You can draw or print something on the back of each month using a different program,"
Print "          staple them together, punch a hole, and hang it on the wall. This does not include"
Print "          saved month info."
Print
Print "          New Feature: After you add your own month info in the beginning, it saves it"
Print "          to a .txt file in the same directory and you can load that month's data anytime"
Print "          by pressing L at any calendar month screen. You can only load one month at a time."
loops = 0
Print
Input "          Press Enter To begin.", begin$
Cls
Print: Print: Print
Input "          Would you like to print a whole year on your printer? (Y/N):", wholeyear$
If Left$(wholeyear$, 1) = "y" Or Left$(wholeyear$, 1) = "Y" Then m = 0: loops = 1

again1:
Print
Input "          Type the year here (1753-9999): ", y
If y <> Int(y) Then Print "Cannot use decimals, try again.": GoTo again1:
If y < 1753 Or y > 9999 Then Print "The year can only be between 1753 and 9999, try again.": GoTo again1:
If loops = 1 Then
    year = y
    holidays = 1
    Print "      This will print 12 pages on your printer, one month each."
    Print "      This will not show any of your saved month information."
    Print "      But it will print out some U.S. holidays."
    Print
    Print "      Press P to print the whole year on your printer."
    Print "      Press Esc key to go back to the beginning."
    Do
        ent$ = InKey$
        If ent$ = "p" Or ent$ = "P" Then GoTo calculate:
        If ent$ = Chr$(27) Then GoTo start:
    Loop
End If
again2:
Print
Input "          Type the month here (1-12): ", m
Print
If m <> Int(m) Then Print "          Cannot use decimals, try again.": GoTo again2:
If m < 1 Or m > 12 Then Print "          1-12 only, try again.": GoTo again2:
Input "          Do you want some U.S. holidays added (Y/N)?", hol$
If Left$(hol$, 1) = "y" Or Left$(hol$, 1) = "Y" Then holidays = 1
Print
Input "          Do you want to add your own month info (Y/N)?", adding$

'It loops here 12 times when printing an entire year.--------------------------------------------------------
calculate:
info = 0
load = 0
calculate2:
monthname = 0
mn = 0
infos = 0
If loops = 1 Then m = m + 1
If m > 12 Then loops = 0: GoTo start:
dd = 0
leap = 0
w = 0
weekday = 0
days = 0
'Get the month name.
If m = 1 Then month$ = " January"
If m = 2 Then month$ = "February"
If m = 3 Then month$ = "  March"
If m = 4 Then month$ = "  April"
If m = 5 Then month$ = "  May"
If m = 6 Then month$ = "  June"
If m = 7 Then month$ = "  July"
If m = 8 Then month$ = " August"
If m = 9 Then month$ = "September"
If m = 10 Then month$ = " October"
If m = 11 Then month$ = "November"
If m = 12 Then month$ = "December"

'Calculate to see if it's a Leap Year.
If m <> 2 Then GoTo nex:
If y / 400 = Int(y / 400) Then leap = 1: GoTo more:
If y / 4 = Int(y / 4) Then leap = 1
If y / 100 = Int(y / 100) Then leap = 0

'Get the number of days for each month.
more:
If leap = 1 Then days = 29
If leap = 0 Then days = 28
GoTo weekday:
nex:
If m = 1 Then days = 31
If m = 3 Then days = 31
If m = 4 Then days = 30
If m = 5 Then days = 31
If m = 6 Then days = 30
If m = 7 Then days = 31
If m = 8 Then days = 31
If m = 9 Then days = 30
If m = 10 Then days = 31
If m = 11 Then days = 30
If m = 12 Then days = 31
weekday:

'Set the month, year, and weekday variables to start with.
mm = m
yy = y
GetDay mm, dd, yy, weekday
If loops = 1 Then y = year

If Left$(adding$, 1) = "y" Or Left$(adding$, 1) = "Y" Then GoSub adding:
adding$ = ""

'This section makes the calendar graph.
make:
Screen _NewImage(800, 600, 32)
Cls
Line (0, 0)-(800, 600), _RGB32(255, 255, 255), BF
_Title "(S)ave BMP Picture, (L)oad Saved Month Info, (P)rint, Left and Right Switches Months, Space Bar Start's Over, Esc ends."
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
Locate 3, 42: Print month$; "  "; y

For x = 20 To 780 Step 108
    Line (x, 100)-(x, 580), _RGB32(0, 0, 0)
Next x
For z = 100 To 580 Step 80
    Line (16, z)-(780, z), _RGB32(0, 0, 0)
Next z

Locate 5, 8: Print "SUNDAY"
Locate 5, 21: Print "MONDAY"
Locate 5, 34: Print "TUESDAY"
Locate 5, 47: Print "WEDNESDAY"
Locate 5, 60: Print "THURSDAY"
Locate 5, 75: Print "FRIDAY"
Locate 5, 87: Print "SATURDAY"

'Finding Date of Easter
PQA = yy
GoSub PAQUES
'month = PQM, day = PQJ, year = PQA

'This section puts the right dates and holidays in the right squares for the calendar.
_Font 16
w = (weekday * 108) + 25
For weeky = 110 To 570 Step 80
    For dayx = w To 692 Step 108
        _Limit 1000
        dd = dd + 1
        GetDay mm, dd, yy, weekday
        If loops = 1 Then y = year
        If weekday = 1 Then GoSub coloring:
        If weekday <> 1 Then Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
        dd$ = Str$(dd)
        _Font 8
        If dd = (dayinfo(infos) And loadm = m And loady = y And load = 1) Or (dd = dayinfo(infos) And newy = y And newm = m) Then
            GoSub coloring:
            i = Len(newinfo$(infos))
            If i < 8 Then ii = 25
            If i > 7 And i < 12 Then ii = 11
            If i > 11 And i < 14 Then ii = 5
            If i > 13 Then ii = 2
            _PrintString (dayx + ii, weeky + 20), newinfo$(infos)
            infos = infos + 1
            ye = 1
        End If

        If holidays = 0 Then GoTo skip:
        If m = 1 And dd = 1 Then
            GoSub coloring:
            _PrintString (dayx + 15, weeky + 60), "New Years"
        End If
        If m = 1 And weekday = 2 And dd > 14 And dd < 22 Then
            GoSub coloring:
            _PrintString (dayx + 25, weeky + 60), "MLK Jr."
        End If
        If m = 2 And dd = 2 Then
            GoSub coloring:
            _PrintString (dayx + 13, weeky + 60), "Groundhog"
        End If
        If m = 2 And weekday = 2 And dd > 14 And dd < 22 Then
            GoSub coloring:
            _PrintString (dayx + 10, weeky + 60), "Presidents"
        End If
        If m = 2 And dd = 14 Then
            GoSub coloring:
            _PrintString (dayx + 10, weeky + 60), "Valentines"
        End If
        If m = 3 And dd = 17 Then
            GoSub coloring:
            _PrintString (dayx + 5, weeky + 60), "St. Patrick"
        End If
        If m = PQM And dd = PQJ Then
            GoSub coloring:
            _PrintString (dayx + 25, weeky + 60), "Easter"
        End If
        If m = 4 And dd > 23 And weekday = 7 Then
            GoSub coloring:
            _PrintString (dayx + 25, weeky + 60), "Arbor"
        End If
        If m = 5 And weekday = 0 And dd > 14 And dd < 22 Then
            GoSub coloring:
            _PrintString (dayx + 2, weeky + 60), "Armed Forces"
        End If
        If m = 5 And weekday = 2 And dd > 24 Then
            GoSub coloring:
            _PrintString (dayx + 15, weeky + 60), "Memorial"
        End If
        If m = 5 And weekday = 1 And dd > 7 And dd < 15 Then
            GoSub coloring:
            _PrintString (dayx + 2, weeky + 60), "Mother's Day"
        End If
        If m = 6 And weekday = 1 And dd > 14 And dd < 22 Then
            GoSub coloring:
            _PrintString (dayx + 2, weeky + 60), "Father's Day"
        End If
        If m = 6 And dd = 14 Then
            GoSub coloring:
            _PrintString (dayx + 35, weeky + 60), "Flag"
        End If
        If m = 7 And dd = 4 Then
            GoSub coloring:
            _PrintString (dayx + 2, weeky + 60), "Independence"
        End If
        If m = 9 And weekday = 2 And dd < 8 Then
            GoSub coloring:
            _PrintString (dayx + 27, weeky + 60), "Labor"
        End If
        If m = 10 And dd > 9 And dd < 16 And weekday = 2 Then
            GoSub coloring:
            _PrintString (dayx + 17, weeky + 60), "Columbus"
        End If
        If m = 10 And dd = 31 Then
            GoSub coloring:
            _PrintString (dayx + 15, weeky + 60), "Halloween"
        End If
        If m = 11 And dd = 11 Then
            GoSub coloring:
            _PrintString (dayx + 19, weeky + 60), "Veterans"
        End If
        If m = 11 And dd > 21 And dd < 29 And weekday = 5 Then
            GoSub coloring:
            _PrintString (dayx + 2, weeky + 60), "Thanksgiving"
        End If
        If m = 12 And dd = 25 Then
            GoSub coloring:
            _PrintString (dayx + 15, weeky + 60), "Christmas"
        End If
        skip:
        ye = 0
        _Font 16
        _PrintString (dayx, weeky), dd$
        _Font 8
        If dd = days Then _Font 16: GoTo more2:
    Next dayx
    w = 25
Next weeky

more2:
_Limit 100
a$ = InKey$
If a$ = "l" Or a$ = "L" Then GoTo loading:
If a$ = Chr$(27) Then Cls: Print: Print: Print "Goodbye.": End
If a$ = "s" Or a$ = "S" Then GoTo saving:
If a$ = " " Then GoTo start:
If a$ = "p" Or a$ = "P" Or loops = 1 Then
    _Delay 2
    'printer prep (code copied and pasted from bplus Free Calendar Program)
    YMAX = _Height: XMAX = _Width
    landscape& = _NewImage(YMAX, XMAX, 32)
    _MapTriangle (XMAX, 0)-(0, 0)-(0, YMAX), 0 To(0, 0)-(0, XMAX)-(YMAX, XMAX), landscape&
    _MapTriangle (XMAX, 0)-(XMAX, YMAX)-(0, YMAX), 0 To(0, 0)-(YMAX, 0)-(YMAX, XMAX), landscape&
    _PrintImage landscape&
End If

If a$ = Chr$(0) + Chr$(77) And loops = 0 Then
    m = m + 1
    If m > 12 Then
        m = 1
        yy = yy + 1
        y = y + 1
    End If
    If y > 9999 Then y = 1753
    dd = 0
    leap = 0
    _Delay .1
    Cls
    GoTo calculate2:
End If
If a$ = Chr$(0) + Chr$(75) And loops = 0 Then
    m = m - 1
    If m < 1 Then
        m = 12
        yy = yy - 1
        y = y - 1
    End If
    If y < 1753 Then y = 9999
    dd = 0
    leap = 0
    _Delay .1
    Cls
    GoTo calculate2:
End If
If loops = 1 Then _Delay 1: Cls: GoTo calculate:
GoTo more2:

adding:
load = 0
monthsave$ = Str$(m)
yearsave$ = Str$(y)
name$ = LTrim$(monthsave$) + "-" + LTrim$(yearsave$) + ".txt"

theFileExists = _FileExists(name$)
If theFileExists = -1 Then
    Print
    Print "       File Already Exists"
    Print "       Saving will delete your old"
    Print "       month data."
    Print "       Would you like to still do it?"
    Print "      (Y/N)."
    Print "      Esc or N goes back to calendar."
    llloop:
    _Limit 100
    ag2$ = InKey$
    If ag2$ = Chr$(27) Then GoTo make:
    If Left$(ag2$, 1) = "n" Or Left$(ag2$, 1) = "N" Then GoTo make:
    If ag2$ = "" Then GoTo llloop:
    If ag2$ = "y" Or ag$ = "Y" Then
        Shell _Hide "DEL " + name$
        GoTo saving2:
    End If
    GoTo llloop:
End If
saving2:
Open name$ For Output As #1
addingbegin:
Cls
Print: Print
add:
Print
olddayinfo = dayinfo(info)
adding2:
If info > days Then Print "You have reached the maximum amount of holidays or info for this month.": Input "Press enter to create calendar.", pe$: Return
Print
Print "Your dates must go in order here."
Print "for example, you cannot put info for day 15 and then put info for day 1."
Print "They must all follow from smallest number to highest number or it will tell you to start over again."
Print "Also, you cannot change a day by doing it over again, so if you mess up, create a new month."
Print
Print info; ". ";
Input "Which day of the month for new holiday or information: ", dayinfo(info)
If dayinfo(info) > days Then Print "That day is not on this calendar, try again.": GoTo adding2:
If dayinfo(info) < 1 Then Print "You cannot type a date less than 1, try again.": GoTo adding2:
If dayinfo(info) <> Int(dayinfo(info)) Then Print "You cannot type a decimal for a date, try again.": GoTo adding2:
If dayinfo(info) < olddayinfo Then
    Print
    Print "You have put a date before your previous one which cannot work, start over from your first date."
    For dl = 0 To 31
        newinfo$(dl) = ""
        dayinfo(dl) = 0
    Next dl
    olddayinfo = 0
    info = 0
    GoTo add:
End If
adding3:
day$ = Str$(dayinfo(info))
day2$ = LTrim$(day$)
Print #1, day2$
Print
Print "Type up to 12 letters, numbers, or spaces that will be put for that day."
Print
Input "->", newinfo$(info)
infoamount = Len(newinfo$(info))
If infoamount > 12 Then Print "Too long, try again.": GoTo adding3:
If infoamount < 1 Then Print "Nothing typed, try again.": GoTo adding3:
Print #1, newinfo$(info)
Print
Input "Do you want to add more (Y/N):", yn$
If Left$(yn$, 1) = "y" Or Left$(yn$, 1) = "Y" Then info = info + 1: GoTo addingbegin:
Close #1
name$ = ""
newm = m
newy = y
loady = 0
loadm = 0
Return

loading:
Cls
'Files "*.txt"

againload:
Print
Input "    Which year to load: ", loady
If loady <> Int(loady) Then Print "    Cannot use decimals, try again.": GoTo againload:
If loady < 1753 Or loady > 9999 Then Print "    The year can only be between 1753 and 9999, try again.": GoTo againload:
againload2:
loady$ = Str$(loady)
loady$ = RTrim$(loady$)
loady$ = LTrim$(loady$)
Print: Print: Print
Print "    " + "Saved Months For " + loady$: Print
Do
    monthname = monthname + 1
    If monthname > 12 Then GoTo askmonth:
    monthn$ = Str$(monthname)
    monthn$ = LTrim$(monthn$)
    monthn$ = RTrim$(monthn$)
    filen$ = monthn$ + "-" + loady$ + ".txt"
    filen$ = LTrim$(filen$)
    filen$ = RTrim$(filen$)
    theFileExists = _FileExists(filen$)
    If theFileExists = -1 Then
        If monthname = 1 Then Print "    " + Str$(monthname) + " January"
        If monthname = 2 Then Print "    " + Str$(monthname) + " February"
        If monthname = 3 Then Print "    " + Str$(monthname) + " March"
        If monthname = 4 Then Print "    " + Str$(monthname) + " April"
        If monthname = 5 Then Print "    " + Str$(monthname) + " May"
        If monthname = 6 Then Print "    " + Str$(monthname) + " June"
        If monthname = 7 Then Print "    " + Str$(monthname) + " July"
        If monthname = 8 Then Print "    " + Str$(monthname) + " August"
        If monthname = 9 Then Print "    " + Str$(monthname) + " September"
        If monthname = 10 Then Print "    " + Str$(monthname) + " October"
        If monthname = 11 Then Print "    " + Str$(monthname) + " November"
        If monthname = 12 Then Print "    " + Str$(monthname) + " December"
    Else
        mn = mn + 1
        If mn > 11 Then Print: Input "    No months saved for this year, press Enter to go back to calendar.", a2$: GoTo calculate2:
    End If
Loop
askmonth:
Print
Input "    Which month number to load: ", loadm
If loadm < 1 Or loadm > 12 Then Print "    Month must be between 1 and 12, try again.": GoTo againload2:
If loadm <> Int(loadm) Then Print "    Cannot use decimals, try again.": GoTo againload2:
loady$ = LTrim$(Str$(loady))
loady$ = RTrim$(loady$)
loadm$ = LTrim$(Str$(loadm))
loadm$ = RTrim$(loadm$)
name2$ = loadm$ + "-" + loady$ + ".txt"
name2$ = LTrim$(name2$)
name2$ = RTrim$(name2$)
theFileExists = _FileExists(name2$)
If theFileExists <> -1 Then
    Print "    This file does not exist."
    Print "    Would you like to (S)tart over or go back to the (C)alendar? (Press S or C): "
    asking:
    aa$ = InKey$
    If aa$ = "s" Or aa$ = "S" Then GoTo loading:
    If aa$ = "c" Or aa$ = "C" Then GoTo make:
    If aa$ = Chr$(27) Then GoTo make:
    GoTo asking:
End If

For t = 0 To 31
    dayinfo(t) = 0
    newinfo$(t) = ""
Next t

info2 = 0
Open name2$ For Input As #1
Do Until EOF(1)
    Input #1, dayinfo(info2)
    Input #1, newinfo$(info2)
    info2 = info2 + 1
Loop
Close #1
name2$ = ""
For snd = 100 To 700 Step 100
    Sound snd, 2
Next snd
Cls
y = loady
m = loadm
yy = y
mm = m
load = 1
newy = 0
newm = 0
GoTo calculate2:

'Color all Sundays and holidays
coloring:
If ye = 1 Then Return
Line (dayx - 4, weeky - 9)-(dayx + 102, weeky + 68), _RGB32(255, 255, 127), BF: Color _RGB32(0, 0, 0), _RGB32(255, 255, 127)
Return


'Find the right date for Easter.
PAQUES:
PQM = Int(PQA / 100): PQ1 = PQA - PQM * 100: PQJ = Int(((PQA / 19 - Int(PQA / 19)) + .001) * 19)
PQ2 = Int(PQM / 4): PQ3 = Int(((PQM / 4) - PQ2 + .001) * 4): PQ4 = Int((8 + PQM) / 25)
PQ5 = Int((1 + PQM - PQ4 + .001) / 3): PQ4 = (15 + 19 * PQJ + PQM - PQ2 - PQ5 + .001) / 30: PQ4 = PQ4 - Int(PQ4)
PQ4 = Int(PQ4 * 30): PQ5 = Int(PQ1 / 4): PQ6 = ((PQ1 / 4) - PQ5) * 4
PQ7 = (32 + 2 * PQ3 + 2 * PQ5 - PQ4 - PQ6 + .001) / 7: PQ7 = (PQ7 - Int(PQ7)) * 7: PQ6 = (PQJ + 11 * PQ4 + 22 * PQ7) / 451
PQ6 = Int(PQ6): PQ2 = (114 + PQ4 + PQ7 - 7 * PQ6) / 31: PQM = Int(PQ2): PQJ = Int((PQ2 - PQM + .001) * 31 + 1)
Return


'This section saves the calendar to a BMP file along with the SUB at the end of this program.
saving:
If loops = 1 Then GoTo more2:
mo$ = Str$(m)
mo$ = LTrim$(RTrim$(mo$))
year2$ = Str$(y)
year2$ = LTrim$(RTrim$(year2$))
nm$ = mo$ + "-"
nm$ = LTrim$(RTrim$(nm$))
nm$ = nm$ + year2$
nm$ = LTrim$(RTrim$(nm$))
SaveImage 0, nm$ 'saves entire program screen,"
Cls
nm2$ = nm$ + ".bmp"
nm2$ = LTrim$(RTrim$(nm2$))
Print: Print: Print
Print "                                           Saving"
Print
Print "                          "; nm2$; " has been saved to your computer."
Print
Print
Input "                         Do you wish to go back to your calendar (Y/N)"; ag$
If Left$(ag$, 1) = "y" Or Left$(ag$, 1) = "Y" Then ag$ = "": GoTo calculate2:
Print
Print
Print "                         Goodbye."
End


'This section gets the right weekday.
Sub GetDay (mm, dd, yy, weekday) 'use 4 digit year
    'From Zeller's congruence: https://en.wikipedia.org/wiki/Zeller%27s_congruence
    If mm < 3 Then yy = yy - 1
    If mm < 3 Then mm = mm + 12
    century = yy Mod 100
    zerocentury = yy \ 100
    weekday = (dd + Int(13 * (mm + 1) / 5) + century + Int(century / 4) + Int(zerocentury / 4) + 5 * zerocentury) Mod 7
End Sub

'This section saves the .bmp picture file.
Sub SaveImage (image As Long, filename As String)
    bytesperpixel& = _PixelSize(image&)
    If bytesperpixel& = 0 Then Print "Text modes unsupported!": End
    If bytesperpixel& = 1 Then bpp& = 8 Else bpp& = 24
    x& = _Width(image&)
    y& = _Height(image&)
    b$ = "BM????QB64????" + MKL$(40) + MKL$(x&) + MKL$(y&) + MKI$(1) + MKI$(bpp&) + MKL$(0) + "????" + String$(16, 0) 'partial BMP header info(???? to be filled later)
    If bytesperpixel& = 1 Then
        For c& = 0 To 255 ' read BGR color settings from JPG image + 1 byte spacer(CHR$(0))
            cv& = _PaletteColor(c&, image&) ' color attribute to read.
            b$ = b$ + Chr$(_Blue32(cv&)) + Chr$(_Green32(cv&)) + Chr$(_Red32(cv&)) + Chr$(0) 'spacer byte
        Next
    End If
    Mid$(b$, 11, 4) = MKL$(Len(b$)) ' image pixel data offset(BMP header)
    lastsource& = _Source
    _Source image&
    If ((x& * 3) Mod 4) Then padder$ = String$(4 - ((x& * 3) Mod 4), 0)
    For py& = y& - 1 To 0 Step -1 ' read JPG image pixel color data
        r$ = ""
        For px& = 0 To x& - 1
            c& = Point(px&, py&) 'POINT 32 bit values are large LONG values
            If bytesperpixel& = 1 Then r$ = r$ + Chr$(c&) Else r$ = r$ + Left$(MKL$(c&), 3)
        Next px&
        d$ = d$ + r$ + padder$
    Next py&
    _Source lastsource&
    Mid$(b$, 35, 4) = MKL$(Len(d$)) ' image size(BMP header)
    b$ = b$ + d$ ' total file data bytes to create file
    Mid$(b$, 3, 4) = MKL$(Len(b$)) ' size of data file(BMP header)
    If LCase$(Right$(filename$, 4)) <> ".bmp" Then ext$ = ".bmp"
    f& = FreeFile
    Open filename$ + ext$ For Output As #f&: Close #f& ' erases an existing file
    Open filename$ + ext$ For Binary As #f&
    Put #f&, , b$
    Close #f&
End Sub

[OldMoses]

That's a very nice upgrade to your original. Well done.

[SierraKen]

That's a very nice upgrade to your original. Well done.

Thank you OldMoses!  I spent a lot of time on this version but it paid off.