BMP picture viewer

[NOVARSEG]

_vince

RLE compression.  Another update

Steve

you were right about the padding. I should have listened.

[_vince]

Yes, that padding nonsense is a common trap.  The code will work but will distort images with a certain width so it's important to test for.  The article mentions it I believe but I noticed that not all do.

I go and come a lot.  The last week or so, I've been in fairly often, but for the next week or so, I probably won't be.  It's time for me to go get mom and take care of her again for a bit to give my sister a break.  ;)

Nice, good to know! I'm going to make a discord account tonight and join in, see you soon ;-)

[bplus]

To make a Sub of the BMP24, take the hunk of code between the 2 =========== bars
start this at bottom of code:

Code: QB64: [Select]

1. Function LoadBmp24&(Filename$)  'loadBMP24& returns handle to image for display code from main code section.
2. >>>>>>>>>>>>>>>> Insert Chuck Here
3.     LoadBMP24& = handle
4. End Sub

Code: QB64: [Select]

1. _TITLE "BMP slide show.   Press ESC to exit"
2.  
3.  
4. DECLARE CUSTOMTYPE LIBRARY ".\direntry"
5.     FUNCTION load_dir& (s AS STRING)
6.     FUNCTION has_next_entry& ()
7.     SUB close_dir ()
8.     SUB get_next_entry (s AS STRING, flags AS LONG, file_size AS LONG)
9. END DECLARE
10.  
11. DIM flags AS LONG
12. DIM length AS LONG
13. DIM NAM AS STRING
14. DIM F(100) AS STRING
15. DIM Fcount AS INTEGER
16. DIM Fmax AS INTEGER
17. DIM L AS _UNSIGNED LONG
18. DIM I AS _UNSIGNED INTEGER
19. DIM C AS _UNSIGNED LONG
20. DIM H AS LONG
21. DIM W AS LONG
22. DIM R AS _UNSIGNED LONG
23. DIM OF AS _UNSIGNED LONG
24. DIM N AS _UNSIGNED LONG
25. DIM tt AS STRING * 4
26. DIM t AS STRING * 3
27. DIM handle AS LONG
28. DIM t1 AS SINGLE
29. DIM t2 AS SINGLE
30. DIM pad AS INTEGER
31.  
32.  
33. 'To view BMP pictures in the root drive or a particular folder (example)
34. 'IF load_dir("C:" + CHR$(0)) <> -1 THEN _FULLSCREEN: PRINT: PRINT "Path name does not exist": SLEEP: END
35. 'IF load_dir("C:\QB64" + CHR$(0)) <> -1 THEN _FULLSCREEN: PRINT: PRINT "Path name does not exist": SLEEP: END
36.  
37. 'To view BMP pictures in the directory (folder) from where the EXE is run (current)
38. IF load_dir("." + CHR$(0)) <> -1 THEN _FULLSCREEN: PRINT: PRINT "Path name does not exist": SLEEP: END
39.  
40. 'To view BMP pictures in the parent directory (folder) from where the EXE is run (current)
41. 'IF load_dir(".." + CHR$(0)) <> -1 THEN _FULLSCREEN: PRINT: PRINT "Path name does not exist": SLEEP: END
42.  
43.  
44. DO
45.     length = has_next_entry
46.     IF length = -1 THEN
47.         PRINT "No more files to process"
48.         EXIT DO
49.     END IF
50.  
51.     IF length > -1 THEN
52.         NAM = SPACE$(length)
53.         get_next_entry NAM, flags, file_size
54.  
55.         IF (flags XOR 2) = 0 AND UCASE$(RIGHT$(NAM, 3)) = "BMP" THEN
56.             PRINT NAM + "                              "
57.             Fcount = Fcount + 1
58.             F(Fcount) = NAM
59.         END IF
60.  
61.     END IF
62.  
63. LOOP
64.  
65. Fmax = Fcount
66. close_dir
67. Fcount = 0
68.  
69. DO
70.     N = 0
71.  
72.     Fcount = Fcount + 1
73. '========================================================= start code chuck
74.     OPEN F(Fcount) FOR BINARY AS #1   < change F(Fcount) to Sub parameter Filename$
75.  
76.     GET #1, 11, OF
77.     'PRINT "Offset to picture data"; OF
78.  
79.     GET #1, 15, L
80.     'PRINT "Header size "; L
81.  
82.     GET #1, , W
83.     'PRINT "image width "; W
84.  
85.     GET #1, , H
86.     'PRINT "image height "; H
87.  
88.     GET #1, , I 'biPlanes. Specifies the number of color planes on the target device.
89.  
90.     GET #1, , I 'bits per pixel. Must = 24 for the program to work.
91.  
92.     IF I <> 24 THEN
93.         CLS
94.         PRINT "width "; W; "    Height "; H; "    Bits per pixel "; I
95.         PRINT Fcount
96.         PRINT F(Fcount); " is not a 24 bit per pixel BMP"
97.         DO
98.             IF INKEY$ <> "" THEN CLS: EXIT DO
99.         LOOP
100.         GOTO LL1
101.     END IF
102.  
103.     DIM a AS _MEM
104.     handle = _NEWIMAGE(W, ABS(H), 32)
105.     a = _MEMIMAGE(handle)
106.  
107.     pad = 4 - (W * 3) MOD 4
108.  
109.     IF pad = 4 THEN pad = 0 'pad = multiple of 4
110.  
111.     IF H < 0 THEN
112.  
113.         FOR R = 0 TO ABS(H) - 1
114.  
115.             FOR C = 1 TO W * 3 STEP 3
116.                 GET #1, R * (W * 3 + pad) + C + OF, t
117.                 tt = t + CHR$(255)
118.                 _MEMPUT a, a.OFFSET + N, tt
119.                 N = N + 4
120.             NEXT C
121.  
122.         NEXT R
123.  
124.     END IF
125.  
126.  
127.     IF H > 0 THEN
128.  
129.         FOR R = H - 1 TO 0 STEP -1
130.  
131.             FOR C = 1 TO W * 3 STEP 3
132.                 GET #1, R * (W * 3 + pad) + C + OF, t
133.                 tt = t + CHR$(255)
134.                 _MEMPUT a, a.OFFSET + N, tt
135.                 N = N + 4
136.             NEXT C
137.  
138.         NEXT R
139.  
140.     END IF
141. '===================================================== end of code chunk
142.  
143.     SCREEN _NEWIMAGE(W, (ABS(H)), 32)
144.     _PUTIMAGE (0, 0), handle
145.     _MEMFREE a
146.  
147.  
148.     t1 = TIMER
149.     DO
150.         _LIMIT 100
151.         t2 = TIMER
152.         IF t2 - t1 > 2 THEN EXIT DO
153.         i$ = INKEY$
154.         IF i$ = CHR$(27) THEN END
155.     LOOP
156.     LL1:
157.  
158.     CLOSE
159.  
160.     IF Fcount = Fmax THEN Fcount = 0
161. LOOP
162.  
163. END
164.  

