VERSION 2.00
Begin Form Cbm2Bmp 
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Cbm 2 Bmp"
   ClientHeight    =   2190
   ClientLeft      =   1095
   ClientTop       =   1845
   ClientWidth     =   4065
   ForeColor       =   &H00000000&
   Height          =   2880
   Icon            =   CBM2BMP.FRX:0000
   Left            =   1035
   MaxButton       =   0   'False
   ScaleHeight     =   2190
   ScaleWidth      =   4065
   Top             =   1215
   Width           =   4185
   Begin CommonDialog CMSave 
      CancelError     =   -1  'True
      Color           =   &H00C0C0C0&
      DefaultExt      =   "bmp"
      DialogTitle     =   "Save: Cbm 2 Bmp"
      Filter          =   "Bmp Files(*.bmp)|*.bmp|All Files(*.*)|*.*"
      Flags           =   2054
      Left            =   480
      Top             =   1080
   End
   Begin CommonDialog CMLoad 
      CancelError     =   -1  'True
      Color           =   &H00C0C0C0&
      DialogTitle     =   "Load: Cbm 2 Bmp"
      Filter          =   "All files(*.*)|*.*"
      Flags           =   38916
      Left            =   0
      Top             =   1080
   End
   Begin Label Label10 
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "0 Min 0 Sec"
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00000000&
      Height          =   255
      Left            =   1320
      TabIndex        =   9
      Top             =   1920
      Width           =   2655
   End
   Begin Label Label9 
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "ETA:"
      ForeColor       =   &H00000000&
      Height          =   255
      Left            =   120
      TabIndex        =   8
      Top             =   1920
      Width           =   1215
   End
   Begin Shape Shape1 
      BackColor       =   &H00000000&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00000000&
      BorderStyle     =   0  'Transparent
      DrawMode        =   6  'Invert
      Height          =   240
      Left            =   1335
      Top             =   1570
      Width           =   2640
   End
   Begin Label Label8 
      Alignment       =   2  'Center
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      BorderStyle     =   1  'Fixed Single
      Caption         =   "Done"
      ForeColor       =   &H00808080&
      Height          =   255
      Left            =   1320
      TabIndex        =   7
      Top             =   1560
      Width           =   2655
   End
   Begin Label Label7 
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "Converting:"
      ForeColor       =   &H00000000&
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   1560
      Width           =   1215
   End
   Begin Label Label6 
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "None"
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00000000&
      Height          =   615
      Left            =   1320
      TabIndex        =   5
      Top             =   840
      Width           =   2655
      WordWrap        =   -1  'True
   End
   Begin Label Label5 
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "None"
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00000000&
      Height          =   255
      Left            =   1320
      TabIndex        =   4
      Top             =   480
      Width           =   2655
   End
   Begin Label Label4 
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "None"
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00000000&
      Height          =   255
      Left            =   1320
      TabIndex        =   3
      Top             =   120
      Width           =   2655
   End
   Begin Label Label3 
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "Comments:"
      ForeColor       =   &H00000000&
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   840
      Width           =   1215
   End
   Begin Label Label2 
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "Picture Type:"
      ForeColor       =   &H00000000&
      Height          =   255
      Left            =   120
      TabIndex        =   1
      Top             =   480
      Width           =   1215
   End
   Begin Label Label1 
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "Filename:"
      ForeColor       =   &H00000000&
      Height          =   255
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   1215
   End
   Begin Menu mnuMain 
      Caption         =   "&File"
      Index           =   1
      Begin Menu mnuFile 
         Caption         =   "&Load Cbm"
         Index           =   1
         Shortcut        =   ^L
      End
      Begin Menu mnuFile 
         Caption         =   "&Save Bmp"
         Enabled         =   0   'False
         Index           =   2
         Shortcut        =   ^S
      End
      Begin Menu mnuFile 
         Caption         =   "-"
         Index           =   3
      End
      Begin Menu mnuFile 
         Caption         =   "&Abort"
         Enabled         =   0   'False
         Index           =   4
         Shortcut        =   ^Z
      End
      Begin Menu mnuFile 
         Caption         =   "-"
         Index           =   5
      End
      Begin Menu mnuFile 
         Caption         =   "&Exit"
         Index           =   6
         Shortcut        =   ^X
      End
   End
   Begin Menu mnuMain 
      Caption         =   "&Help"
      Index           =   2
      Begin Menu mnuHelp 
         Caption         =   "&About"
         Index           =   1
         Shortcut        =   ^A
      End
   End
