Keskustelu: Ohjelmointikysymykset: VB6: Siirron seuranta

ReDim taulu (0 To 1, 0), kokoYht As Long
Dim fso As Scripting.FileSystemObject, Palvelin As String
'...
Sub EnnenVarsinaistaImppausta()
  DoEvents
  '...
  '...
  taulu(0, Ubound(taulu, 2)) = filu
  taulu(1, Ubound(taulu, 2)) = filukoko
  kokoYht = kokoYht + filukoko
  ReDim Preserve taulu(0 To 1, Ubound(taulu, 2) + 1)
End Sub

Sub VarsinainenImppaus()
  Timer1.Enabled = True
  Timer1.Interval = 'jokuSäätö
  DoEvents
  '...
  '...
End Sub

Private Sub Timer1_Timer()
  Static laskuri As Integer
  Static impattuKoko As Long
  DoEvents
  If impattuKoko < kokoYht Then
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists("polku\" & taulu(0, laskuri)) And _
                           taulu(0, laskuri) <> "" Then
      Label1.Caption = "Ladataan tiedostoa: " & Palvelin & _
       " - " &  "polku\" & taulu(0, laskuri)
       If fso.GetFile("polku\" & _
         taulu(0, laskuri)).Size = taulu(1, laskuri) Then
         impattuKoko = impattuKoko + fso.GetFile("polku\" & _
         taulu(0, laskuri)).Size
         Label2.Caption = "Latauksen tila: " & _
         Format$((1 / kokoYht * impattuKoko * 100),"#0") & "%"
         Label3.Caption = Tiedostoja ladattu: " CStr(laskuri) & _
         "/" CStr(UBound(taulu, 2) - 1)
         laskuri = laskuri + 1
       End if
    End If
    Set fso = Nothing
 Else
   Timer1.Interval = 0
   laskuri = 0: impattuKoko = 0
   Timer1.Enabled = False: Exit Sub
 End If
End Sub

'Laskuri (Client)
'Formin säädöt:
'BorderStyle 3 - FixedDialog
'Caption tyhjää
'ControlBox False
'ShowInTaskBar False
Dim fso As Scripting.FileSystemObject
Dim clpData() As String, fileTag As String

Private Sub Form_Initialize()
  Me.BackColor = &H80000007
  Label1.BackColor = Me.BackColor
  Label1.ForeColor = &H8000000E
  Label1.Font.Name = "Terminal"
  Label1.FontSize = 12
  Label1.AutoSize = True
  asettele
End Sub

Private Sub Form_Load()
  If App.PrevInstance Then End
  fileTag = "": Clipboard.Clear
  'referenssi: Microsoft Scripting Runtime
  'C:\WINDOWS\system32\scrrun.dll
  Set fso = CreateObject("Scripting.FileSystemObject")
  Me.Show
  Tapa_Laturi
  Aja_Laturi
End Sub

Private Sub Label1_Change()
  asettele
End Sub

Sub asettele()
  Label1.Top = 300: Label1.Left = 300
  Me.Height = Label1.Height + Label1.Top * 2
  Me.Width = Label1.Width + Label1.Left * 2
  Me.Top = (Screen.Height / 2) - (Me.Height / 2)
  Me.Left = (Screen.Width / 2) - (Me.Width / 2)
End Sub


Sub anna_palaa()
Ret:
  Do: DoEvents
  If Clipboard.GetText = "LATURI_VALMIS" Then Exit_Proc
  If InStr(Clipboard.GetText, "|") > 0 Then
   Dim sptHlp() As String, i As Integer
   sptHlp = Split(Clipboard.GetText, "|")
   ReDim clpData(UBound(sptHlp))
   For i = 0 To UBound(sptHlp)
   clpData(i) = sptHlp(i)
   Next i
   Erase sptHlp
    If fso.FolderExists(clpData(1)) And fileTag <> clpData(2) Then
      fileTag = clpData(2)
      Do: DoEvents
        If fso.FileExists(clpData(1) & "\" & clpData(2)) Then
          Do: DoEvents
          dots = String(CLng(Right(Time, 1) + 4) / 4, ".")
          If Not fso.FileExists(clpData(1) & "\" & clpData(2)) _
          Then Exit_Proc
            Label1.Caption = "LADATAAN" & dots & vbCrLf & _
            " Tiedostoa:   " & clpData(2) & vbCrLf & _
            " Osoitteesta: " & clpData(0) & "/" & _
            vbCrLf & " Kansioon:    " & clpData(1) _
            & vbCrLf & " Ladattu:     " & _
            Format$((1 / CLng(clpData(3)) * _
            fso.GetFile(clpData(1) & "\" & _
            clpData(2)).Size * 100), "0") & "%" _
            & vbCrLf & vbCrLf & " LATAUS" & dots & vbCrLf _
            & " Tiedostot:   " & clpData(5) & "/" & _
            clpData(6) & vbCrLf & " Totaali:     " _
            & Format$((1 / CLng(clpData(4)) * _
            fso.GetFolder(clpData(1)).Size * 100), "0.00") & "%"
            If Clipboard.GetText = "LATURI_VALMIS" Then Exit_Proc
            If fso.GetFile(clpData(1) & "\" & _
            clpData(2)).Size = clpData(3) Then GoTo Ret
           Loop
         End If
       Loop
     End If
   End If
Loop
End Sub

Sub Exit_Proc()
  Label1.Caption = " LATAUS SUORITETTU"
  Dim delay As Single
  delay = Timer + 2
  Do While delay > Timer: DoEvents: Loop
  If fso.FolderExists("c:\Impatut") Then _
  Shell "explorer c:\Impatut"
  Set fso = Nothing
  Tapa_Laturi
  End
End Sub

Sub Aja_Laturi()
  Dim Prosessit, Prosessi, objekti
  Dim kone, ohjelma, simpukka
  kone = "."
  'ohjelma Windows\system32 hakemistoon...
  'ja App.Path + kenoviivan voi poistaa...
  ohjelma = App.Path & "\" & "Laturi.exe"
  Set Prosessit = GetObject("winmgmts:" _
  & "{impersonationLevel=impersonate}!\\" & _
  kone & "\root\cimv2")
  Set Prosessi = Prosessit.Get("Win32_Process")
  Set objekti = Prosessi.Methods_( _
  "Create").InParameters.SpawnInstance_
  objekti.CommandLine = ohjelma
  Set simpukka = Prosessit.ExecMethod( _
  "Win32_Process", "Create", objekti)
  Set simpukka = Nothing: Set objekti = Nothing
  Set Prosessi = Nothing: Set Prosessit = Nothing
  Do: DoEvents
    Dim delay As Single
    delay = 0.25
    Do While delay > Timer: DoEvents: Loop
    Loop Until Clipboard.GetText <> ""
  anna_palaa
End Sub

Sub Tapa_Laturi()
  Dim Prosessit
  Dim Prosessi
  'referenssi: Microsoft WMI Scripting V1.2 Library
  'C:\WINDOWS\system32\wbem\wbemdisp.TLB)
  Set Prosessit = GetObject _
  ("winmgmts:{impersonationLevel=impersonate}") _
  .InstancesOf("Win32_Process")
  For Each Prosessi In Prosessit
    With Prosessi
      If LCase(.Name) = "laturi.exe" Then
        .Terminate
      End If
    End With
  Next
  Set Prosessit = Nothing
End Sub

'Laturi (Proxy)
'Formin säädöt:
'BorderStyle 3 - FixedDialog
'Caption tyhjää
'ControlBox False
'ShowInTaskBar False
Private Type AJAT
  aikaL As Long
  aikaH As Long
End Type

Private Type TIEDOT
  attribuutit As Long
  luotu As AJAT
  avattu As AJAT
  muokattu As AJAT
  kokoH As Long
  kokoL As Long
  varattu0 As Long
  varattu1 As Long
  tiedosto As String * 260
  vtied As String * 14
End Type

Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
Private Declare Function InternetConnect Lib "wininet.dll" _
Alias "InternetConnectA" (ByVal hInternetSession As Long, _
ByVal sServerName As String, ByVal nServerPort As Integer, _
ByVal sUserName As String, ByVal sPassword As String, _
ByVal lService As Long, ByVal lFlags As Long, _
ByVal lContext As Long) As Long
Private Declare Function InternetOpen Lib "wininet.dll" _
Alias "InternetOpenA" (ByVal sAgent As String, ByVal _
lAccessType As Long, ByVal sProxyName As String, ByVal _
sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib _
"wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal _
hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpGetCurrentDirectory Lib _
"wininet.dll" Alias "FtpGetCurrentDirectoryA" (ByVal _
hFtpSession As Long, ByVal lpszCurrentDirectory As _
String, lpdwCurrentDirectory As Long) As Long
Private Declare Function FtpFindFirstFile Lib "wininet.dll" _
Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal _
lpszSearchFile As String, lpFindFileData As TIEDOT, ByVal _
dwFlags As Long, ByVal dwContent As Long) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" _
Alias "InternetFindNextFileA" (ByVal kahvaHaku As Long, _
lpvFindData As TIEDOT) As Long
Const PassiveConnection As Boolean = True
Private Declare Function FtpGetFile Lib "wininet.dll" _
Alias "FtpGetFileA" (ByVal hConnect As Long, ByVal _
lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal _
fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, ByRef dwContext As Long) As Boolean
Dim PALVELIN As String: Dim taulu(): Dim kokoYht As Long
Dim yhteys As Long, avaa As Long, kahvaHaku As Long
Dim fso As Scripting.FileSystemObject

Private Sub Form_Load()
  If App.PrevInstance Then End
  IsLaskuri
  PALVELIN = "palvelin"
  avaa = InternetOpen("WinInet", 0, vbNullString, vbNullString, 0)
  yhteys = InternetConnect(avaa, PALVELIN, 21, "kättäjätunnus", _
  "salasana", 1, IIf(0, 0, 0), 0)
  Dim orgPolku As String
  orgPolku = String(260, 0)
  FtpGetCurrentDirectory yhteys, orgPolku, Len(orgPolku)
  'mikäli hakemisto muu kuin juuri...
  'FtpSetCurrentDirectory yhteys, "hakemisto"
  FtpSetCurrentDirectory yhteys, orgPolku ' takas juureen
  voPolku = orgPolku
  ListaaTiedot yhteys
  'referenssi: Microsoft Scripting Runtime
  'C:\WINDOWS\system32\scrrun.dll
  Set fso = CreateObject("Scripting.FileSystemObject")
  If fso.FolderExists("c:\imppaus") Then
    If fso.GetFolder("c:\imppaus").Size > 0 Then
      Kill "c:\imppaus\*.*"
    End If
  ElseIf Not fso.FolderExists("c:\imppaus") Then
    MkDir ("c:\imppaus")
  Else
  End If
  For i = 0 To UBound(taulu, 2) - 1
  'Hoituu hyvin myös DDE-LinkSend viritelmällä
  Clipboard.SetText PALVELIN & "|" _
  & "c:\imppaus" & "|" & _
  taulu(0, i) & "|" & CStr(taulu(1, i)) & _
  "|" & CStr(kokoYht) & "|" & _
  CStr(i) & "|" & CStr(UBound(taulu, 2) - 1)
  FtpGetFile yhteys, taulu(0, i), "C:\imppaus\" & _
       taulu(0, i), True, 0, &H2, 0

    Do: DoEvents
    Loop Until fso.FileExists("C:\imppaus\" & taulu(0, i))
    Do: DoEvents
    Loop Until fso.GetFile("C:\imppaus\" _
          & taulu(0, i)).Size = taulu(1, i)
  Next i
  If Not fso.FolderExists("c:\Impatut") Then
    MkDir ("c:\Impatut")
  End If
   If Not fso.FolderExists("c:\Impatut") Then
    MkDir ("c:\Impatut")
  End If
  If fso.FolderExists("c:\imppaus") Then
    If fso.GetFolder("c:\imppaus").Size > 0 Then
      For i = 0 To UBound(taulu, 2) - 1
        FileCopy "c:\imppaus\" & taulu(0, i), _
        "c:\Impatut\" & taulu(0, i)
      Next i
        Kill "c:\imppaus\*.*"
        RmDir "c:\imppaus"
    End If
  End If
  Erase taulu
  Set fso = Nothing
  InternetCloseHandle yhteys
  InternetCloseHandle avaa
  Clipboard.SetText "LATURI_VALMIS"
End Sub

Public Sub ListaaTiedot(kamat As Long)
  ReDim taulu(1, 0): kokoYht = 0
  Dim tiedostoDATA As TIEDOT, palaute As Long
  tiedostoDATA.tiedosto = String(260, 0)
  kahvaHaku = FtpFindFirstFile(kamat, "*.*", _
  tiedostoDATA, 0, 0)
  If kahvaHaku = 0 Then Exit Sub
  If Mid(Left(tiedostoDATA.tiedosto, _
  InStr(1, tiedostoDATA.tiedosto, _
  String(1, 0), vbBinaryCompare) - 1), _
  Len(Left(tiedostoDATA.tiedosto, _
  InStr(1, tiedostoDATA.tiedosto, _
  String(1, 0), vbBinaryCompare) - 1)) - 3, 1) = "." Then
  taulu(0, 0) = Left(tiedostoDATA.tiedosto, _
    InStr(1, tiedostoDATA.tiedosto, _
    String(1, 0), vbBinaryCompare) - 1)
  taulu(1, 0) = tiedostoDATA.kokoL
  ReDim Preserve taulu(1, UBound(taulu, 2) + 1)
  End If
  Do
    DoEvents
    tiedostoDATA.tiedosto = String(260, 0)
    palaute = InternetFindNextFile(kahvaHaku, tiedostoDATA)
    If palaute = 0 Then Exit Do
    If Mid(Left(tiedostoDATA.tiedosto, _
    InStr(1, tiedostoDATA.tiedosto, _
    String(1, 0), vbBinaryCompare) - 1), _
    Len(Left(tiedostoDATA.tiedosto, _
    InStr(1, tiedostoDATA.tiedosto, _
    String(1, 0), vbBinaryCompare) - 1)) - 3, 1) = "." _
    And Left(tiedostoDATA.tiedosto, _
    InStr(1, tiedostoDATA.tiedosto, _
    String(1, 0), vbBinaryCompare) - 1) <> PALVELIN Then
    taulu(0, UBound(taulu, 2)) = Left(tiedostoDATA.tiedosto, _
    InStr(1, tiedostoDATA.tiedosto, _
    String(1, 0), vbBinaryCompare) - 1)
    taulu(1, UBound(taulu, 2)) = tiedostoDATA.kokoL
    kokoYht = kokoYht + taulu(1, UBound(taulu, 2))
    ReDim Preserve taulu(1, UBound(taulu, 2) + 1)
    End If
  Loop
  InternetCloseHandle kahvaHaku
End Sub

Sub IsLaskuri()
  'referenssi: Microsoft WMI Scripting V1.2 Library
  '(C:\WINDOWS\system32\wbem\wbemdisp.TLB)
  Dim Prosessit, Prosessi, IsRunning As Boolean
  Set Prosessit = GetObject _
  ("winmgmts:{impersonationLevel=impersonate}") _
  .InstancesOf("Win32_Process")
  For Each Prosessi In Prosessit
    With Prosessi
      If LCase(.Name) = "laskuri.exe" Then
        IsRunning = True: Exit For
      End If
    End With
  Next
  Set Prosessit = Nothing
  If Not IsRunning Then
    MsgBox "Tämä ohjelma voidaan käynnistää" & vbCrLf _
         & "vain käynnistämällä Laskuri.exe!", vbCritical, _
         "Viestiloota": End
  End If
End Sub

Private Type sdata
  d1 As String
  d2 As String
  d3 As String
  d4 As String
  d5 As String
End Type
Private Declare Function ShellExecute Lib _
"Shell32.dll" Alias "ShellExecuteA" (ByVal _
hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As _
String, ByVal lpDirectory As String, ByVal _
nshowcmd As Long) As Long
Dim taulu() As sdata

Private Sub Form_Load()
  If App.PrevInstance Then End
  Command2.Enabled = False
End Sub

Private Sub Command1_Click()
  Command2.Enabled = False
  Dim komennot As String, avaa  As String
 '[linkki "http://www.nsftools.com/tips/MSFTP.htm#mdir"]kaikki tämä on käytössä[/linkki]
  Open "c:\ftpKomento.dat" For Output As #1
  Print #1, "Open"
  Print #1, "ftp-palvelin"
  Print #1, "käyttäjätunnus"
  Print #1, "salasana"
  Print #1, "mdir *.* c:\sFilut.dat" & vbCrLf
  Print #1, "Quit"
  Close #1
  z& = ShellExecute(Me.hwnd, vbNullString, _
  "ftp.exe", "-s:c:\ftpKomento.dat", "C:\", 2)
  lue_filudata
  poista_ftpData
  Command2.Enabled = True
End Sub

Private Sub Command2_Click()
  For i = 0 To UBound(taulu)
    MsgBox _
      "Luku/kirjotus: " & taulu(i).d1 & vbCrLf _
    & "Attribuuti: " & taulu(i).d2 & vbCrLf _
    & "Koko: " & taulu(i).d3 & vbCrLf _
    & "Luotu: " & taulu(i).d4 & vbCrLf _
    & "Nimi: " & taulu(i).d5
  Next i
End Sub

Sub Viive(ByVal aika As Single)
  aika = aika + Timer
  Do While aika > Timer: DoEvents: Loop
End Sub

Sub lue_filudata()
  On Error Resume Next
  Open "c:\sFilut.dat" For Input As #1
  If Err > 0 Then
    Err.Clear
    Viive 0.5: lue_filudata
  End If
  Dim fStr As String, usplit() As String
  Dim userx As String, fdata() As String
  Do While Not InStr(fStr, "asiakas") > 0 And _
  Not InStr(fStr, "client") > 0: Input #1, fStr: Loop
  If InStr(fStr, " asiakas ") > 0 Then
    usplit = Split(fStr, "asiakas")
    usplit(0) = Trim(usplit(0))
    userx = "asiakas"
  ElseIf InStr(fStr, " client ") > 0 Then
    usplit = Split(fStr, "client")
    usplit(0) = Trim(usplit(0))
    userx = "client"
  End If
  For i = Len(usplit(0)) To 1 Step -1
    If Mid(usplit(0), i, 1) = " " Then
      fStr = Right(usplit(0), Len(usplit(0)) - i)
      Exit For
    End If
  Next i
  Seek #1, 1
  fdata = Split(Replace(Replace(Input$(LOF(1), 1), _
  fStr, ""), userx, ""), vbCrLf)
  Close #1
  ReDim taulu(UBound(fdata) - 2) As sdata
  For i = 0 To UBound(fdata) - 2
    Dim apuStr As String, apuStr2 As String
    apuStr = Trim(fdata(i))
    Do While InStr(apuStr, " ") > 0
      If InStr(apuStr, " ") > 0 Then
        apuStr2 = apuStr2 & Left(apuStr, InStr(apuStr, " ") - 1) + "|"
        apuStr = Trim(Right(apuStr, Len(apuStr) - InStr(apuStr, " ")))
      End If
    Loop
    Dim xSplit() As String
    xSplit = Split(apuStr2 & apuStr, "|")

    taulu(i).d1 = xSplit(0)
    taulu(i).d2 = xSplit(1)
    taulu(i).d3 = xSplit(2)
    taulu(i).d4 = xSplit(3) & " " _
    & xSplit(4) & " " & xSplit(5)
    Select Case UBound(xSplit)
      Case 6
        taulu(i).d5 = xSplit(6)
      Case 7
       taulu(i).d5 = xSplit(6) & " " & xSplit(7)
      Case 8
        taulu(i).d5 = xSplit(6) & " " & _
        xSplit(7) & " " & xSplit(8)
      Case 9
        taulu(i).d5 = xSplit(6) & " " & _
        xSplit(7) & " " & xSplit(8) _
        & " " & xSplit(9)
      Case 10
        taulu(i).d5 = xSplit(6) & " " & _
        xSplit(7) & " " & xSplit(8) _
        & " " & xSplit(9) & " " & xSplit(10)
     End Select
     apuStr2 = ""
  Next i

  Kill "c:\sFilut.dat"
  Err.Clear
End Sub
Sub poista_ftpData()
  On Error Resume Next
  Kill "c:\ftpKomento.dat"
  If Err > 0 Then
     Err.Clear: Viive 0.5: poista_ftpData
  End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Erase taulu
End Sub