rdata.frm

资料上传程序源码

lpfn As Long
lParam As Long
iImage As Long
End Type

Const BIF_RETURNONLYFSDIRS = &H1

Private pidl As Long

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByValpszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
 
Private Sub Command1_Click() '----------------------保存设置
Dim rad As String
Dim spa, sad, bad, na, pw, t As String
 spa = Text2(0).Text
sad = Text2(1).Text
bad = Text2(2).Text
 na = Text2(3).Text
pw = Text2(4).Text
t = Text2(5).Text
sad = IIf(Right(Text2(1).Text, 1) = "/", Text2(1).Text, Text2(1).Text & "/")
bad = IIf(Right(Text2(2).Text, 1) = "\", Text2(2).Text, Text2(2).Text & "\")
rad = App.path & "\rad.ini"
Open rad For Output As #1
Print #1, spa
Print #1, sad
Print #1, bad
Print #1, na
Print #1, pw
Print #1, t
Close #1
 Drive1.Drive = Left(Text2(2).Text, 1) & " :" & "\"
Dir1.path = Text2(2).Text
File1.path = Dir1.path
End Sub

Private Sub Command2_Click()
Timer1.Enabled = True
Command3.Enabled = True
Command2.Enabled = False

End Sub

Private Sub Command3_Click()
Command2.Enabled = True
Timer1.Enabled = False
Command3.Enabled = False
End Sub

Private Sub Command4_Click()
FTP.Disconnect
Unload Me
End Sub

Private Sub Command6_Click()
Dim nian, yue, ri, shi, fen, ch, file, strline, t As String
Dim i, j   As Integer
Dim filename As String
nian = Mid(Format(Year(Date), "00"), 3, 2)
yue = Mid(Format(Month(Date), "00"), 1, 2)
ri = Mid(Format(Day(Date), "00"), 1, 2)
shi = Mid(Format(Hour(Time), "00"), 1, 2)
fen = Mid(Format(Minute(Time), "00"), 1, 2)
 If Right(Text2(1).Text, 1) = "/" Then
 Text2(1).Text = Text2(1).Text
 Else
Text2(1).Text = Text2(1).Text & "/"
End If
On Error GoTo ss
       i = Len(Text2(1).Text)
       FTP.RemoteAddress = Text2(0).Text
       FTP.UserName = Text2(3).Text
       FTP.Password = Text2(4).Text
       FTP.RemoteFile = Text2(1).Text & filename
       On Error Resume Next
       FTP.Connect
    
       If Err <> 0 Then
             Text1.Text = Text1.Text + "无法连接到远端计算机!" & "  " + "time:" + nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen & vbCrLf
           
             End If

       FTP.RemoteDirectory = Left(Text2(1).Text, i - 1)
     
       On Error Resume Next
        
           FTP.Disconnect
          
            

           Text1.Text = Text1.Text + "连接测试成功！" + "  " + "time:" + nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen & vbCrLf
          Text1.Text = Text1.Text + "连接测试完毕！" + "  " + "time:" + nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen & vbCrLf
                
        
           Exit Sub
       
    
ss:


 Text1.Text = Text1.Text + "连接测试失败！ " + "  " + "time:" + nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen & vbCrLf
Exit Sub
End Sub

Private Sub Dir1_Change()
File1.path = Dir1.path

End Sub
 Private Sub Timer1_Timer()
 
Dim nian, yue, ri, shi, fen, ch, file, strline, t As String
Dim i, j   As Integer
Dim filename As String
nian = Mid(Format(Year(Date), "00"), 3, 2)
yue = Mid(Format(Month(Date), "00"), 1, 2)
ri = Mid(Format(Day(Date), "00"), 1, 2)
shi = Mid(Format(Hour(Time), "00"), 1, 2)
fen = Mid(Format(Minute(Time), "00"), 1, 2)
t = Text2(5).Text
file = App.path & "\ftp" & yue & ".txt"
If Dir(file) = "" Then
fso.CreateTextFile (file)
End If
N = N + 1
'MsgBox N
If N = Val(t) * 60 Then


'File1.path = Text2(2).Text
File1.ListIndex = File1.ListCount - 1
File1.Refresh
For j = 0 To File1.ListCount - 1
If File1.List(j) = File1.List(File1.ListCount - 1) Then
filename = File1.List(j)
End If
Next j

'MsgBox filename
 Open file For Input As #1
Do Until EOF(1)
      Line Input #1, strline
      Loop
       Close #1
     If Left$(strline, 17) = filename Then
        Beep
       Text1.Text = Text1.Text + "操作完成！无最新资料！" + "  " + "time:" + nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen & vbCrLf
        N = 0
        Exit Sub
        End If
On Error GoTo ss
        i = Len(Text2(1).Text)
       FTP.RemoteAddress = Text2(0).Text
       FTP.UserName = Text2(3).Text
       FTP.Password = Text2(4).Text
       FTP.LocalFile = File1.path & "\" & filename
       FTP.RemoteFile = Text2(1).Text & filename
       On Error Resume Next
       Screen.MousePointer = vbHourglass
       FTP.Connect
       Screen.MousePointer = vbDefault
       If Err <> 0 Then
             Text1.Text = Text1.Text + "无法连接到远端计算机!" & "  " + "time:" + nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen & vbCrLf
             Me.Caption = "无法连接服务器172.23.2.98,请检查设置!"
               Open file For Append As #1
       Print #1, Me.Caption & nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen
       Close #1
             Exit Sub
       End If
      ' FTP.RemoteDirectory = Left(Form1.Text1(3).Text, i - 1)
      FTP.RemoteDirectory = Left(Text2(1).Text, i - 1)
       Screen.MousePointer = vbHourglass
      
     

       On Error Resume Next
       FTP.PutFile
       Screen.MousePointer = vbDefault
       If Err <> 0 Then
           Text1.Text = Text1.Text + "不能连接到远端主机,请检查设置。" + "  " + "time:" + nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen & vbCrLf
          Me.Caption = "无法连接服务器172.23.2.98,请检查设置!"
          PlaySound App.path & "\danger.wav", ByVal 0&, SND_FILENAME Or SND_ASYNC
            Open file For Append As #1
       Print #1, Me.Caption & nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen
       Close #1
           Else
           FTP.Disconnect
           Do While FileLen(Right(FTP.RemoteFile, 17)) >= FileLen(filename)
                  
                  
                  
                  ProgressBar1.Value = ProgressBar1.Value + 1
                  If FileLen(Right(FTP.RemoteFile, 17)) = FileLen(filename) Then
                  ProgressBar1.Value = 100
                  Exit Do
                  End If
            Loop

          
    

           Text1.Text = Text1.Text + "SEND-->" & " " & Right(FTP.RemoteFile, 17) & " " + "成功！" + "  " + "time:" + nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen & vbCrLf
          Text1.Text = Text1.Text + "操作完毕！" + "  " + "time:" + nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen & vbCrLf
          Me.Caption = Right(FTP.RemoteFile, 17) & "上传成功！"
           Open file For Append As #1
       Print #1, Me.Caption & nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen
       Close #1
          ' Beep
          End If
          File1.Refresh
       
          N = 0
         ProgressBar1.Value = 0
      Exit Sub
       
    
ss:


 Text1.Text = Text1.Text + "SEND-->" & " " & Right(FTP.RemoteFile, 17) & "  " + "失败！ " + "  " + "time:" + nian + "-" + yue + "-" + ri + "  " + shi + ":" + fen & vbCrLf
Exit Sub
End If
 End Sub


Private Sub Drive1_Change()

Dir1.path = Drive1.Drive

End Sub


Private Sub Command5_Click()
Dim bi As BROWSEINFO
Dim r As Long
Dim pidl As Long
Dim path As String
Dim pos As Integer

'句柄
bi.hOwner = Me.hWnd
'展开根目录
bi.pidlRoot = 0&

'列表框标题
bi.lpszTitle = "请选择雷达基数据路径:"
'规定只能选择文件夹，其他无效

bi.ulFlags = BIF_RETURNONLYFSDIRS

'调用API函数显示列表框

pidl = SHBrowseForFolder(bi)

'利用API函数获取返回的路径


path = Space$(512)
r = SHGetPathFromIDList(ByVal pidl&, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
Text2(2) = Left(path, pos - 1)
Else: Text2(2) = ""
End If
End Sub

Private Sub Form_Load()
Dim rad, h As String
Dim spa As String
Dim sad, bad, na, pw, t As String
If App.PrevInstance Then
MsgBox "程序已启动！", vbInformation
End
End If
On Error GoTo 2006
Timer1.Enabled = False
Command3.Enabled = False
Dir1.Visible = False
Drive1.Visible = False
rad = App.path & "\rad.ini"
Open rad For Input As #1
Input #1, spa
Input #1, sad, bad, na, pw, t
Close #1
Text2(0).Text = spa
 Text2(1).Text = sad
Text2(2).Text = bad
 Text2(3).Text = na
Text2(4).Text = pw
Text2(5).Text = t
 Drive1.Drive = Left(Text2(2).Text, 1) & " :" & "\"
Dir1.path = Text2(2).Text
File1.path = Dir1.path
2006
If Err.Number = 62 Then
h = MsgBox("上一次未设置FTP ！")
End If
End Sub