Then move all DIM 's Variable in main that got moved to Function into Function at top

[NOVARSEG]

 

Code: QB64: [Select]

1. DIM SHARED a AS _MEM
2.  
3.   'code  . . . . .
4.  
5. 'input filename
6. 'returns W image width (if W = 0 then error)
7. 'returns H image height (negative or positive value)
8. 'returns HANDLE
9. SUB loadBMP24 (FILENAME AS STRING, W AS LONG, H AS LONG, HANDLE AS LONG)
10.     DIM L AS _UNSIGNED LONG
11.     DIM I AS _UNSIGNED INTEGER
12.     DIM C AS _UNSIGNED LONG
13.     DIM R AS _UNSIGNED LONG
14.     DIM OF AS _UNSIGNED LONG
15.     DIM N AS _UNSIGNED LONG
16.     DIM tt AS STRING * 4
17.     DIM t AS STRING * 3
18.     DIM pad AS INTEGER
19.  
20.     N = 0
21.  
22.     OPEN FILENAME FOR BINARY AS #1
23.  
24.     GET #1, 11, OF 'Offset to picture data
25.  
26.     GET #1, 15, L 'Header size
27.  
28.     GET #1, , W 'image width
29.  
30.     GET #1, , H 'image height
31.  
32.     GET #1, , I 'biPlanes. Specifies the number of color planes on the target device.
33.  
34.     GET #1, , I 'bits per pixel. Must = 24 for the program to work.
35.  
36.     IF I <> 24 THEN W = 0: GOTO LL1
37.  
38.     HANDLE = _NEWIMAGE(W, ABS(H), 32)
39.     a = _MEMIMAGE(HANDLE)
40.  
41.     pad = 4 - (W * 3) MOD 4
42.  
43.     IF pad = 4 THEN pad = 0 'pad = multiple of 4
44.  
45.     IF H < 0 THEN
46.  
47.         FOR R = 0 TO ABS(H) - 1
48.  
49.             FOR C = 1 TO W * 3 STEP 3
50.                 GET #1, R * (W * 3 + pad) + C + OF, t
51.                 tt = t + CHR$(255)
52.                 _MEMPUT a, a.OFFSET + N, tt
53.                 N = N + 4
54.             NEXT C
55.  
56.         NEXT R
57.  
58.     END IF
59.  
60.  
61.     IF H > 0 THEN
62.  
63.         FOR R = H - 1 TO 0 STEP -1
64.  
65.             FOR C = 1 TO W * 3 STEP 3
66.                 GET #1, R * (W * 3 + pad) + C + OF, t
67.                 tt = t + CHR$(255)
68.                 _MEMPUT a, a.OFFSET + N, tt
69.                 N = N + 4
70.             NEXT C
71.  
72.         NEXT R
73.  
74.     END IF
75.     LL1:
76.     CLOSE
77. END SUB