End
DefInt A-Z

Const NUMB = 20
Const CDERR_CANCEL = 32755
Const HALF = 0, FULL = 1
Const GEO = -1, HRBW = 0, HR = 1, MC = 2

Dim picname$
Dim CBMColor(0 To 15) As Long
Dim shapewidth
Dim imagetype
Dim converting, abort
Dim tistart As Single
Dim xinit$, xfile$
Dim geosize

Dim p_name(0 To NUMB) As String
Dim p_sa(1 To NUMB) As Long
Dim p_len(1 To NUMB) As Long
Dim p_bitmap(1 To NUMB) As Long
Dim p_screen(1 To NUMB) As Long
Dim p_colour(1 To NUMB) As Long
Dim p_back(1 To NUMB) As Long
Dim p_type(0 To NUMB) As Integer

Sub CheckType ()
    imagetype = HRBW

    Open picname$ For Binary Access Read As 1

    ReadBlock buffer$:       'first sector
    If Mid$(buffer$, 22, 2) = Chr$(1) + Chr$(7) Then
        ReadBlock buffer$:      'second sector
        If Mid$(buffer$, 76, 11) = "Paint Image" Then
            comment$ = Mid$(buffer$, 159)
            x = InStr(comment$, Chr$(0))
            If x > 0 Then comment$ = Left$(comment$, x - 1)
            Label5.Caption = "GeoPaint Image"
            Label6.Caption = comment$
            imagetype = GEO
            Close 1
            Exit Sub
        End If
    End If

    sa$ = Space$(2)
    Get #1, 1, sa$
    Close 1
    
    flen& = FileLen(picname$)
    fsa& = Asc(Right$(sa$, 1)) * 256 + Asc(sa$)

    For i = 1 To NUMB
        If p_sa(i) = fsa& And p_len(i) = flen& Then
            imagetype = i
            Exit For
        End If
    Next i

    Label5.Caption = p_name(imagetype)
    Label6.Caption = "None"
End Sub

