frmconvertbmp2hex.frm

Convert BMP files into hex data

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmConvertBmp2Hex 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Bitmap To Hex"
   ClientHeight    =   2115
   ClientLeft      =   2250
   ClientTop       =   2040
   ClientWidth     =   4815
   Icon            =   "frmConvertBmp2Hex.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2115
   ScaleWidth      =   4815
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Begin VB.Frame Frame2 
      Height          =   1935
      Left            =   3000
      TabIndex        =   7
      Top             =   60
      Width           =   1695
      Begin VB.CommandButton cmdCOMMAND 
         Caption         =   "&Convert"
         Enabled         =   0   'False
         Height          =   435
         Index           =   2
         Left            =   180
         TabIndex        =   10
         Top             =   720
         Width           =   1335
      End
      Begin VB.CommandButton cmdCOMMAND 
         Caption         =   "&Open File"
         Height          =   435
         Index           =   1
         Left            =   180
         TabIndex        =   9
         Top             =   240
         Width           =   1335
      End
      Begin VB.CommandButton cmdCOMMAND 
         Caption         =   "E&xit"
         Height          =   435
         Index           =   0
         Left            =   180
         TabIndex        =   8
         Top             =   1380
         Width           =   1335
      End
   End
   Begin VB.Frame Frame1 
      Height          =   1935
      Left            =   120
      TabIndex        =   5
      Top             =   60
      Width           =   2775
      Begin MSComDlg.CommonDialog dlgFILE 
         Left            =   2160
         Top             =   1200
         _ExtentX        =   847
         _ExtentY        =   847
         _Version        =   393216
         CancelError     =   -1  'True
         DefaultExt      =   "*.bmp"
         DialogTitle     =   "Open BMP File"
         FileName        =   "*.bmp"
      End
      Begin VB.PictureBox picSmall 
         Appearance      =   0  'Flat
         BackColor       =   &H80000005&
         DrawStyle       =   2  'Dot
         DrawWidth       =   2
         ForeColor       =   &H80000008&
         Height          =   510
         Left            =   1980
         OLEDragMode     =   1  'Automatic
         OLEDropMode     =   2  'Automatic
         ScaleHeight     =   42.057
         ScaleMode       =   0  'User
         ScaleWidth      =   38
         TabIndex        =   6
         Top             =   240
         Width           =   615
      End
      Begin VB.Image picBigger 
         Appearance      =   0  'Flat
         BorderStyle     =   1  'Fixed Single
         Height          =   1515
         Left            =   180
         Stretch         =   -1  'True
         Top             =   240
         Width           =   1695
      End
   End
   Begin VB.CommandButton Command11 
      Caption         =   "Command11"
      Enabled         =   0   'False
      Height          =   435
      Left            =   6120
      TabIndex        =   4
      Top             =   1320
      Width           =   1035
   End
   Begin VB.CommandButton Command10 
      Caption         =   "Command10"
      Enabled         =   0   'False
      Height          =   435
      Left            =   6120
      TabIndex        =   3
      Top             =   780
      Width           =   1035
   End
   Begin VB.CommandButton Command9 
      Caption         =   "Command9"
      Enabled         =   0   'False
      Height          =   435
      Left            =   6120
      TabIndex        =   2
      Top             =   240
      Width           =   1035
   End
   Begin VB.ListBox lstBinary 
      Height          =   3570
      Left            =   4320
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   2340
      Width           =   4155
   End
   Begin VB.ListBox lstHex 
      Height          =   3570
      Left            =   60
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   2340
      Width           =   4155
   End
End
Attribute VB_Name = "frmConvertBmp2Hex"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim Reply$, Send$
Dim intCounter As Integer
Dim sBitmap$(112)

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Function Asc2Bin(intValue As Integer) As String
    Dim i As Integer
    Dim nPangkat As Integer
    Dim nReminder As Integer
    Dim sBinary$
    
    nReminder = intValue
    sBinary$ = ""
    
    If nReminder > 255 Then
        nPangkat = 15
    Else
        nPangkat = 7
    End If
    
    For i = nPangkat To 1 Step -1
        If nReminder >= (2 ^ i) Then
            nReminder = nReminder - (2 ^ i)
            sBinary$ = sBinary$ & "1"
        Else
            sBinary$ = sBinary$ & "0"
        End If
    Next
    
    sBinary$ = sBinary$ & Trim$(Str$(nReminder))
    
    Asc2Bin = sBinary$
End Function

Function Bin2Asc(strStr As String) As Integer
    Dim i As Integer
    Dim nLen As Integer
    
    Bin2Asc = 0
    
    nLen = Len(strStr)
    If nLen > 0 Then
        For i = nLen To 1 Step -1
            Bin2Asc = Bin2Asc + ((2 ^ (i - 1)) * (Val(Mid$(strStr, nLen + 1 - i, 1))))
        Next
    End If
