Kirjautuminen

Haku

Tehtävät

Keskustelu: Ohjelmointikysymykset: Kuvan lähetys toiselle tietokoneelle (VB6) (VBA)

Sivun loppuun

JoreSoft [29.10.2008 14:57:08]

#

Eli ongelma on tällä kertaa se, että olen tehnyt kaksi ohjelmaa, jotka olisi tarkoitus liittää toisiinsa.

Olen käyttänyt winsock-kontrollia yhteyden saamiseen ohjelmien välille.
Chat onnistuu winshock:lla.

Olisinkin kysynyt kuinka lähetän bitmap-kuvan toiselle ohjelmalle, esim koti-netin yli? GetData ei tunne bittikartta tyyppiä.
Ilmeisesti kuva pitäisi muuttaa, johonkin muotoon.. ?? (Taulukkoon? 'vbArray + vbByte')

GetData tuntee nää muodot.. esim.. sock1.GetData dat, vbString

The settings for type are:
Description Constant
Byte | vbByte
Integer | vbInteger
Long | vbLong
Single | vbSingle
Double | vbDouble
Currency | vbCurrency
Date | vbDate
Boolean | vbBoolean
Scode | vbError
String | vbString
Byte Array | vbArray + vbByte

Nettinerot, alkakaahan neuvoa aloittelijaa ;)

neau33 [29.10.2008 16:47:45]

#

Moikka JoreSoft!


Byte Array on se oikea...tsekkaa täältä funktio ArrayToPicture

JoreSoft [29.10.2008 18:50:49]

#

Onnistuuko jollakin apilla muuttaa olemassa oleva picturebox arrayksi lähetystä varten, vai pitääkö se ensin tallettaa levylle ja lukea takas?
Eli voiko ton talletus/latauksen jättää välistä pois?

eli tarkoitan tätä...

Public Sub PictureToArray(Pic As IPicture, Arr() As Byte)
Dim F%, Filename$, Apu() As Byte

    On Error GoTo Virhe
    Filename = App.Path & "\Temp.bmp"
    SavePicture Pic, Filename                   'Talletetaan kuva
    F = FreeFile
    Open Filename For Binary Access Read As #F  'Luetaan kuva taulukkoon
        Get #F, , Apu
    Close #F
    Arr = Apu                                   'Palautetaan se
    Exit Sub
Virhe:
    MsgBox Error$(Err)
    Close #F
End Sub

JoreSoft [29.10.2008 20:39:50]

#

Kiitos NEA, oli noista jotain hyötyä.. =)

Oletkos käyttänyt WinSock-kontrollia?

Private Sub sock1_DataArrival(ByVal bytesTotal As Long)
Dim Arr() As Byte
    If Working Then Exit Sub
    ReDim Arr(bytesTotal) As Byte   '<== Tarvitaanko?
    sock1.GetData Arr, vbArray + vbByte, bytesTotal
    Tied.ChangeArrayToPicture Arr
    frmLog.Log = frmLog.Log & "Receiving picture data..." & vbCrLf
End Sub

Kun vastaanotetaan kuva taulukkoa, alkaa toi DataArrival kiertää silmukassa..
Tuleeko data joissakin paloissa, joista se sitten pitäisi kasata?
Tulevan datan koko "bytesTotal" 1. kierroksella on 4380 tavua.
2. 8192, jne..
Taaskaan ei googlella löytynyt mitään järkevää...

neau33 [30.10.2008 01:03:44]

#

Heippa taas JoreSoft!

tässä suurinpiirtein kaikki mitä tarvitset "kuvankäsittelyyn"...

'Paitsi: Imppaa täältä .zip paketti ja asentele ohjeen mukaan...

' Tuo projektiin referenssi:
' Neobase OLE interfaces & functions v1.81
' (C:\Windows\System32\olelib.tlb)

' Testaus:
' Formille Image-kontrolli, pari nappia, luo
' ..\Omat tiedostot\Omat kuvatiedostot\picture1.bmp
' tiedosto ja painelle nappeja 1 & 2

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 GetHGlobalFromStream Lib "ole32" _
(ByVal pstm As IStream, phglobal As Long) As Long

