Hello !
Out of curiosity, I created a program for converting images to characters.
There are so many online, there are also online converters.
I tried to add something extra. It also works with variable character width, and the shades of the image can be adjusted.
Enter the image and font in the source code. You can change what characters it uses.
When the program starts, the optimal image can be adjusted with brightness/contrast.
It is possible to set how many lines the image is displayed.
Black characters on a white background or white characters on a black background.
The width of the letter can be adjusted. (1- original 0.5, half as wide, 2, double wide)
You can set the size of the map to work on. This is important when saving, because the image can be saved in very good quality.
The program does not require external files.
Give it a picture and start it.
Out of curiosity, I created a program for converting images to characters.
There are so many online, there are also online converters.
I tried to add something extra. It also works with variable character width, and the shades of the image can be adjusted.
Enter the image and font in the source code. You can change what characters it uses.
When the program starts, the optimal image can be adjusted with brightness/contrast.
It is possible to set how many lines the image is displayed.
Black characters on a white background or white characters on a black background.
The width of the letter can be adjusted. (1- original 0.5, half as wide, 2, double wide)
You can set the size of the map to work on. This is important when saving, because the image can be saved in very good quality.
The program does not require external files.
Give it a picture and start it.
Code: (Select All)
'MasterGy 2022
Dim Shared pic, contrast, brightness, contrast_ref, char_collection$
'CHANGES SETTING ! ----------------------------------------------------------------------------------------------------------------------
picture$ = "image1.jpg" ' <------ set a picture
char_collection$ = "'+0123456789.?!=:>()<%/-,ABCDEFGHIJKLMNOPQRSTVXYZUWabcdefghijklmnopqrstvxyzuw" '<----- charecters used
type_s$ = Environ$("systemroot") + "/fonts/arial.ttf" '<------ font type
'------------------------------------------------------------------------------------------------------------------------------
s$ = " Press S to save BMP file , ESC to return menu ": _Font 16
mess = _NewImage(8 * Len(s$), 16, 32): _Dest mess: Cls , _RGB32(100, 0, 0, 100): Color _RGB32(255, 255, 255, 255), _RGB32(100, 0, 0, 100): Locate 1, 1: Print s$;
pic_size = 500
temp = _LoadImage(picture$, 32): _Source temp
If _Width(temp) > _Height(temp) Then x = pic_size: y = Int(x / _Width(temp) * _Height(temp)) Else y = pic_size: x = Int(y / _Height(temp) * _Width(temp))
pic = _NewImage(x, y, 32): _Dest pic: _PutImage: _FreeImage temp
s_c = 7
s$(0) = "contrast": s(0, 0) = 1.5: s(0, 1) = 1: s(0, 2) = 7
s$(1) = "contrast_ref": s(1, 0) = 128: s(1, 1) = 0: s(1, 2) = 255
s$(2) = "brigthness": s(2, 0) = 0: s(2, 1) = -255: s(2, 2) = 255
s$(3) = "types rows": s(3, 0) = 75: s(3, 1) = 10: s(3, 2) = 200
s$(4) = "output picture size": s(4, 0) = _DesktopWidth: s(4, 1) = 300: s(4, 2) = 3000
s$(5) = "picture colors negate": s(5, 0) = 1: s(5, 1) = 0: s(5, 2) = 1
s$(6) = "type width-ratio": s(6, 0) = 1: s(6, 1) = .5: s(6, 2) = 4
s_sy = Int((y / 16) + 2): winx = x + 100: winy = (s_sy + s_c * 3 + 3) * 16 + 1: x_size = winx * .7
win = _NewImage(winx, winy, 32): Screen win: _FullScreen _SquarePixels , _Smooth
Do: _Limit 30
k$ = InKey$
Select Case k$
Case Chr$(27): System
Case "1", "2", "3": work_type = Val(k$): GoSub work
End Select
mousew = 0: While _MouseInput: mousew = mousew + _MouseWheel: Wend: If _MouseButton(1) = 0 Then mc = -1
s(3, 0) = Int(s(3, 0))
s(4, 0) = Int(s(4, 0))
s(5, 0) = CInt(s(5, 0))
s(7, 0) = CInt(s(7, 0))
For sa = 0 To s_c - 1
y1 = (s_sy + sa * 3 - 1) * 16 + 20: y2 = y1 + 14: x1 = (winx - x_size) / 2: x2 = x1 + x_size
under2 = _MouseX > x1 And _MouseX < x2: under = under2 And _MouseY > y1 And _MouseY < y2
mgrey = 128 + (CInt(s(5, 0)) * 2 - 1) * 127 * under
Color _RGB(mgrey, mgrey, mgrey)
s$ = s$(sa) + " (" + LTrim$(Str$(Int(s(sa, 0) * 100) / 100)) + ")"
If sa = 4 Then s$ = s$(sa) + " (" + LTrim$(Str$(Int(s(sa, 0)))) + " x " + LTrim$(Str$(Int(s(sa, 0) / x * y))) + ")"
Locate s_sy + sa * 3, (winx - Len(s$) * 8) / 16: Print UCase$(s$)
Color _RGB(200, 40, 40): Line (x1, y1)-(x2, y2), , B
x2 = x1 + x_size / (s(sa, 2) - s(sa, 1)) * (s(sa, 0) - s(sa, 1)): Line (x1, y1)-(x2, y2), , BF
If under And _MouseButton(1) And mc = -1 Then mc = sa
Next sa
If mc <> -1 And under2 And mc <> 5 Then s(mc, 0) = (s(mc, 2) - s(mc, 1)) * (1 / x_size * (_MouseX - (winx - x_size) / 2)) + s(mc, 1)
If mc = 5 And under2 And m5last = 0 Then s(5, 0) = 1 - s(5, 0): m5last = 1
m5last = m5last And -_MouseButton(1)
contrast = s(0, 0): contrast_ref = s(1, 0): brightness = s(2, 0)
'statistic
min = 999999: max = -min: _Dest mon: _Source pic
For tx = 0 To x - 1: For ty = 0 To y - 1: grey = pic_read(tx, ty): If grey > max Then max = grey
If grey < min Then min = grey
Next ty, tx
'draw
temp = 255 / (max - min)
sx = (winx - x) / 2: For tx = 0 To x - 1: For ty = 0 To y - 1: grey = temp * (pic_read(tx, ty) - min): PSet (sx + tx, ty), _RGB(grey, grey, grey): Next ty, tx
_Display
grey = 255 * CInt(s(5, 0))
Cls , _RGB(grey, grey, grey)
Color _RGB(50, 128, 50), 0
Locate Int(winy / 16) - 3, 3: Print "-1- work variable character width";
Locate Int(winy / 16) - 2, 3: Print "-2- work same character width";
Locate Int(winy / 16) - 1, 3: Print "-3- work random character location";
Loop
'work
work:
Cls
_AutoDisplay
monx2 = Int(s(4, 0))
mony2 = Int(s(4, 0) / x * y)
t_height = Int(mony2 / s(3, 0))
temp = _LoadImage(picture$, 32): _Source temp: pic_work = _NewImage(monx2, mony2, 32): _Dest pic_work: _PutImage: _Source pic_work: _FreeImage temp
pic_out = _NewImage(monx2, mony2, 32)
temp = 255 / (max - min)
For tx = 0 To monx2 - 1: For ty = 0 To mony2 - 1: grey = temp * (pic_read(tx, ty) - min): PSet (tx, ty), _RGB(grey, grey, grey): Next ty, tx
mon2 = _NewImage(monx2, mony2, 32): Screen mon2
negate = CInt(s(5, 0))
ReDim Shared font_collection(255, 2): font_install type_s$, t_height * 2, negate, Abs(work_type = 2): _Font 16
_Dest pic_out
Cls , _RGB(255 * negate, 255 * negate, 255 * negate)
_FullScreen _SquarePixels , _Smooth
Select Case work_type
Case 1, 2
ReDim st(499, 1)
Do: For a_row = 0 To Int(s(3, 0)) - 1
_Source pic_out: _Dest mon2: _PutImage
_Source mess: _PutImage (0, 0)-(_Width(mon2), _Width(mon2) / _Width(mess) * _Height(mess)): _Display
_Dest pic_out
a_col = 0
Do
_Source pic_work
dif_ok = 99999
For ac = 0 To Len(char_collection$) - 1
Select Case LCase$(InKey$): Case Chr$(27): GoTo return_menu: Case "s": GoTo saving: End Select
x1 = a_col
stx = Int(t_height / _Height(font_collection(ac + 1, 0)) * _Width(font_collection(ac + 1, 0)))
x2 = x1 + Int(s(6, 0) * stx)
If x2 > monx2 Then Exit Do
y1 = a_row * t_height
y2 = y1 + t_height
If st(stx, 0) = a_col Then
st = st(stx, 1)
Else
sum = 0: c = 0: For tx = x1 To x2
For ty = y1 To y2: sum = sum + _Red(Point(tx, ty)): c = c + 1: Next ty, tx
st(stx, 0) = a_col
st = sum / (255 * c)
st(stx, 1) = st
End If
dif = Abs(st - font_collection(ac + 1, 2))
If dif < dif_ok Then dif_ok = dif: st_need = ac: x2_need = x2
Next ac
_Source font_collection(st_need + 1, 0)
_PutImage (x1, y1)-(x2_need, y2)
a_col = x2_need + 1
Loop
Next a_row: Loop
Case 3
Do
cn = cn + 1: If cn > 100 Then
_Source pic_out: _Dest mon2: _PutImage
_Source mess: _PutImage (0, 0)-(_Width(mon2), _Width(mon2) / _Width(mess) * _Height(mess)): _Display
cn = 0
End If
_Dest pic_out
Select Case LCase$(InKey$): Case Chr$(27): GoTo return_menu: Case "s": GoTo saving: End Select
xsize = Int(t_height * (1 + .5 * Rnd))
ysize = Int(t_height * (1 + .5 * Rnd))
xpos = Int((monx2 - xsize) * Rnd)
ypos = Int((mony2 - ysize) * Rnd)
sum = 0: c = 0: For tx = 0 To xsize - 1
_Source pic_work
For ty = 0 To ysize - 1: sum = sum + _Red(Point(tx + xpos, ty + ypos)): c = c + 1: Next ty, tx
st = sum / (255 * c)
dif_ok = 99999
For ac = 0 To Len(char_collection$) - 1
dif = Abs(st - font_collection(ac + 1, 2))
If dif < dif_ok Then dif_ok = dif: st_need = ac
Next ac
_Source font_collection(st_need + 1, 0)
_PutImage (xpos, ypos)-(xpos + xsize, ypos + ysize)
Loop
End Select
saving: _AutoDisplay: Screen 0: _FullScreen _Off: Cls: Print "saving picture to SAVED.BMP...waiting": SaveImage pic_out, "saved.bmp": Sleep 2: System
return_menu: Screen win: _Dest win: _Source win: _Font 16: _FreeImage mon2: _FreeImage pic_work: _FreeImage pic_out: Return
Sub font_install (f$, fs, negate, mono)
If mono Then af = _LoadFont(f$, fs, "monospace") Else af = _LoadFont(f$, fs)
For ac = 0 To Len(char_collection$) - 1: ac$ = Mid$(char_collection$, ac + 1, 1): _Font af
temp2 = _NewImage(_PrintWidth(ac$), fs, 32): _Dest temp2: Cls , _RGB(255 * negate, 255 * negate, 255 * negate)
_Font af: Color _RGB(255 * (negate Xor 1), 255 * (negate Xor 1), 255 * (negate Xor 1)), 0
_PrintString (0, 0), ac$: font_collection(ac + 1, 0) = _CopyImage(temp2, 32): _Source temp2
c = 0: st = 0: For tx = 0 To _Width(temp2) - 1: For ty = 0 To _Height(temp2) - 1: c = c + 1: st = st + Abs(_Red(Point(tx, ty)) <> _Red(tc&&)): Next ty, tx
font_collection(ac + 1, 2) = 1 / c * st: _FreeImage temp2
font_collection(ac + 1, 1) = Asc(ac$): Next ac
font_collection(0, 0) = af
min_g = 99999: max_g = -min_g
For t = 0 To Len(char_collection$) - 1 'find limits
If font_collection(t + 1, 2) < min_g Then min_g = font_collection(t + 1, 2)
If font_collection(t + 1, 2) > max_g Then max_g = font_collection(t + 1, 2)
Next t
For t = 0 To Len(char_collection$) - 1 'normalizing limits
font_collection(t + 1, 2) = 1 / (max_g - min_g) * (font_collection(t + 1, 2) - min_g)
Next t
End Sub
Function pic_read (tx, ty)
p&& = Point(tx, ty): grey = (_Red(p&&) + _Green(p&&) + _Blue(p&&)) * .33333
grey = contrast_ref + (grey - contrast_ref) * contrast + brightness
If grey < 0 Then grey = 0
If grey > 255 Then grey = 255
pic_read = grey
End Function
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