代码缺陷还比较多,没有加出错处理。 该程序既做服务端,又做客户端'Author:Dah 'Coded time:2000.11.10 //y.m.d 'Usage:transfer a file to other pcs through intranet with winsock power Option Explicit Dim mybyte() As Byte '发送方数组 Const filecomesMSG = "a file is coming " '有文件到来 Const RemoteIsReadyMSG = "I'm ready " '准备好了 Const FileisOverMSG = "the file is ended" '文件完毕 Const RemoteDenyMSG = "the user canceled" Const filecountMSG = "the file lengh is" Dim arrdata() As Byte '收到的信息 Dim filesave As Integer '保存文件的句柄 Dim filehandle As Integer '发送方文件的句柄 Dim MyLocation As Double Dim myMSG As String '消息 Dim FileisTransfer As Boolean '文件正在传送 Dim Isendfile As Boolean '是否是本人在传送 Dim FileisOver As Boolean '文件是否已经完毕 Dim Counttime As Integer '需要传递的次数 Dim totaltime As Variant Private Sub cmdsend_Click() On Error GoTo errorhandle 'this is needed for correct filename filehandle = FreeFile If Mid(File1.Path, Len(File1.Path), 1) = "\" Then Open File1.Path & File1.FileName For Binary Access Read As #filehandle Else Open File1.Path & "\" & File1.FileName For Binary Access Read As #filehandle End If Isendfile = True '是本人在传送 FileisOver = False '文件刚开始 cmdsend.Enabled = False Label1.Caption = "Wait for reply..." MsgBox ("the selected file size is " & LOF(filehandle) & " bytes") totaltime = Int(LOF(filehandle) / 4000 + 1) MyLocation = Loc(filehandle) Winsock.SendData filecomesMSG & File1.FileName '发送发出文件信息 Winsock.SendData filecountMSG & totaltime Exit Sub errorhandle: MsgBox ("You havn't choose a file!") End SubPrivate Sub Dir1_Change() File1.Path = Dir1.Path End SubPrivate Sub Drive1_Change() Dir1.Path = Drive1.Drive End SubPrivate Sub Form_Load() Drive1.Drive = "c:\" Winsock.RemoteHost = "255.255.255.255" Winsock.LocalPort = 7904 Winsock.Bind 7904 Winsockfile.RemoteHost = "255.255.255.255" Winsockfile.LocalPort = 7905 Winsockfile.Bind 7905 FileisTransfer = False 'initialize the bool value Isendfile = False FileisOver = True Counttime = 0 Label1.Caption = "Ready..." End SubPrivate Sub Timer1_Timer() Dim i As Integer If LOF(filehandle) - MyLocation > 4000 Then ReDim mybyte(0 To 4000) Get #filehandle, , mybyte MyLocation = Loc(filehandle) Winsockfile.SendData mybyte Counttime = Counttime + 1 Label1.Caption = "the select file is being transfered..." & "about " & Counttime & " / " & totaltime Timer1.Enabled = False Else ReDim mybyte(0 To LOF(filehandle) - MyLocation - 1) Get #filehandle, , mybyte Winsockfile.SendData mybyte FileisTransfer = False Timer1.Enabled = False FileisOver = True End IfEnd SubPrivate Sub Winsock_DataArrival(ByVal bytesTotal As Long) Winsock.GetData myMSG Select Case Mid(myMSG, 1, 17) Case filecomesMSG '这些消息发送方和接受方都可收到 'do display a form If Not Isendfile Then '接受方处理这些事情 On Error GoTo errorhandle CommonDialog1.FileName = Mid(myMSG, 17, Len(myMSG)) CommonDialog1.ShowSave filesave = FreeFile FileisTransfer = True cmdsend.Enabled = False Open CommonDialog1.FileName For Binary Access Write As #filesave Winsock.SendData RemoteIsReadyMSG Label1.Caption = "the select file is being transfered..." End If Case RemoteIsReadyMSG 'do begin transfer a file '如果文件还没有结束,也就是说,只有主机才能受到 If Isendfile Then If Not FileisOver Then Timer1.Enabled = True Label1.Caption = "the select file is being transfered..." Else Winsock.SendData FileisOverMSG End If End If Case FileisOverMSG If Not Isendfile Then '客户机处理 Close #filesave FileisTransfer = False Else '主机处理 Isendfile = False Close #filehandle End If MsgBox ("the file is transfered successfully!") '大家一起处理 Isendfile = False cmdsend.Enabled = True Label1.Caption = "Ready..." Case RemoteDenyMSG If Isendfile Then MsgBox ("The user canceled this transfer session!") Isendfile = False FileisOver = True cmdsend.Enabled = True Label1.Caption = "Ready..." Close #filehandle End If Case filecountMSG If Not Isendfile Then totaltime = Mid(myMSG, 17, Len(myMSG)) End If End Select Exit Sub errorhandle: Winsock.SendData RemoteDenyMSG End Sub Private Sub writetofile() Put #filesave, , arrdata End SubPrivate Sub Winsockfile_DataArrival(ByVal bytesTotal As Long) If FileisTransfer Then Winsockfile.GetData arrdata, vbArray + vbByte, 4001 writetofile Winsock.SendData RemoteIsReadyMSG Counttime = Counttime + 1 Label1.Caption = "the select file is being transfered..." & "about " & Counttime & "/" & totaltime End If End Sub
ID E-mail oicq
fleg(若有所思) [email protected] 24762989
wwwunix([email protected]) [email protected]
dsfy(没完没了....) [email protected] 3692572
swain(球球)[email protected] 21023989
licher(瑞诚) [email protected] 38612744
aifeihuang(波波) [email protected] 300652 phone:13973170842
nicholas() 5427655
wt13(饿狼) 18987813
lawman() phone: 13007313329
In355Hz(好象一条狗)[email protected] 39557323
ZRX_JYP(我想飞) [email protected]
APIer(APIer) [email protected] 1832617 http://calfsoft.51.net
he_Fly(南柯) [email protected] 17573529
catthunder(catthunder) [email protected]
lzcwyd(lzcwyd) [email protected] 11862289
snowguy(snowguy) 392029
Bitsoftware(Bit) [email protected]
Firein_Sky(烈焰焚空) [email protected] 343077
yemagxy(野马) [email protected]
Firing_Sky(火的天空) [email protected] 213841
DeadWolf(死狼) [email protected] call: 95951-076492
angband(笨笨) http://www.csdn.net/cnshare/soft/soft5079.shtm
dynku(随风来去) [email protected]
xcex(可乐瓶) [email protected] 37112249
cai3995(塞尔) 4515047
ID E-mail oicq
fleg(若有所思) [email protected] 24762989
wwwunix([email protected]) [email protected]
f1789(盛世浮言)
bzshow(神啊,求求我吧!))
dsfy(没完没了....) [email protected] 3692572
airwing()
bigjim(飞翔鸟)
flyhigh(一不小心)
qinzm(不归人)
HaoGeGe()
xcex(可乐瓶)
Firein_Sky(烈焰焚空)
TechnoFantasy(www.applevb.com)
Jackyin(农民)
pangpang(胖胖)
starwild(对酒当歌)
chuyf(楚云飞)
gameboy999(无名)
xsx(xiaoxiong)
DeadWolf(死狼)
xialm(用手走路的)
lhztco99(环保概念股)
swain(球球)[email protected] 21023989
songhtao(三十年孤独)
licher(瑞诚) [email protected] 38612744
doxpix()
aifeihuang(波波)[email protected] 300652 mobile:13973170842
nicholas() 5427655
wt13(饿狼) 18987813
wing_pn(麦田守望者)
lawman() phone: 13007313329
oulix(区子)
In355Hz(好象一条狗)[email protected] 39557323
cofe(cofe)
xfyxq(小小旗)
ZRX_JYP(我想飞) [email protected]
APIer(APIer) [email protected] 1832617 http://calfsoft.51.net
he_Fly(南柯) [email protected] 17573529
catthunder(catthunder) [email protected]
lzcwyd(lzcwyd) [email protected] 11862289
snowguy(snowguy) 392029
joki()
Bitsoftware(Bit) [email protected]
54xx()
wxz(行舟)
Firein_Sky(烈焰焚空) [email protected] 343077
yemagxy(野马) [email protected]
Firing_Sky(火的天空) [email protected] 213841
patpat(不死七幻:笑饮一杯酒,杀人都市中)
cieky(冷面寒风)
blod(斑点)
camz(仔)
Dainy(方程式)
qiu006()
DeadWolf(死狼) [email protected] call: 95951-076492
yw_w()
angband(笨笨) http://www.csdn.net/cnshare/soft/soft5079.shtm
dynku(随风来去) [email protected]
feiyunta(蓝天)
xuyi(一)
toadnet(哓哓)
xcex(可乐瓶) [email protected] 37112249
AYellow(北斗猪)
cai3995(塞尔) 4515047
的话题就不多说了。
的话题就不多说了。
该程序既做服务端,又做客户端'Author:Dah
'Coded time:2000.11.10 //y.m.d
'Usage:transfer a file to other pcs through intranet with winsock power
Option Explicit
Dim mybyte() As Byte '发送方数组
Const filecomesMSG = "a file is coming " '有文件到来
Const RemoteIsReadyMSG = "I'm ready " '准备好了
Const FileisOverMSG = "the file is ended" '文件完毕
Const RemoteDenyMSG = "the user canceled"
Const filecountMSG = "the file lengh is"
Dim arrdata() As Byte '收到的信息
Dim filesave As Integer '保存文件的句柄
Dim filehandle As Integer '发送方文件的句柄
Dim MyLocation As Double
Dim myMSG As String '消息
Dim FileisTransfer As Boolean '文件正在传送
Dim Isendfile As Boolean '是否是本人在传送
Dim FileisOver As Boolean '文件是否已经完毕
Dim Counttime As Integer '需要传递的次数
Dim totaltime As Variant
Private Sub cmdsend_Click()
On Error GoTo errorhandle
'this is needed for correct filename
filehandle = FreeFile
If Mid(File1.Path, Len(File1.Path), 1) = "\" Then
Open File1.Path & File1.FileName For Binary Access Read As #filehandle
Else
Open File1.Path & "\" & File1.FileName For Binary Access Read As #filehandle
End If
Isendfile = True '是本人在传送
FileisOver = False '文件刚开始
cmdsend.Enabled = False
Label1.Caption = "Wait for reply..."
MsgBox ("the selected file size is " & LOF(filehandle) & " bytes")
totaltime = Int(LOF(filehandle) / 4000 + 1)
MyLocation = Loc(filehandle)
Winsock.SendData filecomesMSG & File1.FileName '发送发出文件信息
Winsock.SendData filecountMSG & totaltime
Exit Sub
errorhandle: MsgBox ("You havn't choose a file!")
End SubPrivate Sub Dir1_Change()
File1.Path = Dir1.Path
End SubPrivate Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End SubPrivate Sub Form_Load()
Drive1.Drive = "c:\"
Winsock.RemoteHost = "255.255.255.255"
Winsock.LocalPort = 7904
Winsock.Bind 7904
Winsockfile.RemoteHost = "255.255.255.255"
Winsockfile.LocalPort = 7905
Winsockfile.Bind 7905
FileisTransfer = False 'initialize the bool value
Isendfile = False
FileisOver = True
Counttime = 0
Label1.Caption = "Ready..."
End SubPrivate Sub Timer1_Timer()
Dim i As Integer
If LOF(filehandle) - MyLocation > 4000 Then
ReDim mybyte(0 To 4000)
Get #filehandle, , mybyte
MyLocation = Loc(filehandle)
Winsockfile.SendData mybyte
Counttime = Counttime + 1
Label1.Caption = "the select file is being transfered..." & "about " & Counttime & " / " & totaltime
Timer1.Enabled = False
Else
ReDim mybyte(0 To LOF(filehandle) - MyLocation - 1)
Get #filehandle, , mybyte
Winsockfile.SendData mybyte
FileisTransfer = False
Timer1.Enabled = False
FileisOver = True
End IfEnd SubPrivate Sub Winsock_DataArrival(ByVal bytesTotal As Long)
Winsock.GetData myMSG
Select Case Mid(myMSG, 1, 17)
Case filecomesMSG '这些消息发送方和接受方都可收到
'do display a form
If Not Isendfile Then '接受方处理这些事情
On Error GoTo errorhandle
CommonDialog1.FileName = Mid(myMSG, 17, Len(myMSG))
CommonDialog1.ShowSave
filesave = FreeFile
FileisTransfer = True
cmdsend.Enabled = False
Open CommonDialog1.FileName For Binary Access Write As #filesave
Winsock.SendData RemoteIsReadyMSG
Label1.Caption = "the select file is being transfered..."
End If
Case RemoteIsReadyMSG
'do begin transfer a file
'如果文件还没有结束,也就是说,只有主机才能受到
If Isendfile Then
If Not FileisOver Then
Timer1.Enabled = True
Label1.Caption = "the select file is being transfered..."
Else
Winsock.SendData FileisOverMSG
End If
End If
Case FileisOverMSG
If Not Isendfile Then '客户机处理
Close #filesave
FileisTransfer = False
Else '主机处理
Isendfile = False
Close #filehandle
End If
MsgBox ("the file is transfered successfully!") '大家一起处理
Isendfile = False
cmdsend.Enabled = True
Label1.Caption = "Ready..."
Case RemoteDenyMSG
If Isendfile Then
MsgBox ("The user canceled this transfer session!")
Isendfile = False
FileisOver = True
cmdsend.Enabled = True
Label1.Caption = "Ready..."
Close #filehandle
End If
Case filecountMSG
If Not Isendfile Then
totaltime = Mid(myMSG, 17, Len(myMSG))
End If
End Select
Exit Sub
errorhandle: Winsock.SendData RemoteDenyMSG
End Sub
Private Sub writetofile()
Put #filesave, , arrdata
End SubPrivate Sub Winsockfile_DataArrival(ByVal bytesTotal As Long)
If FileisTransfer Then
Winsockfile.GetData arrdata, vbArray + vbByte, 4001
writetofile
Winsock.SendData RemoteIsReadyMSG
Counttime = Counttime + 1
Label1.Caption = "the select file is being transfered..." & "about " & Counttime & "/" & totaltime
End If
End Sub
很早时写的
不过传输200M的文件都没有问题,你可以改进一下
http://softarts.home.chinaren.com/download/tranfile.zip