[bplus]

OK and now use the rest of the code for the main section to test calling up the Function or Sub.

I don't see the need to pass anything but the handle for the image to display in the main.

Do you have to change something when displaying for h < 0? Couldn't the adjustment be made before the sub or function passes the handle to main for display.

Remember to _FeeImage handles to avoid memory leaks.

[NOVARSEG]

@bplus

I don't see the need to pass anything but the handle for the image to display in the main.

   
In the main this code displays
SCREEN _NEWIMAGE(W, (ABS(H)), 32)
    _PUTIMAGE (0, 0), HANDLE
    _MEMFREE a

which requires W and H.  The SUB returns W, H and handle.  Notice the ABS(H) because the Sub will return either -H or H depending on the BMP

Also if there is an error (not a 24BMP) the sub will return W = 0

Maybe only a HANDLE is needed but at least there is the optional W and H returned

That is one of the problems with SUBs - what data do we think does not have to be returned
***

Do you have to change something when displaying for h < 0? Couldn't the adjustment be made before the sub or function passes the handle (height?) to main for display.

Inside the sub there could be an H = ABS(H) but what if your code in the main wanted to know if the BMP had -H or +h height?

****

Remember to _FreeImage handles to avoid memory leaks.

how  is _FreeImage used?

[NOVARSEG]

OK here is another version of the BMP viewer that shows how the SUB works

Code: QB64: [Select]