Sub Convert ()
    converting = True
    abort = False

    Label8 = "0%"
    Label10 = "Calibrating"
    Shape1.Width = 0

    GeoPic.Hide
    cbmpic.Hide

    f$ = picname$
    Do
        x = InStr(f$, "\")
        If x = 0 Then Exit Do
        f$ = Mid$(f$, x + 1)
    Loop

    Select Case imagetype
    Case GEO
        GeoPic.Picture1.Picture = LoadPicture("")
        GeoPic.Image1.Picture = GeoPic.Picture1.Image
        GeoPic.Caption = "GeoPaint Image [" + f$ + "]"
        GeoPic.Show
        Call Convert_Geo
    Case Else
        cbmpic.Picture = LoadPicture("")
        cbmpic.Caption = p_name(imagetype) + " [" + f$ + "]"
        cbmpic.Show
        Call Convert_Other
    End Select

    mnufile(1).Enabled = True
    mnufile(4).Enabled = False
    If abort = False Then
        mnufile(2).Enabled = True
        Label8 = "Done"
    Else
        Label8 = "Aborted"
    End If
    Label10 = "0 Min 0 sec"
    
    converting = False
End Sub

Sub Convert_Geo ()

ReDim blocks(0 To 44, 1 To 2)
ReDim pat(0 To 7)

Open picname$ For Binary Access Read As 1

ReadBlock buffer$:      'first sector
ReadBlock buffer$:      'second sector
ReadBlock buffer$:      'third sector

validsectors = 0
sector = 0

For i = 0 To 44
  m$ = Left$(buffer$, 2)
  blocks(i, 1) = Asc(m$)
  If blocks(i, 1) <> 0 Then
    blocks(i, 2) = Asc(Right$(m$, 1))
    validsectors = validsectors + 1
  End If
  buffer$ = Mid$(buffer$, 3)
Next i

DoEvents
tistart = Timer
' display loop

For i = 0 To 44

If blocks(i, 1) > 0 Then

dat$ = ""
For j = 1 To blocks(i, 1)
    ReadBlock buffer$
    If j = blocks(i, 1) Then buffer$ = Left$(buffer$, blocks(i, 2))
    dat$ = dat$ + buffer$
Next j

bitposh = 0
bitposv = 0

dpos = 1
ldat = Len(dat$)

DoEvents

Do While bitposv < 16 And ldat >= dpos And abort = False

nxt = Asc(Mid$(dat$, dpos, 1) + Chr$(0))
dpos = dpos + 1

Select Case nxt
  Case 1 To 63
    For k = 1 To nxt
      pix = Asc(Mid$(dat$, dpos, 1) + Chr$(0))
      dpos = dpos + 1
      GoSub paintbit
      If abort Then Exit For
    Next k
  Case 65 To 127
    For k = 0 To 7
      pat(k) = Asc(Mid$(dat$, dpos, 1) + Chr$(0))
      dpos = dpos + 1
    Next k
    For l = 1 To (nxt And 63)
      For k = 0 To 7
        pix = pat(k)
        GoSub paintbit
      Next k
      If abort Then Exit For
    Next l
  Case 129 To 255
    dt = Asc(Mid$(dat$, dpos, 1) + Chr$(0))
    dpos = dpos + 1
    For k = 1 To (nxt - 128)
      pix = dt
      GoSub paintbit
      If abort Then Exit For
    Next k
End Select

Loop

If abort Then Exit For

If geosize = HALF Then GeoPic.Image1.Picture = GeoPic.Picture1.Image
DoEvents

sector = sector + 1
Call Percent(sector / validsectors * 100!)
DoEvents

End If

Next i

Close 1

Exit Sub


' *******************************************************


paintbit:
For k2 = 0 To 7
    Colour& = CBMColor(1)
    If (pix And (2 ^ k2)) Then Colour& = CBMColor(0)
    GeoPic.Picture1.PSet (bitposh * 8 + 7 - k2, i * 16 + bitposv), Colour&
Next k2
bitposv = bitposv + 1
If bitposv = 8 Or bitposv = 16 Then
    bitposh = bitposh + 1: bitposv = bitposv - 8
    DoEvents
    If bitposh > 79 Then
        bitposh = bitposh - 80: bitposv = bitposv + 8
    End If
End If
Return

End Sub

Sub Convert_Other ()

Open picname$ For Binary Access Read As 1
bitmap$ = Space$(8000)
scrn$ = Space$(1000)
col$ = Space$(1000)
bk$ = Chr$(1)
Select Case p_type(imagetype)
    Case HRBW
        Get #1, 3, bitmap$
    Case HR
        Get #1, p_bitmap(imagetype) + 3, bitmap$
        Get #1, p_screen(imagetype) + 3, scrn$
    Case MC
        Get #1, p_bitmap(imagetype) + 3, bitmap$
        Get #1, p_screen(imagetype) + 3, scrn$
        Get #1, p_colour(imagetype) + 3, col$
        Get #1, p_back(imagetype) + 3, bk$
    End Select
Close 1

bitposh = 0
bitposv = 0
dpos = 1
cpos = 1
bg = Asc(bk$)

DoEvents

tistart = Timer

Do While bitposv < 200 And abort = False

    pix = Asc(Mid$(bitmap$, dpos, 1))
    dpos = dpos + 1

    Select Case p_type(imagetype)
    Case HRBW
        For k2 = 0 To 7
            cbmpic.PSet (bitposh * 8 + 7 - k2, bitposv), IIf(pix And (2 ^ k2), CBMColor(0), CBMColor(1))
        Next k2
    Case HR
        s = Asc(Mid$(scrn$, cpos, 1))
        For k2 = 0 To 7
            cbmpic.PSet (bitposh * 8 + 7 - k2, bitposv), IIf(pix And (2 ^ k2), CBMColor((s And 240) / 16), CBMColor(s And 15))
        Next k2
    Case MC
        s = Asc(Mid$(scrn$, cpos, 1))
        c = Asc(Mid$(col$, cpos, 1))
        For k2 = 0 To 6 Step 2
            k3 = 2 ^ k2
            bit$ = IIf(pix And (k3 * 2), "1", "0")
            bit$ = bit$ + IIf(pix And k3, "1", "0")
            Select Case bit$
                Case "00": colput& = CBMColor(bg)
                Case "10": colput& = CBMColor(s And 15)
                Case "01": colput& = CBMColor((s And 240) / 16)
                Case "11": colput& = CBMColor(c And 15)
            End Select
            cbmpic.PSet (bitposh * 8 + 7 - k2, bitposv), colput&
            cbmpic.PSet (bitposh * 8 + 6 - k2, bitposv), colput&
        Next k2
    End Select

    bitposv = bitposv + 1
    If bitposv / 8 = bitposv \ 8 Then
        bitposh = bitposh + 1: bitposv = bitposv - 8
        cpos = cpos + 1
        DoEvents
        If bitposh > 39 Then
            bitposh = bitposh - 40: bitposv = bitposv + 8
            Call Percent(bitposv / 200 * 100!)
        End If
    End If
Loop

End Sub

Sub Form_Load ()
    Move 0, 0
    cbmpic.Move Width, 0
    GeoPic.Move Width, 0

    shapewidth = Shape1.Width
    
    Filename$ = App.Path
    If Right$(Filename$, 1) <> "\" Then Filename$ = Filename$ + "\"
    ChDrive Filename$
    ChDir Left$(Filename$, Len(Filename$) - 1)

    Call SetColor
    Call LoadConfig

    ' Set full size geopaint preview for suitable screens
    geosize = HALF
    ' Disabled at the moment due to doubling of processing
    ' time when larger preview is shown
'    If Screen.Width >= GeoPic.Width * 2 + Me.Width And Screen.Height > GeoPic.Width * 2 Then
'        geosize = FULL
'        GeoPic.Width = GeoPic.Width * 2
'        GeoPic.Height = GeoPic.Height * 2
'        GeoPic.Picture1.Move 0, 0
'        GeoPic.Picture1.Visible = True
'        GeoPic.Image1.Visible = False
'    End If

End Sub

Sub Form_Unload (Cancel As Integer)
    End
End Sub

Sub LoadConfig ()

Filename$ = App.Path
If Right$(Filename$, 1) <> "\" Then Filename$ = Filename$ + "\"

num = 0

Open Filename$ + "cbm2bmp.cfg" For Input As #1

Do Until num >= NUMB Or EOF(1) = True
    Line Input #1, a$
    If Left$(a$, 1) = Chr$(34) Then
        num = num + 1
        
        i = InStr(2, a$, Chr$(34))
        p_name(num) = Mid$(a$, 2, i - 2)
        
        i = InStr(a$, "$")
        a$ = Mid$(a$, i + 1)
        p_sa(num) = Val("&H" + Mid$(a$, 1, 4))
        a$ = Mid$(a$, 5)
        Do
            If Left$(a$, 1) <> " " Then Exit Do
            a$ = Mid$(a$, 2)
        Loop
        
        i = InStr(a$, " ")
        p_len(num) = Val(Left$(a$, i))
        a$ = Mid$(a$, i + 1)
        Do
            If Left$(a$, 1) <> " " Then Exit Do
            a$ = Mid$(a$, 2)
        Loop
        
        i = InStr(a$, " ")
        p_bitmap(num) = Val(Left$(a$, i))
        a$ = Mid$(a$, i + 1)
        Do
            If Left$(a$, 1) <> " " Then Exit Do
            a$ = Mid$(a$, 2)
        Loop
        
        i = InStr(a$, " ")
        p_screen(num) = Val(Left$(a$, i))
        a$ = Mid$(a$, i + 1)
        Do
            If Left$(a$, 1) <> " " Then Exit Do
            a$ = Mid$(a$, 2)
        Loop
        
        i = InStr(a$, " ")
        p_type(num) = MC
        If Left$(a$, 1) = "-" Then p_type(num) = HR
        p_colour(num) = Val(Left$(a$, i))
        a$ = Mid$(a$, i + 1)
        Do
            If Left$(a$, 1) <> " " Then Exit Do
            a$ = Mid$(a$, 2)
        Loop
        
        p_back(num) = Val(a$)
    End If
Loop

Close 1

p_name(0) = "Hi-Res B/W Image"
p_type(0) = HRBW

End Sub

Sub mnuFile_Click (Index As Integer)
    Select Case Index
    Case 1
        CMLoad.Filename = ""
        On Error Resume Next
        CMLoad.Action = 1
        If Err = CDERR_CANCEL Then Exit Sub
        On Error GoTo 0
        xinit$ = CurDir$
        xfile$ = CMLoad.Filetitle
        mnufile(1).Enabled = False
        mnufile(2).Enabled = False
        mnufile(4).Enabled = True
        Label4 = CMLoad.Filename
        picname$ = CMLoad.Filename
        Call CheckType
        Call Convert
    Case 2
        ChDrive xinit$
        ChDir xinit$
        f$ = xfile$
        x = InStr(f$, ".")
        If x > 0 Then f$ = Left$(f$, x - 1)
        f$ = f$ + ".bmp"
        CMSave.Filename = f$
        On Error Resume Next
        CMSave.Action = 2
        If Err = CDERR_CANCEL Then Exit Sub
        On Error GoTo 0
        f$ = CMSave.Filename
        Call SaveImage(f$)
    Case 4
        abort = True
        mnufile(4).Enabled = False
    Case 6
        Unload Me
    End Select
End Sub

Sub mnuHelp_Click (Index As Integer)
    MsgBox "Cbm 2 Bmp is FreeWare" + Chr$(13) + "Version 1.1 by Peter Weighill", 64, "About: Cbm 2 Bmp"
End Sub

Sub Percent (cent As Single)
    If cent > 100 Then cent = 100
    Label8 = Int(cent) & "%"
    Shape1.Width = shapewidth * (cent / 100)
    itot = Int((Timer - tistart) / cent * (100 - cent))
    imin = itot \ 60
    isec = itot - (imin * 60)
    Label10 = imin & " Min " & isec & " sec"
End Sub

Sub ReadBlock (buf$)

buf$ = Space$(254)
Get #1, , buf$

End Sub

Sub SaveImage (Filename$)
    Select Case imagetype
    Case GEO
        SavePicture GeoPic.Picture1.Image, Filename$
    Case Else
        SavePicture cbmpic.Image, Filename$
    End Select
End Sub

Sub SetColor ()
    CBMColor(0) = RGB(0, 0, 0)
    CBMColor(1) = RGB(255, 255, 255)
    CBMColor(2) = RGB(255, 0, 0)
    CBMColor(3) = RGB(0, 255, 255)
    CBMColor(4) = RGB(255, 0, 255)
    CBMColor(5) = RGB(0, 255, 0)
    CBMColor(6) = RGB(0, 0, 255)
    CBMColor(7) = RGB(255, 255, 0)
    CBMColor(8) = RGB(255, 102, 0)
    CBMColor(9) = RGB(170, 68, 0)
    CBMColor(10) = RGB(255, 119, 119)
    CBMColor(11) = RGB(85, 85, 85)
    CBMColor(12) = RGB(136, 136, 136)
    CBMColor(13) = RGB(153, 255, 153)
    CBMColor(14) = RGB(153, 153, 255)
    CBMColor(15) = RGB(187, 187, 187)
End Sub