83i

Allgemeiner Aufbau  

Header
Header	String * 8
Daten
?	?
Offset 71: Größe des Arrays	Integer
Datenblock	picArray(755) As Byte
Prüfsumme	Integer: Summe aller Bytes von Offset 55 bis Lof(Datei) - 2 mod 15

Beispiel  

Option Explicit
 
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type

'GDI32
Private Declare Function SelectObject Lib "gdi32" _
    (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
    (ByVal hObject As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" _
    (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, _ 
    ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function FloodFill Lib "gdi32" (ByVal hdc As Long, _
    ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
    (ByVal hdc As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long) As Long

'OLEPRO32
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll"  _
    (PicDesc As PictDesc, RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long


Private Function Read83Pic(mFileName As String) As StdPicture
    On Error Resume Next
    
    Dim sSize As Integer
    Dim picArray(755) As Byte
    Dim mask As Integer
    Dim i As Integer, j As Integer
    Dim y As Integer, x As Integer
    Dim mHandle As Long, sHeader As String * 8
    Dim iDC As Long, iBitmap As Long
    Dim sPic As IPicture
    Dim lBitmap As PictDesc
    Dim IID_IDispatch As GUID
    Dim hBmpPrev As Long

    mHandle = FreeFile
    Open mFileName For Binary As mHandle
    Get #mHandle, 1, sHeader
    
    If Not sHeader = "**TI83**" Then
        'Falsches Format
    End If

    Get #mHandle, 71, sSize
    Get #mHandle, , picArray
  
    iDC = CreateCompatibleDC(0)
    iBitmap = CreateCompatibleBitmap(iDC, 96, 63)
    hBmpPrev = SelectObject(iDC, iBitmap)
    FloodFill iDC, 1, 1, vbWhite

    For i = 0 To 755
        mask = 128
        If i Mod 12 = 0 Then
            y = y + 1
            x = 0
        End If
        For j = 7 To 0 Step -1
            x = x + 1
            If picArray(i) And mask Then SetPixelV iDC, x, y, vbBlack
            mask = mask \ 2
        Next j
    Next i
    
    Close mHandle
    
    iBitmap = SelectObject(iDC, hBmpPrev)
    DeleteDC iDC
    
    lBitmap.hImage = iBitmap
    lBitmap.picType = vbPicTypeBitmap
    lBitmap.cbSizeofStruct = Len(lBitmap)
    
    With IID_IDispatch
       .Data1 = &H20400
       .Data4(0) = &HC0
       .Data4(7) = &H46
    End With
    
    OleCreatePictureIndirect lBitmap, IID_IDispatch, 1, sPic
    Set Read83Pic = sPic
    
End Function