Private Declare Sub MoveMemory Lib "kernel32" Alias _
"RtlMoveMemory" (Dest As Any, src As Any, ByVal cb As Long)

Private Declare Function GlobalSize Lib "kernel32" _
(ByVal hMem 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)

Const PictureID = &H746C&
Const S_OK = 0

Private Type PictureHeader
   Magic As Long
   Size As Long
End Type

Dim ImageData() As Byte
Dim BasePath As String
Dim FileName As String
Dim FullPath As String

Private Sub Command1_Click()

  FileName = "picture1.bmp"
  FromFileToByteArray
  FileName = "picture2.bmp"
  FromByteArrayToFile
  FromByteArrayToImageControl Image1

End Sub

Private Sub Command2_Click()

  If Not Image1.Picture Is Nothing Then
    If ArrayExists(ImageData) Then Erase ImageData
    FromImageControlToByteArray Image1.Picture
    FileName = "picture3.bmp"
    FromByteArrayToFile
  End If

End Sub

Sub FromFileToByteArray()

  BasePath = Environ("userprofile") & _
  "\Omat tiedostot\Omat kuvatiedostot\"

  FullPath = BasePath & FileName

  If Dir(FullPath) <> "" Then

    Open FullPath For Binary As #1
    ReDim ImageData(1 To LOF(1)) As Byte
    Seek #1, 1
    Get #1, , ImageData: Close #1

  End If

End Sub

Sub FromByteArrayToFile()

  If Not ArrayExists(ImageData) Then Exit Sub
  FullPath = BasePath & FileName
  If Dir(FullPath) <> "" Then
    Kill FullPath
  End If
  Open FullPath For Binary As #1
  Put #1, , ImageData: Close #1


End Sub

Sub FromByteArrayToImageControl(ByVal ImgCtl As Control)

  If Not ArrayExists(ImageData) Then Exit Sub
  Set ImgCtl.Picture = _
  ArrayToPicture(ImageData(), 1, UBound(ImageData))

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

Public Sub FromImageControlToByteArray( _
ByVal oObj As StdPicture)

  Dim oIPS As IPersistStream
  Dim oStream As IStream, hGlobal As Long, lPtr As Long
  Dim lSize As Long, Hdr As PictureHeader
  Dim lRes As Long
  Set oIPS = oObj
  lRes = CreateStreamOnHGlobal(0, True, oStream)
  If lRes = S_OK Then
    oIPS.Save oStream, True
    If GetHGlobalFromStream(oStream, hGlobal) = S_OK Then
      lSize = GlobalSize(hGlobal)
      lPtr = GlobalLock(hGlobal)
        If lPtr Then
          lSize = lSize - Len(Hdr)
          ReDim ImageData(1 To lSize)
          MoveMemory ImageData(1), ByVal lPtr + Len(Hdr), lSize
        End If
        GlobalUnlock hGlobal
      End If
    Set oStream = Nothing
  End If

End Sub

Public Function ArrayExists(Bytes() As Byte) As Boolean

  Dim lb As Long
  On Error Resume Next

  lb = LBound(Bytes())

  If Err <> 0 Then
    Err.Clear: On Error GoTo 0
    ArrayExists = False: Exit Function
  End If
  ArrayExists = True

End Function

Olettaisin, että Byte Array:ta lähetettäessä kanattaa liittää pakettiin tieto taulukon koosta ja tsekata vastaanottaessa, että kaikki kama on perillä ennen, kuin purku alkaa...

' jotenkin tuntuisi, että jos array pitää kasata uusiksi niin...
  ReDim Preserve Arr(bytesTotal) As Byte

JoreSoft [30.10.2008 02:26:59]

#

Eli helpommalla pääsee kun lähettää tavun kerrallaan ja vastaanottopää kuittaa, kunnes tulee esim "Stop" viesti... =)
Kiitos kuitenkin vaivannäöstä

neau33 [30.10.2008 11:15:34]

#

Heippa taas JoreSoft!

toimivuutta ei ole testattu, mutta jos ja kun lähetys kerran saapuu osissa niin...

Dim ByteArray() As Byte

Private Sub sock1_DataArrival(ByVal bytesTotal As Long)

    If Working Then Exit Sub

    Static bytesAlreadyArrived As Long
    On Error Resume Next

    bytesAlreadyArrived = Ubound(ByteArray)

    If Err <> 0 Then
      Err.Clear: On Error GoTo 0
      bytesAlreadyArrived = 0
    End If

    If bytesTotal > bytesAlreadyArrived Then
      ReDim Preserve ByteArray(1 To bytesTotal) As Byte
      sock1.GetData ByteArray(bytesAlreadyArrived + 1 To Ubound( _
      ByteArray)), vbArray + vbByte, bytesTotal - bytesAlreadyArrived
    End If

End Sub

JoreSoft [30.10.2008 15:07:07]

#

Hei NEA :)
bytesTotal Ilmoittaa vaan tulossa olevan paketin koon, joten lause
If bytesTotal > bytesAlreadyArrived Then
ei tietenkään voi toimia, kuin ekan paketin kohdalla =)

Mutta tarinalla on onnellinen loppu, joten jaetaan se tässä, vaikka ei ohjelmointivinkki paikka olekkaan =)

Ensin server ohjelma
Moduulissa:

Global Arr() As Byte

Luokassa Tiedostot

Public Sub PictureToArray()
Dim F%, Filename$, Apu() As Byte, I As Long

    On Error GoTo Virhe
    Erase Arr                               'Tyhjennetään taulukko
    Filename = App.Path & "\Temp.bmp"
    SavePicture PL.P1.Image, Filename       'Talletetaan kuva
    F = FreeFile
    Open Filename For Binary As #F          'Luetaan kuva taulukkoon
        ReDim Apu(0 To LOF(1)) As Byte
        Seek #F, 1
        Get #F, , Apu
    Close #F
    Kill Filename '' poistetaan turha väliaikainen tiedosto
    If IsNull(Apu) Then
        MsgBox "Tyhjä taulukko!"
        Stop
    End If
    ReDim Arr(UBound(Apu)) As Byte
    For I = 0 To UBound(Apu)
        Arr(I) = Apu(I)                                'Siirretään se
    Next I
    Exit Sub
Virhe:
    MsgBox Error$(Err)
    Close #F
End Sub

Formilla PL

Dim UploadStarted As Boolean

Public Sub Send()
    On Error GoTo T
    Erase Arr
    Tied.PictureToArray 'Muutetaan lähetettävä kuva taulukoksi
    sock1.SendData "Start" & Str(UBound(Arr))
    UploadStarted = True
    frmLog.Log = frmLog.Log & "Waiting ..." & vbCrLf
Exit Sub
T:
    frmLog.Log = frmLog.Log & "Error : " & Err.Description & vbCrLf
    sock1_Close   'close the connection
End Sub

Public Sub sock1_Close()
    sock1.Close  'close connection
    UploadStarted = False
    frmLog.Log = frmLog.Log & " *** Disconnected" & vbCrLf
    Kuuntele
End Sub

Private Sub sock1_ConnectionRequest(ByVal requestID As Long)
    If sock1.State <> sckClosed Then sock1.Close
    sock1.Accept requestID
    frmLog.Log = "Client Connected. IP : " & sock1.RemoteHostIP & vbCrLf
    UploadStarted = False
End Sub

Private Sub sock1_DataArrival(ByVal bytesTotal As Long)
    Dim dat As String     'where to put the data
    sock1.GetData dat, vbString   'writes the new data in our string dat ( string format )
    If UploadStarted Then
        If dat = "OK Send" Then
            sock1.SendData Arr
            frmLog.Log = frmLog.Log & "Sending picture..." & vbCrLf
            frmLog.Log = frmLog.Log & "Send compete" & vbCrLf
        End If
    Else
        frmLog.Log = frmLog.Log & "Client : " & dat & vbCrLf
    End If
End Sub

Public Sub Kuuntele()
On Error GoTo T
With PL.sock1
    .Close
    .LocalPort = 123
    .Listen                'Start Listening
End With
    frmLog.Log = frmLog.Log & "Server : Listening...." & vbCrLf
Exit Sub
T:
    frmLog.Log = frmLog.Log & "Error : " & Err.Description & vbCrLf
End Sub

Private Sub sock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    frmLog.Log = frmLog.Log & " *** Error : " & Description & vbCrLf
    sock1_Close
    UploadStarted = False
End Sub

Ja Client eli kuvan vastaanottopää...

Moduulissa:

Global Arr() As Byte 'Globaali, koska käytetään myös luokissa

Luokassa Tiedostot

Public Sub ArrayToPicture()
Dim F%, Filename$
    On Error GoTo Virhe
    Filename = App.Path & "\Temp.bmp"
    F = FreeFile
    Open Filename For Binary As #F      'Talletetaan kuva-taulukko
        Put #F, , Arr
    Close #F
        pBu.pLoadPic.Picture = LoadPicture(Filename)    'Palautetaan se
    Exit Sub
    Kill Filename '' poistetaan turha väliaikainen tiedosto
Virhe:
    MsgBox Error$(Err)
    Close #F
End Sub

Form PL

Dim Tavuja As Long, DowloadStarted As Boolean, AllData As Long
Public Sub sock1_Close()
    sock1.Close  'close connection
    DownloadStarted = False
    frmLog.Log = frmLog.Log & "*** Disconnected" & vbCrLf
End Sub

Private Sub sock1_Connect()
    Erase Arr() 'Tyhjennetään taulukko
    Tavuja = 0
    frmLog.Log = frmLog.Log & "Client : " & "Connected to " & sock1.RemoteHostIP & vbCrLf
    DownloadStarted = False
End Sub

Private Sub sock1_DataArrival(ByVal bytesTotal As Long)
Dim I%, dat$, T$
    If Working Then Exit Sub    'Ei oteta kuvaa vastaan, jos edellistä työstetään
    If DownloadStarted Then
        'Vastaanotetaan kuva
        ReDim Preserve Arr(Tavuja + bytesTotal) As Byte 'lisätään taulukon kokoa
        sock1.GetData T, vbString, bytesTotal 'Vastaanotetaan merkkijonona
        For I = 0 To bytesTotal - 1 'Siirretään vastaanotettu paketti
            Arr(Tavuja + I) = Asc(Mid$(T, I + 1, 1))
        Next I
        Tavuja = Tavuja + bytesTotal   'Lisätään määrää, ja siirretään yhdellä eteenpäin
        frmLog.Log = frmLog.Log & "Server has send :" & Str(Tavuja) & vbCrLf
        If Tavuja >= AllData Then
            Tied.ArrayToPicture
            Erase Arr() 'Tyhjennetään taulukko
            DownloadStarted = False
            frmLog.Log = frmLog.Log & "Done. Server has send " & Str(Tavuja) & " packets:" & vbCrLf
            Tavuja = 0
        End If
    Else
        'Norm chat
        sock1.GetData dat, vbString, bytesTotal
        frmLog.Log = frmLog.Log & "Server : " & dat & vbCrLf
        If Left$(dat, 5) = "Start" Then
            frmLog.Log = "Server : " & dat & vbCrLf
            AllData = Val(Mid$(dat, 6))
            DownloadStarted = True
            Erase Arr
            sock1.SendData "OK Send"    'Annetaan lupa lähettää kuvapaketit
        End If
    End If
End Sub

Private Sub sock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    frmLog.Log = frmLog.Log & "*** Error : " & Description & vbCrLf
    sock1_Close
End Sub

Kiitos Nealle ja muille avusta tämän ongelman selvittämisessä =)

Alkuperäisen koodin on tehnyt
"Winsock example by VirusFree - http://www.phoenixbit.com"
http://www.phoenixbit.com/site/tutorials.asp?view=UHJvZ3JhbW1pbmcvVmlzdWFsIEJhc2ljL3dpbnNvY2sx

JoreSoft [30.10.2008 20:04:57]

#

Luokassa Tiedostot
Yksi Exit sub, oli unehtunut koodista eikä voinut enää editoida

Tiedostot Luokka

Public Sub ArrayToPicture()
Dim F%, Filename$
    On Error GoTo Virhe
    Filename = App.Path & "\Temp.bmp"
    F = FreeFile
    Open Filename For Binary As #F      'Talletetaan kuva-taulukko
        Put #F, , Arr
    Close #F
        pBu.pLoadPic.Picture = LoadPicture(Filename)    'Palautetaan se
    Exit Sub
    Kill Filename '' poistetaan turha väliaikainen tiedosto
    Exit sub '<<== tämä oli jäänyt pois ;)
