Qbasicnews.com › Qbasic "like" compilers/interpreters › FB Discussion & Programming Help › FB Projects v
BMP 2 HTML

Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Threaded Mode
BMP 2 HTML
yetifoot Offline
Senior Member
****
Posts: 484
Threads: 14
Joined: Apr 2005
#1
12-09-2005, 06:49 AM
saw a page recently that had an image converted to text and thought id rip off the idea. heres what i came up with.

www.streetcds.co.uk/test1.html
www.streetcds.co.uk/test2.html

Code:
#include "crt.bi"
#include "windows.bi"

Option Explicit

Dim Shared message As String

message = "TestStringIsStandardInThisSituationIfYouAreReallyLuckyIMayEvenSayHelloWorld"

Sub Write_Header(hFile As Integer)
  Print #hFile, "<html>"
  Print #hFile, "<body style=""background-color: #000000;text-align: center;font-size: 7pt;"">"
  Print #hFile, "<pre>"
End Sub

Sub Write_Footer(hFile As Integer)
  Print #hFile, "</pre>"
  Print #hFile, "</body>"
  Print #hFile, "</html>"
End Sub

Function HTML_Hex(col As uInteger) As String
  Dim str_ret As String
  Dim i As Integer
  Dim tmp_ptr As uByte ptr
  
    tmp_ptr = cptr(uByte ptr, @col)
    
    For i = 0 To 2
      str_ret = hex(tmp_ptr[i]) & str_ret
      If Len(str_ret) = (i * 2) + 1 Then str_ret = "0" & str_ret
    Next i
    
    HTML_Hex = "#" & str_ret
End Function

Function GetHTMLColor(x As Integer, y As Integer, img_array As uByte ptr, img_width As Integer) As String
  Dim p As uInteger
  Dim q As uInteger
  
    p = (((y * img_width) + x) * 4) + 4
    memcpy(@q, @img_array[p], 4)
    GetHTMLColor = HTML_Hex(q)
    
End Function    

Function EatMessage() As String
  Static message_pos As uInteger
    EatMessage = Mid(message, message_pos + 1, 1)
    message_pos = message_pos + 1  
    If message_pos = len(message) Then message_pos = 0  
End Function

Sub Write_ImgData(hFile As Integer, img_array As uByte ptr, img_width As Integer, img_height As Integer)
  Dim As Integer x, y
  Dim bobo As String
    For y = 0 To img_height - 1
      For x = 0 To img_width - 1
        bobo = ""
        bobo = bobo & EatMessage
        bobo = bobo & EatMessage
        Print #hFile, "<font color=""" & GetHTMLColor(x, y, img_array, img_width) & """>" & bobo & "</font>";
      Next x
      Print #hFile, ""
    Next y  
End Sub

Sub Main()
  Dim hFile As Integer
  Dim bHead As BITMAPFILEHEADER
  Dim bInfo As BITMAPINFOHEADER
  Dim img_array AS uByte ptr
  Dim output_file As String
  Dim input_file As String
  Dim img_width As Integer
  Dim img_height As Integer  
  
    Screen 18, 24
    
    input_file = Command$
    output_file = input_file & ".html"
    
    If input_file = "" Then
      Print "No File Specified"
      Sleep
      End
    End If
    
    hFile = FreeFile
    Open input_file For Binary As #hFile
      Get #hFile, , bHead
      Get #hFile, , bInfo
    Close #hFile
    
    If bInfo.biBitCount <> 24 Then
      Print "Bitmaps Depth Was Not 24bit"
      Sleep
      End      
    End If
    
    img_width = bInfo.biWidth
    img_height = bInfo.biHeight

    Print " " & img_width & "x" & img_height

    img_array = malloc(4 * (img_width * img_height) + 4)

    BLoad input_file, img_array
    Put (7, 15), img_array
    
    hFile = FreeFile
    Open output_file For Output As #hFile
      Write_Header(hFile)
      Write_ImgData(hFile, img_array, img_width, img_height)
      Write_Footer(hFile)
    Close #hFile
    
    free(img_array)
    
End Sub

'Entry
Main
Sleep
EVEN MEN OF STEEL RUST.
[Image: chav.gif]
Find
Reply
yetifoot Offline
Senior Member
****
Posts: 484
Threads: 14
Joined: Apr 2005
#2
12-09-2005, 06:09 PM
just updated this. now compiles, and then takes bmp as argument (or drag bmp onto exe)

no need to redefine width and height anymore

max size for 1024x768 seems to be 101 x 49
EVEN MEN OF STEEL RUST.
[Image: chav.gif]
Find
Reply
Ryan Offline
Senior Member
****
Posts: 306
Threads: 14
Joined: Nov 2002
#3
12-09-2005, 07:14 PM
Very nice. 8)
Website Find
Reply
Torahteen Offline
Senior Member
****
Posts: 684
Threads: 64
Joined: May 2004
#4
12-09-2005, 07:36 PM
Haven't ran it myself, but the tests speak for themselves. Awesome work.
quote="Deleter"]judging gameplay, you can adaquately compare quake 4 with pong[/quote]
Find
Reply
yetifoot Offline
Senior Member
****
Posts: 484
Threads: 14
Joined: Apr 2005
#5
12-10-2005, 01:17 AM
just figured a optimization for making the HTML smaller

replace this sub

seems fine but i havent tested it as much as the old one.

Code:
Sub Write_ImgData(hFile As Integer, img_array As uByte ptr, img_width As Integer, img_height As Integer)
  Dim As Integer x, y
  Dim bobo As String
  Dim HTMLColor As String
  Static Old_HTMLColor As String  
  
    For y = 0 To img_height - 1
      Old_HTMLColor = ""
      For x = 0 To img_width - 1
        bobo = ""
        bobo = bobo & EatMessage
        bobo = bobo & EatMessage
        HTMLColor = GetHTMLColor(x, y, img_array, img_width)
        If HTMLColor <> Old_HTMLColor Then
          If x <> 0 Then
            Print #hFile, "</font>";
          End If
          Print #hFile, "<font color=""" & HTMLColor & """>" & bobo;
        Else
          Print #hFile, bobo;
        End If
        Old_HTMLColor = HTMLColor
      Next x
      Print #hFile, "</font>";
      Print #hFile, ""
    Next y  
End Sub
EVEN MEN OF STEEL RUST.
[Image: chav.gif]
Find
Reply


Forum Jump:


Users browsing this thread: 1 Guest(s)