1. _TITLE "BMP slide show.   Press ESC to exit"
2.  
3.  
4.  
5. DECLARE CUSTOMTYPE LIBRARY ".\direntry"
6.     FUNCTION load_dir& (s AS STRING)
7.     FUNCTION has_next_entry& ()
8.     SUB close_dir ()
9.     SUB get_next_entry (s AS STRING, flags AS LONG, file_size AS LONG)
10. END DECLARE
11.  
12. DIM flags AS LONG
13. DIM length AS LONG
14. DIM NAM AS STRING
15. DIM F(100) AS STRING
16. DIM Fcount AS INTEGER
17. DIM Fmax AS INTEGER
18. DIM H AS LONG
19. DIM W AS LONG
20. DIM tt AS STRING * 4
21. DIM t AS STRING * 3
22. DIM HANDLE AS LONG
23. DIM SHARED a AS _MEM
24.  
25. 'To view BMP pictures in the root drive or a particular folder (example)
26. 'IF load_dir("C:" + CHR$(0)) <> -1 THEN _FULLSCREEN: PRINT: PRINT "Path name does not exist": SLEEP: END
27. 'IF load_dir("C:\QB64" + CHR$(0)) <> -1 THEN _FULLSCREEN: PRINT: PRINT "Path name does not exist": SLEEP: END
28.  
29. 'To view BMP pictures in the directory (folder) from where the EXE is run (current)
30. IF load_dir("." + CHR$(0)) <> -1 THEN _FULLSCREEN: PRINT: PRINT "Path name does not exist": SLEEP: END
31.  
32. 'To view BMP pictures in the parent directory (folder) from where the EXE is run (current)
33. 'IF load_dir(".." + CHR$(0)) <> -1 THEN _FULLSCREEN: PRINT: PRINT "Path name does not exist": SLEEP: END
34.  
35.  
36. DO
37.     length = has_next_entry
38.     IF length = -1 THEN
39.         PRINT "No more files to process"
40.         EXIT DO
41.     END IF
42.  
43.     IF length > -1 THEN
44.         NAM = SPACE$(length)
45.         get_next_entry NAM, flags, file_size
46.  
47.         IF (flags XOR 2) = 0 AND UCASE$(RIGHT$(NAM, 3)) = "BMP" THEN
48.             PRINT NAM + "                              "
49.             Fcount = Fcount + 1
50.             F(Fcount) = NAM
51.         END IF
52.  
53.     END IF
54.  
55. LOOP
56.  
57. Fmax = Fcount
58. close_dir
59. Fcount = 0
60. DO
61.     Fcount = Fcount + 1
62.  
63.     loadBMP24 F(Fcount), W, H, HANDLE
64.     IF W = 0 THEN
65.         CLS
66.         PRINT F(Fcount); " Is not a 24 bit per pixel BMP"
67.         PRINT W; H
68.         GOTO LL1
69.     END IF
70.  
71.  
72.  
73.     SCREEN _NEWIMAGE(W, (ABS(H)), 32)
74.     _PUTIMAGE (0, 0), HANDLE
75.     _MEMFREE a
76.  
77.     LL1:
78.     t1 = TIMER
79.     DO
80.         _LIMIT 100
81.         t2 = TIMER
82.         IF t2 - t1 > 1 THEN EXIT DO
83.         i$ = INKEY$
84.         IF i$ = CHR$(27) THEN END
85.     LOOP
86.  
87.  
88.     IF Fcount = Fmax THEN Fcount = 0
89.  
90.  
91. LOOP
92.  
93. END
94.  
95. 'SUB loadBMP24
96. 'input filename
97. 'returns W image width (if = 0 then error)
98. 'returns H image height (negative or positive value)
99. 'returns HANDLE
100.  
101. SUB loadBMP24 (FILENAME AS STRING, W AS LONG, H AS LONG, HANDLE AS LONG)
102.  
103.     DIM L AS _UNSIGNED LONG
104.     DIM I AS _UNSIGNED INTEGER
105.     DIM C AS _UNSIGNED LONG
106.     DIM R AS _UNSIGNED LONG
107.     DIM OF AS _UNSIGNED LONG
108.     DIM N AS _UNSIGNED LONG
109.     DIM tt AS STRING * 4
110.     DIM t AS STRING * 3
111.     DIM pad AS INTEGER
112.  
113.     N = 0
114.  
115.     OPEN FILENAME FOR BINARY AS #1
116.  
117.     GET #1, 11, OF 'Offset to picture data
118.  
119.     GET #1, 15, L 'Header size
120.  
121.     GET #1, , W 'image width
122.  
123.     GET #1, , H 'image height
124.  
125.     GET #1, , I 'biPlanes. Specifies the number of color planes on the target device.
126.  
127.     GET #1, , I 'bits per pixel. Must = 24 for the program to work.
128.  
129.     IF I <> 24 THEN W = 0: GOTO LL1
130.  
131.     HANDLE = _NEWIMAGE(W, ABS(H), 32)
132.     a = _MEMIMAGE(HANDLE)
133.  
134.     pad = 4 - (W * 3) MOD 4
135.  
136.     IF pad = 4 THEN pad = 0 'pad = multiple of 4
137.  
138.     IF H < 0 THEN
139.  
140.         FOR R = 0 TO ABS(H) - 1
141.  
142.             FOR C = 1 TO W * 3 STEP 3
143.                 GET #1, R * (W * 3 + pad) + C + OF, t
144.                 tt = t + CHR$(255)
145.                 _MEMPUT a, a.OFFSET + N, tt
146.                 N = N + 4
147.             NEXT C
148.  
149.         NEXT R
150.  
151.     END IF
152.  
153.  
154.     IF H > 0 THEN
155.  
156.         FOR R = H - 1 TO 0 STEP -1
157.  
158.             FOR C = 1 TO W * 3 STEP 3
159.                 GET #1, R * (W * 3 + pad) + C + OF, t
160.                 tt = t + CHR$(255)
161.                 _MEMPUT a, a.OFFSET + N, tt
162.                 N = N + 4
163.             NEXT C
164.  
165.         NEXT R
166.  
167.     END IF
168.     LL1:
169.     CLOSE
170. END SUB

[bplus]

Works great! All the images loaded and displayed fine! Really easy to load the sub and use it for displaying images.

Navigate your hard disk for BMP24's to display:

Code: QB64: [Select]

