8xi

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 mPictureID As String
Private mComment As String

Public Property Get LoadPicture(mFileName As String) _
    As StdPicture
    
    On Error Resume Next
    
    Dim mask As Integer
    Dim i As Integer, j As Integer
    Dim y As Integer, x As Integer
    
    Dim iDC As Long, iBitmap As Long
    Dim sPic As IPicture
    Dim lBitmap As PictDesc
    Dim IID_IDispatch As GUID
    Dim hBmpPrev As Long
        
    Dim mHandle As Long, sHeader As String * 8
    Dim mPicID As Byte
    Dim mSignature As String * 3
    Dim mDataSize As Integer
    Dim mSize As Integer
    Dim picArray(755) As Byte

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

    Get #mHandle, , mSignature  'Erweiterter Header
    mComment = Space(42)
    Get #mHandle, , mComment    'Kommentar
    Get #mHandle, , mDataSize   'Größe des Datenblockes
    
    Get #mHandle, 62, mPicID    'Nummer des Bildes
    
    'Bildnummer in Pic0-Pic9 umrechnen
    mPictureID = CStr(mPicID + 1)
    If Len(mPictureID) > 1 Then
        mPictureID = Right(mPictureID, 1)
    End If
    mPictureID = "Pic" & mPictureID

    Get #mHandle, 71, mSize
    Get #mHandle, , i
    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
            End If
            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 LoadPicture = sPic
    
End Property

Public Property Get ID() As String
    ID = mPictureID
End Property

Public Property Get Comment() As String
    Comment = StripNulls(mComment)
End Property

Private Function StripNulls(OriginalStr As String) As String
    If (InStr(OriginalStr, Chr(0)) > 0) Then
       OriginalStr = Left(OriginalStr, _
        InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function