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 SubKiitos 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 SubKun 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 FunctionOlettaisin, 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 SubHei 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 SubFormilla 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 SubJa 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 SubForm 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 SubKiitos 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 SubHeippa 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 FunctionMoikka 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 SubAihe on jo aika vanha, joten et voi enää vastata siihen.