1. Option _Explicit
2. _Title "Pipecom Browser 2 for BMP24 File Display" 'b+ testing one array system with pipecom
3. ' Thanks to Spriggsy, Zak, for convincing me pipecom is better!
4. ' Using Steve's fixed BMP24 loader
5. ' Also thanks to Dav for 1 window for file and folder selection idea
6. ' Also thanks to NOVARSEG who got me going on this for a better filename$ retriever
7. ' 2021-02-10 update with LoadBMP24 Sub
8.  
9. Declare Library "pipecom"
10.     Function pipecom$ (cmd As String)
11. End Declare
12.  
13. Screen _NewImage(1280, 740, 32)
14. _Delay .25
15. _ScreenMove 65, 0 ' your screen might need different
16.  
17. ReDim myFile$
18. ReDim As Long col, row, charW, charH, W, H, image
19. Color , &HFF000033
20. Cls
21. Do 'test our new function
22.     ScnState 0
23.     col = 16: row = 3: charW = 128: charH = 40
24.     myFile$ = GetFileName$(row, col, charW, charH)
25.     ScnState -1 ' <<<<<<<<<<<<<<<<<<<<<<<<<<< this is supposed to restore back color
26.     'image& = loadBMP24&(myFile$)
27.  
28.     loadBMP24 myFile$, W, H, image
29.     Color , &HFF000033
30.     Cls
31.     If image <> 0 Then
32.         _Title myFile$ + " press any to get another BMP24 file image, esc to quit"
33.         _PutImage ((_Width - _Width(image&)) / 2, (_Height - _Height(image&)) / 2)-Step(_Width(image&), _Height(image&)), image&, 0
34.         Sleep
35.         _FreeImage image&
36.     End If
37. Loop Until _KeyDown(27)
38.  
39. 'NOVARSEG's fixed loadBLP24 Sub 2021-02-10 AAAAM https://www.qb64.org/forum/index.php?topic=3602.msg129753#msg129753
40. Sub loadBMP24 (FILENAME As String, W As Long, H As Long, HANDLE As Long)
41.  
42.     Dim L As _Unsigned Long
43.     Dim I As _Unsigned Integer
44.     Dim C As _Unsigned Long
45.     Dim R As _Unsigned Long
46.     Dim OF As _Unsigned Long
47.     Dim N As _Unsigned Long
48.     Dim tt As String * 4
49.     Dim t As String * 3
50.     Dim pad As Integer
51.     Dim a As _MEM 'not defined
52.  
53.     N = 0
54.  
55.     Open FILENAME For Binary As #1
56.     Get #1, 11, OF 'Offset to picture dat
57.     Get #1, 15, L 'Header size
58.     Get #1, , W 'image width
59.     Get #1, , H 'image height
60.     Get #1, , I 'biPlanes. Specifies the number of color planes on the target device.
61.     Get #1, , I 'bits per pixel. Must = 24 for the program to work.
62.     If I <> 24 Then W = 0: GoTo LL1
63.     HANDLE = _NewImage(W, Abs(H), 32)
64.     a = _MemImage(HANDLE)
65.     pad = 4 - (W * 3) Mod 4
66.     If pad = 4 Then pad = 0 'pad = multiple of 4
67.     If H < 0 Then
68.         For R = 0 To Abs(H) - 1
69.             For C = 1 To W * 3 Step 3
70.                 Get #1, R * (W * 3 + pad) + C + OF, t
71.                 tt = t + Chr$(255)
72.                 _MemPut a, a.OFFSET + N, tt
73.                 N = N + 4
74.             Next C
75.         Next R
76.     End If
77.     If H > 0 Then
78.         For R = H - 1 To 0 Step -1
79.             For C = 1 To W * 3 Step 3
80.                 Get #1, R * (W * 3 + pad) + C + OF, t
81.                 tt = t + Chr$(255)
82.                 _MemPut a, a.OFFSET + N, tt
83.                 N = N + 4
84.             Next C
85.         Next R
86.     End If
87.     LL1:
88.     Close
89. End Sub
90.  
91. Function loadBMP24& (Filename$) ' Steve's revised version without the extra handle and memory leak
92.     Dim As _Unsigned Long of, l, w, r, c
93.     Dim i As _Unsigned Integer
94.     Dim a As _MEM
95.     Dim As Long handle, h ' <<< edit as per NOVARSEG
96.     Dim tt As String * 4
97.     Dim t As String * 3
98.     Dim padding$
99.  
100.     If Right$(UCase$(Filename$), 4) <> ".BMP" Then Exit Function
101.     Print Filename$
102.     Open Filename$ For Binary As #1
103.     Get #1, 11, of
104.     Get #1, 15, l
105.     Get #1, , w
106.     Get #1, , h
107.     Get #1, , i
108.     Get #1, , i 'get I twice ???
109.     If i <> 24 Then Exit Function
110.     handle = _NewImage(w, h, 32)
111.     a = _MemImage(handle)
112.     If ((w * 3) Mod 4) <> 0 Then padding$ = Space$((4 - ((w * 3) Mod 4))) '’need padding pixels
113.     Seek #1, of + 1 'go to the offset where the data starts
114.     For r = h - 1 To 0 Step -1 'from the bottom to top
115.         For c = 0 To w - 1 'left to right
116.             Get #1, , t 'get the data sequentially
117.             tt = t + Chr$(255)
118.             _MemPut a, a.OFFSET + (w * r + c) * 4, tt
119.         Next c
120.         Get #1, , padding$ 'Get the padding at the end of the line
121.     Next r
122.     Close
123.     loadBMP24& = handle
124.     _MemFree a
125. End Function
126.  
127. Function GetFileName$ (LocateR, LocateC, CharWide, CharHigh) ' < careful Locate Row, Col NOT x, y
128.     'This Funtion needs:
129.     ' pipecom.h in same folder as QB64.exe
130.     ' This in main code section near top:
131.     ' Declare Library "pipecom"
132.     '    Function pipecom$ (cmd As String)
133.     ' End Declare
134.     ' sub  Split source$, delimiter$, arr$()
135.     ' function GetArrayItem$(x, y, w, h, arr$())
136.  
137.     ReDim As String d, s, dr
138.     ReDim As _Unsigned Long fc, bc
139.     fc = _DefaultColor: bc = _BackgroundColor ' save colors
140.     Getfolder:
141.     Color fc, bc: Cls
142.     d = pipecom("dir /n /o:gend") '/n files on right (40) /o = order g for group dirs first, e extension, name, date
143.     d = Left$(d, Len(d) - 1) ' always ends with delimiter
144.     ReDim dir(1 To 1) As String
145.     Split d, Chr$(10), dir()
146.     s = GetArrayItem$(LocateR, LocateC, CharWide, CharHigh, dir())
147.     If InStr(s, "<DIR>") Then 'isolate name
148.         dr = _Trim$(Mid$(s, InStr(s, "<DIR>") + 6))
149.         ChDir dr
150.         GoTo Getfolder
151.     ElseIf InStr(s, "AM") Or InStr(s, "PM") Then
152.         GetFileName$ = _Trim$(Mid$(s, 40))
153.         Color fc, bc: Cls
154.     ElseIf s = "" Then 'cancel, escape, bad line
155.         Color fc, bc: Cls ' will return empty string
156.     End If
157. End Function
158.  
159. Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
160.     Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
161.     curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
162.     dpos = InStr(curpos, SplitMeString, delim)
163.     Do Until dpos = 0
164.         loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
165.         arrpos = arrpos + 1
166.         If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
167.         curpos = dpos + LD
168.         dpos = InStr(curpos, SplitMeString, delim)
169.     Loop
170.     loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
171.     ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
172. End Sub
173.  
174.  
175. ' Help: all this I hope is intuitive so Help window is provided
176. ' "Mouse, mouse wheel, and arrow keys should work as expected for item selection."
177. ' "Press spacebar to select a highlighted item or just click it."
178. ' "Use number(s) + enter to select an array item by it's index number,"
179. ' "backspace will remove last number pressed, delete will clear a number started.
180. ' "Numbers started are shown in bottom right PgDn bar."
181. ' "Enter will also select the highlighted item, if no number has been started."
182. ' "Home starts you at lowest array index, End highlights then highest index."
183. ' "Use PgUp and PgDn keys to flip through pages of array items."
184. '
185. ' Escape to Cancel Return "" else Return the selected string from the array
186. Function GetArrayItem$ (LocateRoww, LocateColumn, BoxWidth, BoxHeight, Arr() As String)
187.     'Notes: locateRow, locateColumn for top right corner of selection box on screen in characters for LOCATE.
188.     'boxWidth and boxHeight are in character units, again for locate and print at correct places.
189.     'All displaying is restricted to inside the box, which has PgUP and PgDn as top and bottom lines in the display.
190.  
191.     ReDim As Long maxWidth, maxHeight, page, hlite, mx, my, locateRow, lastMX, lastMY, row, mb
192.     ReDim As Long lba, uba, choice, kh, index
193.     Dim clrStr As String, b As String
194.  
195.     'ScnState 0 ' use out side this function before and after
196.     locateRow = LocateRoww + 1 'fix a miscalc in coding
197.     maxWidth = BoxWidth '       number of characters in box
198.     maxHeight = BoxHeight - 2 ' number of lines displayed of array at one time = 1 page
199.     lba = LBound(arr)
200.     uba = UBound(arr)
201.     page = 0
202.     hlite = 0 '                 line in display ready for selection by spacebar or if no number is started, enter
203.     clrStr$ = Space$(maxWidth) 'clearing a display line
204.  
205.     GoSub update '              show the beginning of the array items for selection
206.     choice = -1719
207.     Do 'until get a selection or demand exit
208.  
209.         'handle the key stuff
210.         kh& = _KeyHit
211.         If kh& Then
212.             If kh& > 0 And kh& < 255 Then
213.                 If InStr("0123456789", Chr$(kh&)) > 0 Then
214.                     b$ = b$ + Chr$(kh&): GoSub update
215.                 ElseIf kh& = 13 Then 'enter pressed check if number is being entered?
216.                     If Len(b$) Then
217.                         If Val(b$) >= lba And Val(b$) <= uba Then 'we have number started
218.                             choice = Val(b$): Exit Do
219.                         Else 'clear b$ to show some response to enter
220.                             b$ = "": GoSub update 'clear the value that doesn't work
221.                         End If
222.                     Else
223.                         choice = hlite + page * maxHeight + lba 'must mean to select the highlighted item
224.                     End If
225.                 ElseIf kh& = 27 Then
226.                     Exit Do 'escape clause offered to Cancel selection process
227.                 ElseIf kh& = 32 Then
228.                     choice = hlite + page * maxHeight + lba 'best way to choose highlighted selection
229.                 ElseIf kh& = 8 Then 'backspace to edit number
230.                     If Len(b$) Then b$ = Left$(b$, Len(b$) - 1): GoSub update
231.                 End If
232.             Else
233.                 Select Case kh& 'choosing sections of array to display and highlighted item
234.                     Case 21248 ' delete so clear b$
235.                         b$ = "": GoSub update
236.                     Case 20736 ' pg dn
237.                         If (page + 1) * maxHeight + lba <= uba Then page = page + 1: GoSub update
238.                     Case 18688 ' pg up
239.                         If (page - 1) * maxHeight + lba >= lba Then page = page - 1: GoSub update
240.                     Case 18432 ' up
241.                         If hlite - 1 < 0 Then
242.                             If page > 0 Then
243.                                 page = page - 1: hlite = maxHeight - 1: GoSub update
244.                             End If
245.                         Else
246.                             hlite = hlite - 1: GoSub update
247.                         End If
248.                     Case 20480 'down
249.                         If (hlite + 1) + page * maxHeight + lba <= uba Then 'ok to move up
250.                             If hlite + 1 > maxHeight - 1 Then
251.                                 page = page + 1: hlite = 0: GoSub update
252.                             Else
253.                                 hlite = hlite + 1: GoSub update
254.                             End If
255.                         End If
256.                     Case 18176 'home
257.                         page = 0: hlite = 0: GoSub update
258.                     Case 20224 ' end
259.                         page = Int((uba - lba) / maxHeight): hlite = maxHeight - 1: GoSub update
260.                 End Select
261.             End If
262.         End If
263.  
264.         'handle the mouse stuff
265.         While _MouseInput
266.             If _MouseWheel = -1 Then 'up?
267.                 If hlite - 1 < 0 Then
268.                     If page > 0 Then
269.                         page = page - 1: hlite = maxHeight - 1: GoSub update
270.                     End If
271.                 Else
272.                     hlite = hlite - 1: GoSub update
273.                 End If
274.             ElseIf _MouseWheel = 1 Then 'down?
275.                 If (hlite + 1) + page * maxHeight + lba <= uba Then 'ok to move up
276.                     If hlite + 1 > maxHeight - 1 Then
277.                         page = page + 1: hlite = 0: GoSub update
278.                     Else
279.                         hlite = hlite + 1: GoSub update
280.                     End If
281.                 End If
282.             End If
283.         Wend
284.         mx = Int((_MouseX - LocateColumn * 8) / 8) + 2: my = Int((_MouseY - locateRow * 16) / 16) + 2
285.         If _MouseButton(1) Then 'click contols or select array item
286.             'clear mouse clicks
287.             mb = _MouseButton(1)
288.             If mb Then 'clear it
289.                 While mb 'OK!
290.                     If _MouseInput Then mb = _MouseButton(1)
291.                     _Limit 100
292.                 Wend
293.             End If
294.  
295.             If mx >= 1 And mx <= maxWidth And my >= 1 And my <= maxHeight Then
296.                 choice = my + page * maxHeight + lba - 1 'select item clicked
297.             ElseIf mx >= 1 And mx <= maxWidth And my = 0 Then 'page up or exit
298.                 If my = 0 And (mx <= maxWidth And mx >= maxWidth - 2) Then 'exit sign
299.                     Exit Do 'escape plan for mouse click top right corner of display box
300.                 Else 'PgUp bar clicked
301.                     If (page - 1) * maxHeight + lba >= lba Then page = page - 1: GoSub update
302.                 End If
303.             ElseIf mx >= 1 And mx <= maxWidth And my = maxHeight + 1 Then 'page down bar clicked
304.                 If (page + 1) * maxHeight + lba <= uba Then page = page + 1: GoSub update
305.             End If
306.         Else '   mouse over highlighting, only if mouse has moved!
307.             If mx >= 1 And mx <= maxWidth And my >= 1 And my <= maxHeight Then
308.                 If mx <> lastMX Or my <> lastMY Then
309.                     If my - 1 <> hlite And (my - 1 + page * maxHeight + lba <= uba) Then
310.                         hlite = my - 1
311.                         lastMX = mx: lastMY = my
312.                         GoSub update
313.                     End If
314.                 End If
315.             End If
316.         End If
317.         _Limit 200
318.     Loop Until choice >= lba And choice <= uba
319.     If choice <> -1719 Then GetArrayItem$ = Arr(choice) 'set function and restore screen
320.     'ScnState -1 'restore
321.     Exit Function
322.  
323.     'display of array sections and controls on screen  ====================================================
324.     update:
325.  
326.     'fix hlite if it has dropped below last array item
327.     While hlite + page * maxHeight + lba > uba
328.         hlite = hlite - 1
329.     Wend
330.  
331.     'main display of array items at page * maxHeight (lines high)
332.     For row = 0 To maxHeight - 1
333.         If hlite = row Then Color _RGB(200, 200, 255), _RGB32(0, 0, 88) Else Color _RGB32(0, 0, 88), _RGB(200, 200, 255)
334.         Locate locateRow + row, LocateColumn: Print clrStr$;
335.         index = row + page * maxHeight + lba
336.         If index >= lba And index <= uba Then
337.             Locate locateRow + row, LocateColumn
338.             Print Left$(LTrim$(Str$(index)) + ") " + Arr(index), maxWidth);
339.         End If
340.     Next
341.  
342.     'make page up and down bars to click, print PgUp / PgDn if available
343.     Color _RGB32(200, 200, 255), _RGB32(0, 100, 50)
344.     Locate locateRow - 1, LocateColumn: Print Space$(maxWidth);
345.     If page <> 0 Then Locate locateRow - 1, LocateColumn: Print Left$(" Pg Up" + Space$(maxWidth), maxWidth);
346.     Locate locateRow + maxHeight, LocateColumn: Print Space$(maxWidth);
347.     If page <> Int(uba / maxHeight) Then
348.         Locate locateRow + maxHeight, LocateColumn: Print Left$(" Pg Dn" + Space$(maxWidth), maxWidth);
349.     End If
350.     'make exit sign for mouse click
351.     Color _RGB32(255, 255, 255), _RGB32(200, 100, 0)
352.     Locate locateRow - 1, LocateColumn + maxWidth - 3
353.     Print " X ";
354.  
355.     'if a number selection has been started show it's build = b$
356.     If Len(b$) Then
357.         Color _RGB(255, 255, 0), _RGB32(0, 0, 0)
358.         Locate locateRow + maxHeight, LocateColumn + maxWidth - Len(b$) - 1
359.         Print b$;
360.     End If
361.     _Display
362.     _Limit 100
363.     Return
364. End Function
365.  
366. Sub ScnState (restoreTF As Long) 'Thanks Steve McNeill  should we get a snap shot of screen?
367.     Static As _Unsigned Long defaultColor, backGroundColor
368.     Static As Long font, dest, source, row, col, autodisplay, mb, snap
369.     If restoreTF Then
370.         _Font font
371.         Color defaultColor, backGroundColor
372.         _Dest dest
373.         _Source source
374.  
375.         _KeyClear
376.         While _MouseInput: Wend 'clear mouse clicks
377.         mb = _MouseButton(1)
378.         If mb Then 'need this if line ?
379.             Do
380.                 While _MouseInput: Wend
381.                 mb = _MouseButton(1)
382.                 _Limit 100
383.             Loop Until mb = 0
384.         End If
385.         _PutImage , snap, dest
386.         _FreeImage snap
387.         _Display
388.         If autodisplay Then _AutoDisplay Else _Display
389.         Locate row, col
390.     Else
391.         snap = _NewImage(_Width, _Height, 32)
392.         _PutImage , 0, snap
393.         font = _Font: defaultColor = _DefaultColor: backGroundColor = _BackgroundColor
394.         dest = _Dest: source = _Source
395.         row = CsrLin: col = Pos(0): autodisplay = _AutoDisplay
396.         While _MouseInput: Wend 'clear mouse clicks
397.         mb = _MouseButton(1)
398.         If mb Then 'need this if line ?
399.             Do
400.                 While _MouseInput: Wend
401.                 mb = _MouseButton(1)
402.                 _Limit 100
403.             Loop Until mb = 0
404.         End If
405.         _KeyClear
406.     End If
407. End Sub
408.  
409.  
410.  
411.  

Need this in your QB64.exe Folder

[NOVARSEG]

That is the first sub I have written in years!
 Do  I need the latest ver of QB64 to see this?   

Glad it worked even on -h too ?

i see you used  _FreeImage image&

Ok prob works better than  _MEMFREE a   

[bplus]

That is the first sub I have written in years!
 Do  I need the latest ver of QB64 to see this?   

Glad it worked even on -h too ?

i see you used  _FreeImage image&

Ok prob works better than  _MEMFREE a   

For your version QB64, you might have to change the REDIM statements that declare Types in groups like:
ReDim As Long x, y, z

Just make:
Redim x as long, y as long, z as long

Or get the 1.5 dev version ;)


I used _FreeImage because what was stored in Handle was an image.

_MEMFREE a should have been in LoadBMP24 Sub because that is where the variable, a, resides.
I don't know with _Mem stuff if a is automatically cleared like a regular variable as soon as you exit the sub. We know images wont.