End Function

Function Hex2Asc(strStr As String) As Integer
    Dim i As Integer
    Dim nValue As Integer
    
    Hex2Asc = 0
    
    For i = Len(strStr) To 1 Step -1
        If Mid(strStr, i, 1) = "A" Or Mid(strStr, i, 1) = "a" Then
            nValue = 10
        ElseIf Mid(strStr, i, 1) = "B" Or Mid(strStr, i, 1) = "b" Then
            nValue = 11
        ElseIf Mid(strStr, i, 1) = "C" Or Mid(strStr, i, 1) = "c" Then
            nValue = 12
        ElseIf Mid(strStr, i, 1) = "D" Or Mid(strStr, i, 1) = "d" Then
            nValue = 13
        ElseIf Mid(strStr, i, 1) = "E" Or Mid(strStr, i, 1) = "e" Then
            nValue = 14
        ElseIf Mid(strStr, i, 1) = "F" Or Mid(strStr, i, 1) = "f" Then
            nValue = 15
        Else
            nValue = Val(Mid(strStr, i, 1))
        End If
        
        Hex2Asc = Hex2Asc + ((16 ^ (i - 1)) * nValue)
    Next
    
End Function

Private Sub CreateBinary()
    Dim i As Integer
    Dim j As Integer
    
    lstBinary.Clear
    For i = 0 To 31         'picSmall.ScaleHeight - 1
        For j = 0 To 37     'picSmall.ScaleWidth
            If (GetPixel(picSmall.hdc, j, i)) = 0 Then
                sBitmap$(i) = sBitmap$(i) & "1"
            Else
                sBitmap$(i) = sBitmap$(i) & "0"
            End If
        Next
        
        lstBinary.AddItem Left$(sBitmap$(i), 38)
    Next
End Sub

Private Sub CreateHexFile()
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim l As Integer
    Dim q As Integer
    Dim strBin$(160)
    Dim strTemp$
    Dim strHex$
    
    If lstBinary.ListCount <> 32 Then
        MsgBox "Invalid Picture"
        Exit Sub
    End If
    
    k = 0
    l = 0
    
    For i = 0 To 152
        strBin$(i) = ""
    Next
    
    For i = 0 To lstBinary.ListCount - 1 Step 8
        For j = 0 To 7
            For q = 0 To 37
                strBin$(q + k) = Mid$(lstBinary.List(j + l), q + 1, 1) + strBin$(q + k)
            Next
        Next
        k = k + 38
        l = l + 8
    Next
    
    On Error Resume Next
    Kill App.Path & "\OwnLogo.hex"
    On Error GoTo 0
    
    Open App.Path & "\HexLogo.txt" For Output As #1
    Open App.Path & "\OwnLogo.hex" For Binary Access Write As #2 Len = 38
    
    lstHex.Clear
    j = 0
    strTemp$ = ""
    For i = 0 To 152
        If strBin$(i) <> "" Then
            k = Bin2Asc(strBin$(i))
            lstHex.AddItem strBin$(i) & " / " & k & " / 0x" & Right$("00" & Hex(k), 2)
            
            strTemp$ = strTemp$ & "0x" & Right$("00" & Hex(k), 2)
            strHex$ = strHex$ & Chr$(k)
            j = j + 1
            If j < 38 Then
                strTemp$ = strTemp$ & ","
            Else
                Print #1, strTemp$
                Put #2, , strHex$
                j = 0
                strTemp$ = ""
                strHex$ = ""
            End If
        End If
    Next
    
    Close #2
    Close #1
    
    MsgBox "Convert Bitmap to Hex File was successful !", vbOKOnly + vbInformation, "Success"
End Sub

Private Sub cmdCOMMAND_Click(Index As Integer)
    Select Case Index
        Case 0      'End
            Unload Me
        Case 1      'Open File
            cmdCOMMAND(2).Enabled = False
            Call OpenBmpFile
        Case 2      'Process
            Me.MousePointer = 11
            Call CreateBinary
            Call CreateHexFile
            Me.MousePointer = 0
    End Select
End Sub

Private Sub OpenBmpFile()
    Dim strFileBmp$
    
    picSmall.Picture = LoadPicture("")
    picSmall.Refresh
    
    picBigger.Picture = LoadPicture("")
    picBigger.Refresh
    
    strFileBmp$ = ""
    
    On Error GoTo Exit_Sub
    dlgFILE.InitDir = CurDir$
    dlgFILE.ShowOpen
    
    strFileBmp$ = dlgFILE.FileName
    
    picSmall.Picture = LoadPicture(strFileBmp$)
    picSmall.Refresh
    
    picBigger.Picture = LoadPicture(strFileBmp$)
    picBigger.Refresh
    
    cmdCOMMAND(2).Enabled = True
    
Exit_Sub:
End Sub