📄 faws.frm
字号:
If mu1 = 2 Then
Scmnet3.SendData "e" & ListView2.SelectedItem.Key
End If
End Sub
Private Sub Sendfile1_Click()
On Error Resume Next
Select Case mu1
Case "1" '服务端发送文件
If (list2path = "") Then
MsgBox "请打开要传入的位置", 16
Exit Sub
End If
a4 = 0
ReDim list1path(a4)
Call clickimage2
Case "2" '客户端发关文件
If (list1key = "") Then
MsgBox "请打开要存放在本机的位置", 16
Exit Sub
End If
ReDim list2paths(0)
Call clickimage
Call list2_list1
End Select
End Sub
Private Sub Timer1_Timer()
GetCursorPos z
ScreenToClient Me.hwnd, z
'If z.X < Image1.Left Or z.Y < Image1.Top Or z.X > Image1.Left + Image1.Width Or z.Y > Image1.Top + Image1.Height Then
'If z.X < ScaleX(Frame3.Left, 1, 3) Or z.Y < ScaleX(Image1.Top, 1, 3) Or z.X > ScaleX(Frame3.Left, 1, 3) + ScaleX(Image1.Width, 1, 3) Or z.Y > ScaleX(Image1.Top, 1, 3) + ScaleX(Image1.Height, 1, 3) Then
'Image1.Picture = LoadResPicture(101, 0)
Timer1.Enabled = False
'End If
End Sub
Private Sub Timer2_Timer()
GetCursorPos z
ScreenToClient Me.hwnd, z
'If z.X < Image2.Left Or z.Y < Image2.Top Or z.X > Image2.Left + Image2.Width Or z.Y > Image2.Top + Image2.Height Then
'If z.X < ScaleX(Frame3.Left, 1, 3) Or z.Y < ScaleX(Image2.Top, 1, 3) Or z.X > ScaleX(Frame3.Left, 1, 3) + ScaleX(Image2.Width, 1, 3) Or z.Y > ScaleX(Image2.Top, 1, 3) + ScaleX(Image2.Height, 1, 3) Then
'Image2.Picture = LoadResPicture(103, 0)
Timer2.Enabled = False
'End If
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "向上"
On Error GoTo er1
Dim path1 As String
Dim b2 As String
Dim b3 As Integer
Dim b1 As Integer
Dim name As String
path1 = Left(list1key, Len(list1key) - 1)
b2 = "\"
b1 = Len(path1)
Do While b1 >= 2
b1 = b1 - 1
b3 = InStr(b1, path1, b2, 1)
If (b3 > 0) Then
Exit Do
End If
Loop
l1f2 = list1key '保存现在路径
Toolbar1.Buttons(3).Enabled = True
name = Left(path1, b3)
If (name = "") Then
Call computer
ListView1.ListItems(1).Selected = False
ListView1.ListItems(l1f2).Selected = True
Toolbar1.Buttons(4).Enabled = False
Else
Toolbar1.Buttons(4).Enabled = True
Call refu(name, 1)
ListView1.ListItems(1).Selected = False
ListView1.ListItems(list1key).Selected = True
list1key = name '把新路径存回
End If
Exit Sub
er1:
Call computer
Case "新建文件夹"
On Error GoTo er2
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CreateFolder (list1key & "文件传输-新建文件夹")
Call refu(list1key, 1)
ListView1.ListItems(ListView1.SelectedItem.index).Selected = False
ListView1.ListItems(list1key & "文件传输-新建文件夹" & "\").Selected = True
Exit Sub
er2:
MsgBox "已存在一个名为“文件传输-新建文件夹”或 其它原因，创建文件夹失败！", 16, "出错"
Case "后退"
Toolbar1.Buttons(3).Enabled = True
Toolbar1.Buttons(1).Enabled = True
Toolbar1.Buttons(2).Enabled = False
Toolbar1.Buttons(4).Enabled = True
l1f3 = list1key
list1key = l1f2
If (l1f2 = "") Then
Call computer
Else
Call refu(l1f2, 1)
End If
Case "前进"
Toolbar1.Buttons(4).Enabled = True
Toolbar1.Buttons(1).Enabled = True
Toolbar1.Buttons(2).Enabled = True
Toolbar1.Buttons(3).Enabled = False
l1f2 = list1key
list1key = l1f3
If (l1f3 = "") Then
Call computer
Else
Call refu(l1f3, 1)
End If
Case "我的电脑"
Call computer
End Select
End Sub
Private Sub Toolbar2_ButtonClick(ByVal Button As MSComctlLib.Button)
On Error Resume Next
Select Case Button.Key
Case "向上"
Dim path1 As String
Dim b2 As String
Dim b3 As Integer
Dim b1 As Integer
Dim name As String
path1 = Left(list2path, Len(list2path) - 1)
b2 = "\"
b1 = Len(path1)
Do While b1 >= 2
b1 = b1 - 1
b3 = InStr(b1, path1, b2, 1)
If (b3 > 0) Then
Exit Do
End If
Loop
name = Left(path1, b3)
If (name = "") Then
Toolbar2.Buttons(4).Enabled = False
Toolbar2.Buttons(3).Enabled = False
list2path = ""
Scmnet3.SendData "3"
Else
list2path = name
Scmnet3.SendData "1" & name
End If
If (list2path <> "") Then
StatusBar2.Panels(2).Text = Rcname & "\\" & list2path
StatusBar2.Panels(2).ToolTipText = Rcname & "\\" & list2path
Else
StatusBar2.Panels(2).Text = "[" & Rcname & "]" & "的电脑"
End If
Case "新建文件夹"
Scmnet3.SendData "8" & list2path
Case "远程电脑"
list2path = ""
Scmnet3.SendData "3"
Toolbar2.Buttons(1).Enabled = False
Toolbar2.Buttons(2).Enabled = False
Toolbar2.Buttons(3).Enabled = False
Toolbar2.Buttons(4).Enabled = False
End Select
End Sub
Private Sub Scmnet3_Close()
On Error Resume Next
MsgBox "网络连接意外断开！", 16
Scmnet3.Close
Scmnet3.Listen
Unload Fapt
'Unload Me
End Sub
Private Sub Scmnet3_ConnectionRequest(ByVal requestID As Long)
On Error Resume Next
Scmnet3.Close
Scmnet3.Accept requestID
l2f1 = Scmnet3.RemoteHostIP
Frame2.Caption = "远程主机" & "(" & l2f1 & ")" & "[" & Rcname & "]"
StatusBar2.Panels(2).Text = "[" & Rcname & "]" & "的电脑"
Combo2.AddItem "[" & Rcname & "]" & "的电脑"
Combo2.SelText = "[" & Rcname & "]" & "的电脑"
Call UDP_P
Scmnet3.SendData "0" & Scmnet4.LocalPort
End Sub
Private Sub UDP_P() '打开UDP 端口
On Error GoTo er
With Scmnet4
.Close
.Bind Puport1
End With
Exit Sub
er:
Call UDP_P
End Sub
Public Function icoindex(f1 As String, f2 As String) As Long
On Error Resume Next
Dim lngIcon As Long '图标句柄
Dim a1 As String '后缀
Dim fs 'fso模型
Dim im As ListImage
Set fs = CreateObject("Scripting.FileSystemObject")
a1 = fs.GetExtensionName(f2)
Select Case a1
Case "bmp"
icoindex = 4
Case "exe", "lnk", "ico", "cur"
imageindex = imageindex + 1
lngIcon = ExtractAssociatedIcon(App.hInstance, f1, 0)
Set im = ImageList1.ListImages.Add(imageindex, , IconToPicture(lngIcon))
icoindex = imageindex
Case Else
Dim fin As Long
fin = find(a1)
If (fin = 0) Then
Dim a2 As Long
a2 = UBound(imagel)
ReDim Preserve imagel(a2 + 1)
imageindex = imageindex + 1
lngIcon = ExtractAssociatedIcon(App.hInstance, f1, 0)
Set im = ImageList1.ListImages.Add(imageindex, , IconToPicture(lngIcon))
imagel(a2 + 1).index = imageindex
imagel(a2 + 1).suffix = a1
icoindex = imageindex
Else
icoindex = fin
End If
End Select
End Function
Public Function find(str As String) As Long
Dim X As Long
X = UBound(imagel)
Dim i As Long
Dim Y As Long
Dim str1 As String
On Error GoTo er
For i = 1 To X Step 1
str1 = imagel(i).suffix
If (str1 = str) Then
find = imagel(i).index
Exit Function
End If
1
Next
find = 0
Exit Function
er:
find = 0
End Function
Private Sub Scmnet3_DataArrival(ByVal bytesTotal As Long)
Dim k1 As String
Dim k2 As String
Dim k3 As String
Dim k4 As String
Static Filesizedb As String
If (fileput = False) Then
Fapt.Show
Scmnet3.GetData k1
'MsgBox k1 ' _________________________________________________
k2 = Left(k1, 1)
k3 = Right(k1, Len(k1) - 1)
'MsgBox k3 '______________________________________________-
Select Case k2
Case 1
Dim b1 As Long
b1 = InStr(1, k3, ".", 1)
filesizes = Left(k3, b1 - 1)
k4 = Right(k3, Len(k3) - b1)
'''''''''''''''''''''''''''''''
'MsgBox k4 '______________________________________________-
Fapt.Pbar1.Max = filesizes
'''''''''''''''''''''''''''
If filesizes < 1024 Then
Filesizedb = "共有:" & Round(filesizes, 2) & "字节 "
'Fapt.Label2.Caption = Filesizedb
ElseIf filesizes < 1048576 Then
Filesizedb = filesizes / 1024
Filesizedb = "共有:" & Round(Filesizedb, 2) & "KB "
'Fapt.Label2.Caption = Filesizedb
ElseIf filesizes < 1073741824 Then
Filesizedb = filesizes / 1024 / 1024
Filesizedb = "共有:" & Round(Filesizedb, 2) & "MB "
'Fapt.Label2.Caption = Filesizedb
ElseIf filesizes >= 1073741824 Then
Filesizedb = filesizes / 1024 / 1024 / 1024
Filesizedb = "共有:" & Round(Filesizedb, 2) & "GB "
'Fapt.Label2.Caption = Filesizedb
End If
'''''''''''''''''''''''''''''''''''
Fapt.Label1.Caption = "从:" & Scmnet3.RemoteHostIP & "\\" & Left(k4, Len(k4) - Len(k4) + 28) & "..."
k4 = filename(k4)
k4 = list1key & k4
'MsgBox k4 '______________________________________________-
'''''''''''''''''''
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
If (fs.FileExists(k4)) Then '查找在本地是否存在同名文件
Dim b2 As String
Dim b3 As Long
Dim name1 As String
Dim name2 As String
Dim name3 As String
b2 = "\"
b1 = Len(k4)
Do While b1 >= 1
b1 = b1 - 1
b3 = InStr(b1, k4, b2, 1)
If (b3 > 0) Then
Exit Do
End If
Loop
name1 = Left(k4, b3)
name2 = Right(k4, Len(k4) - b3)
k4 = name1 & "(附件) " & name2
Else
Call createfs(k4)
End If
fileput = True
On Error GoTo er
' MsgBox k4 '--------------------------------------------------
Open k4 For Binary As #1
If (filesizes = 0) Then '如果发送的文件为空
Close #1
fileput = False
End If
Fapt.Label5.Caption = "到:" & Left(k4, Len(k4) - Len(k4) + 42) & "..."
Case 2
Call refu(list1key, 1)
Fapt.Command1.Caption = "完成"
End Select
Else
On Error GoTo er1
Dim Files() As Byte
Scmnet3.GetData Files
Put #1, , Files
Dim ji, fns As Long
Dim jfns As String
Dim Rnbs As Long
Dim Robs As String
ji = Loc(1)
Fapt.Pbar1.Value = ji
'Fapt.Label3.Caption = "已发送 " & ji & " 字节"
'Fapt.Label4.Caption = "剩余 " & filesizes - ji & " 字节 "
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''%
Rnbs = filesizes - ji
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -