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 ;)
Moikka JoreSoft!
Byte Array on se oikea...tsekkaa täältä funktio ArrayToPicture
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
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ää...
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
Eli helpommalla pääsee kun lähettää tavun kerrallaan ja vastaanottopää kuittaa, kunnes tulee esim "Stop" viesti... =)
Kiitos kuitenkin vaivannäöstä
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
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
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
Heippa taas JoreSoft!
Miksi päädyit Client-puolella tallentamaan kuvan ensin väliaikaiseen tiedostoon?
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.. =)
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
Moikka taas JoreSoft!
pikku copy/paste moka eli
'Get #1, , FileStr: Close #1 Get #1, , ImageStr: Close #1
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
Aihe on jo aika vanha, joten et voi enää vastata siihen.