Virhe:
    MsgBox Error$(Err)
    Close #F
End Sub

neau33 [30.10.2008 20:39:17]

#

Heippa taas JoreSoft!

Miksi päädyit Client-puolella tallentamaan kuvan ensin väliaikaiseen tiedostoon?

JoreSoft [31.10.2008 18:56:20]

#

Hei NEA
En saanut kuvaa aikaiseksi taulukosta sillä sun koodilla...
Tuossahan kuva tulee merkkijonoina, joka siirretään yhteen taulukkoon.
siksi oli helpompaa tallettaa se taulukko, ja lukea takas kuvana normaaliin tapaan. Kuin käyttää jotain mystistä api-kutsu juttuja, joista ei saa mitään tolkkua.. =)

neau33 [31.10.2008 23:15:20]

#

Heippa taas JoreSoft!

asiathan vain yksinkertaistuvat...eli viilaa näistä...

' *** Client-puolen API-kama
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)
' ***

Sub Lähetä()

  Dim FullPath As String

  FullPath = Environ("userprofile") & _
  "\Omat tiedostot\Omat kuvatiedostot\picture1.bmp"
  Open FullPath For Binary As #1
  Dim ImageStr As String

  ImageStr = Space(LOF(1))
  Get #1, , FileStr: Close #1

  Vastaanota(ImageStr)

End Sub

'Client-kamaa...
Sub Vastaanota(ByVal ImageStr As String)

  Dim ImageData() As Byte
  ImageData = StrConv(ImageStr, vbFromUnicode)

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

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

neau33 [01.11.2008 00:33:22]

#

Moikka taas JoreSoft!

pikku copy/paste moka eli

'Get #1, , FileStr: Close #1
Get #1, , ImageStr: Close #1

JoreSoft [01.11.2008 18:54:06]

#

Kiitos NEA, sain toimiin sen noinkin =)

Private Sub sock1_DataArrival(ByVal bytesTotal As Long)
Dim I%, dat$, T$
    If Working Then Exit Sub    'Ei oteta kuvaa vastaan, jos edellistä työstetään
    If DownloadStarted Then
        'Vastaanotetaan kuva
        ReDim Preserve Arr(Tavuja + bytesTotal) As Byte 'lisätään taulukon kokoa
        sock1.GetData T, vbString, bytesTotal
        For I = 0 To bytesTotal - 1 'Siirretään vastaanotettu paketti Tmp=tmp+T ei toiminut...
            Arr(Tavuja + I) = Asc(Mid$(T, I + 1, 1))
        Next I
        Tavuja = Tavuja + bytesTotal   'Lisätään määrää, ja siirretään yhdellä eteenpäin
        If Tavuja >= AllData Then
            pBu.pLoadPic.Picture = Tied.ArrayToPicture(Arr(), 0, UBound(Arr) + 1)
            Tied.SetLoadPicture
            PL.P1_Resize
            Opt.EnaDis 0
            Opt.SetValues
            Erase Arr() 'Tyhjennetään taulukko
            DownloadStarted = False
            frmLog.Log = frmLog.Log & "Done. Server has send " & Str(Tavuja) & " bytes." & vbCrLf
            Tavuja = 0
        End If
    Else
        'Norm chat
        sock1.GetData dat, vbString, bytesTotal
        frmLog.Log = frmLog.Log & "Server : " & dat & vbCrLf
        If Left$(dat, 5) = "Start" Then 'Onko avainsana, jolla aloitetaan vastaanottamaan kuvadataa?
            frmLog.Log = "Server : " & dat & vbCrLf
            AllData = Val(Mid$(dat, 6)) 'Tulossa olevan kuvadatatn koko
            If AllData > 0 Then
                DownloadStarted = True      'Lippu ilmoittaa prosessin alkaneen
                Erase Arr                   'nollataan taulukko
                sock1.SendData "OK Send"    'Annetaan lupa lähettää kuvapaketit
            End If
        End If
    End If
End Sub

Sivun alkuun

Vastaus

Aihe on jo aika vanha, joten et voi enää vastata siihen.

Tietoa sivustosta