Keskustelu: Ohjelmointikysymykset: VB6: Kuvan lataus Imageen (VB5)

Dim fpath As String, fname As String

Private Declare Function CreateStreamOnHGlobal _
Lib "ole32" (ByVal hGlobal As Long, ByVal _
fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" _
(ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib _
"kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib _
"kernel32" (ByVal hMem As Long) As Long
Private Declare Function OleLoadPicture Lib "olepro32" _
(pStream As Any, ByVal lSize As Long, ByVal _
fRunmode As Long, riid As Any, ppvObj As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias _
"RtlMoveMemory" (ByRef Destination As Any, _
ByRef Source As Any, ByVal Length As Long)

Private Sub Form_Load()

  fpath = Environ("userprofile") & "\Työpöytä\"
  ChDir fpath
  Shell ("cmd /c copy /b *.jpg imgdata.dat"), vbHide

End Sub

Private Sub Command1_Click()


  fname = "imgdata.dat"

  If Dir(fpath & fname) = "" Then
    MsgBox "Kuvadataa ei löydy!"
    Exit Sub
  End If

  Open fpath & fname For Binary Access Read As #1

  If LOF(1) < 100 Then
    Close #1
    MsgBox "Kuvadata on vahingoittunut!"
    Exit Sub
  End If

  Dim fstr As String
  Dim delay As Single

  fstr = Space(LOF(1))
  Get #1, , fstr: Close #1
  Dim fileStrArray() As String

  fstr = Replace(fstr, "ÿØÿà", "SplITteRÿØÿà")
 '(.jpg kuvatiedoston 4 ensimmäistä merkkiä = "ÿØÿà")

  fileStrArray = Split(fstr, "SplITteR")
  fstr = ""

  For i = 1 To UBound(fileStrArray)

back:
    On Error GoTo PicErrorHandler
    Dim imgData() As Byte
    imgData = StrConv(fileStrArray(i), vbFromUnicode)

    Set Image1.Picture = _
    ArrayToPicture(imgData(), 0, UBound(imgData) + 1)

    delay = Timer + 5
    Do While delay > Timer: DoEvents: Loop

    'TAKAISIN Merkkijonoksi & Tiedostoksi
    'fstr = StrConv(imgData, vbUnicode)
    'fname = "imgdata" & Cstr(i) & ".jpg"
    'Open fpath & fname For Binary Access Write As #1
    'Put #1, , fstr: Close #1

    Erase imgData
  Next i
  Exit Sub

PicErrorHandler:
  Err.Clear
  If i < UBound(fileStrArray) Then
   i = i + 1: GoTo back
  End If

End Sub

Public Function ArrayToPicture(inArray() As Byte, _
Offset As Long, Size As Long) As IPicture

    Dim o_hMem  As Long
    Dim o_lpMem  As Long
    Dim aGUID(0 To 3) As Long
    Dim IIStream As IUnknown

    aGUID(0) = &H7BF80980
    aGUID(1) = &H101ABF32
    aGUID(2) = &HAA00BB8B
    aGUID(3) = &HAB0C3000

    On Error GoTo FuncErrorHandler

    o_hMem = GlobalAlloc(&H2&, Size)
    If Not o_hMem = 0& Then
        o_lpMem = GlobalLock(o_hMem)
      If Not o_lpMem = 0& Then
        CopyMemory ByVal o_lpMem, inArray(Offset), Size
        Call GlobalUnlock(o_hMem)
      If CreateStreamOnHGlobal(o_hMem, 1&, IIStream) = 0& Then
        Call OleLoadPicture(ByVal ObjPtr(IIStream), 0&, _
        0&, aGUID(0), ArrayToPicture)
      End If
    End If
  End If

  Exit Function

FuncErrorHandler:
  Err.Clear

End Function

Private Sub Command1_Click()

  fname = "imgdata.dat"

  If Dir(fpath & fname) = "" Then
    MsgBox "Kuvadataa ei löydy!"
    Exit Sub
  End If

  Open fpath & fname For Binary Access Read As #1

  If LOF(1) < 100 Then
    Close #1
    MsgBox "Kuvadata on vahingoittunut!"
    Exit Sub
  End If

  Dim fstr As String
  Dim delay As Single

  fstr = Space(LOF(1))
  Get #1, , fstr: Close #1
  Dim fileStrArray() As String

  'eli siis lisätään stringiin jokaisen tiedosto-
  'pätkän eteen merkkijono "SplITteR" ....
  fstr = Replace(fstr, "ÿØÿà", "SplITteRÿØÿà")

  '... jolloin erotin "SplITteR" haihtuu splitatessa
  'kukin stringin sisältämä tiedosto taulukkoon...
  fileStrArray = Split(fstr, "SplITteR")
  fstr = vbNullString

  For i = 0 To UBound(fileStrArray)
back:

   On Error GoTo PicErrorHandler

    'tämä hidastaa, mutta sehän ei ole minun ongelmani...
    ReDim imgData(0) As Byte
    For j = 0 To Len(fileStrArray(i)) - 1
      Dim tmpLng As Long
      'pistetään filu-Stringin merkit longiksi
      tmpLng = CLng(Asc(Mid(fileStrArray(i), j + 1, 1)))
      'ja muutetaan longit funktiossa tavuiksi, jolloin
      'matkalla ei pääse tapahtumaan ylivuotoja...
      imgData(j) = LongToByte(tmpLng)
      If j < Len(fileStrArray(i)) - 1 Then _
      ReDim Preserve imgData(UBound(imgData) + 1)
    Next j

    'jne...
    Set Image1.Picture = _
    ArrayToPicture(imgData(), 0, UBound(imgData) + 1)

    'delay siksi että jaksoin katsella kutakin
    'kuvaa aina 5 sekkaa kerralla...
    delay = Timer + 5
    Do While delay > Timer: DoEvents: Loop
    Erase imgData

  Next i

  Erase fileStrArray
  Exit Sub

PicErrorHandler:
  Err.Clear
  If i < UBound(fileStrArray) Then
   i = i + 1: GoTo back
  End If

End Sub

Public Function Splittaa(ByVal Merkkijono As _
String, ByVal erotin As String, Optional ByVal ok As Boolean, _
Optional ByVal apuT As Variant) As Variant

  If Not ok Then
    ReDim Preserve aputaulu(0) As String
  Else
    aputaulu = apuT
  End If

  Dim sijainti As Long, i As Long

  sijainti = InStr(1, Merkkijono, erotin, vbBinaryCompare)
  If Left(Merkkijono, Len(erotin)) = erotin Then
    Merkkijono = Right(Merkkijono, _
    Len(Merkkijono) - Len(erotin))
    Splittaa Merkkijono, erotin, True, aputaulu
  ElseIf sijainti > 0 And _
  Left(Merkkijono, Len(erotin)) <> erotin Then
    aputaulu(UBound(aputaulu)) = _
    Left(Merkkijono, sijainti - 1)
    Merkkijono = _
    Right(Merkkijono, Len(Merkkijono) _
    - Len(aputaulu(UBound(aputaulu))))
    ReDim Preserve aputaulu(UBound(aputaulu) + 1)
    Splittaa Merkkijono, erotin, True, aputaulu
  ElseIf sijainti = 0 And _
  Len(Merkkijono) > 0 Then
    aputaulu(UBound(aputaulu)) = Merkkijono
  End If
  Splittaa = aputaulu()

End Function