Keskustelu: Ohjelmointikysymykset: Tiedoston uppaaminen nettiin (VB6) (VBA)

Private Sub CommandButton1_Click()
  virhe = False: indeksi = 0: jatka = False
  UserForm1.Show 1
  If Not jatka Then Exit Sub
  Dim kama()
  ChDir (Environ("userprofile") & "\Työpöytä")
  On Error Resume Next
  kama = Application.GetOpenFilename( _
  "Tiedostot (*.*), *.*", , "Uppatava kama", , True)
  If Err > 0 Then
  Err.Clear: Exit Sub
  End If
  Open "c:\ftpYhteys.bat" For Output As #1
  Print #1, "ftp.exe -s:c:\ftpKomento.dat >c:\ftpPalaute.dat"
  Print #1, "exit": Close #1
  fname = "c:\ftpYhteys.bat"
  UserForm1.tsekkaaStatus (fname)
  Open "c:\ftpKomento.dat" For Output As #1
  Print #1, "Open"
  Print #1, palvelin & " " & portti
  Print #1, tunnus
  Print #1, salasana
  Print #1, "type binary"
  For i = 0 To UBound(kama)
  Print #1, "send " & Chr(34) & kama(i) & Chr(34)
  Next i
  Print #1, vbCrLf
  Print #1, "Quit"
  Close #1
  fname = "c:\ftpKomento.dat"
  UserForm1.tsekkaaStatus (fname)
  Shell "c:\ftpYhteys.bat", vbHide
  fname = "c:\ftpPalaute.dat"
  UserForm1.tsekkaaStatus (fname)
  UserForm1.lue_ftpPalaute (2)
  If InStr(uppaus, "PORT command successful") > 0 Then
    For i = 0 To UBound(kama)
      ActiveWorkbook.Worksheets(1).Activate
      Cells(3, 1).Value = "UPATAAN TIEDOSTOJA..."
      Cells(4, 1).Value = "Palvelimelle :" & palvelin
      Cells(6, 1).Value = "Kopioitavat tiedostot:"
      With Sheets(1)
        .Cell(6 + i, 1).Value = kama(i)
      End With
    Next i
  End If
  uppaus = "": kamat = UBound(kama)
 Erase kama: tsekkaaTila
End Sub
Sub tsekkaaTila()
 Dim Prosessit, Prosessi, rullaa As Boolean
  'Projektiin 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) = "ftp.exe" Then
         rullaa = True
      End If
    End With
  Next
  Set Prosessit = Nothing
  If rullaa Then
    UserForm1.Viive 0.5: tsekkaaTila
  End If
  Sheets(1).Activate
  Application.ScreenUpdating = False
  Range("A1:A" & CStr(6 + kamat)).Select
  Selection.Clear: Cells(1, 1).Select
  Cells(16, 8).Value = "UPPAAMINEN VALMIS!"
  Application.ScreenUpdating = True
  UserForm1.Viive 1: Cells(16, 8).Value = ""
  UserForm1.tappolaskuri
End Sub

'formille 4 Textboxia ja pari nappia
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

Private Sub TextBox3_Change()
   For i = 0 To 255
     Select Case i
       Case 0 To 45, 47, 59 To 96, 123 To 255
       TextBox3.Text = _
      Replace(TextBox3.Text, CStr(Chr(i)), "")
    End Select
  Next
End Sub

Private Sub TextBox4_Change()
  For i = 0 To 255
     Select Case i
       Case 0 To 45, 47, 59 To 96, 123 To 255
       TextBox4.Text = _
       Replace(TextBox4.Text, CStr(Chr(i)), "")
    End Select
  Next
End Sub

Private Sub UserForm_Activate()
  Me.Caption = "FTP-uppaaja"
  nollaaKaikki
End Sub

Private Sub CommandButton2_Click()
  Dim fname As String
  For i = 1 To 4
    tsekkaa_boxit (i)
    If virhe Then
      virhe = False
    Exit Sub
    End If
  Next i
  CommandButton2.Enabled = False
  ChDir ("C:\")
  Open "c:\ftpYhteys.bat" For Output As #1
  Print #1, "ftp.exe -s:c:\ftpKomento.dat >c:\ftpPalaute.dat"
  Print #1, "exit": Close #1
  fname = "c:\ftpYhteys.bat"
  tsekkaaStatus (fname)
  Open "c:\ftpKomento.dat" For Output As #1
  Print #1, "Open"
  Print #1, TextBox1.Text & " " & TextBox2.Text
  Print #1, TextBox3.Text
  Print #1, TextBox4.Text
  Print #1, "quote" & vbCrLf
  Print #1, "Quit"
  Close #1
  fname = "c:\ftpKomento.dat"
  tsekkaaStatus (fname)
  Shell "c:\ftpYhteys.bat", vbHide
  fname = "c:\ftpPalaute.dat"
  tsekkaaStatus (fname)
  lue_ftpPalaute (0)
  If UBound(virheet) > 0 Then
    Dim msgStr As String
    msgStr = "Virheet:" & vbCrLf
    For i = 0 To UBound(virheet)
      Select Case virheet(i)
        Case "1": msgStr = msgStr & "- osoite" & vbCrLf
          TextBox1.Text = ""
        Case "2": msgStr = msgStr & "- portti" & vbCrLf
          TextBox2.Text = "21"
        Case "3": msgStr = msgStr & "- käyttäjätunnus" & vbCrLf _
                                & "- /salasana pari"
          TextBox3.Text = "": TextBox4.Text = ""
      End Select
    Next i
    MsgBox msgStr, vbExclamation, "Virheilmo"
    CommandButton2.Enabled = True
    Select Case virheet(0)
      Case "1": TextBox1.SetFocus: Exit Sub
      Case "2": TextBox2.SetFocus: Exit Sub
      Case "3": TextBox3.SetFocus: Exit Sub
    End Select
  Else
    Open "c:\ftpYhteys.bat" For Output As #1
    Print #1, "ftp.exe -s:c:\ftpKomento.dat"
    Print #1, "exit": Close #1
    fname = "c:\ftpYhteys.bat"
    tsekkaaStatus (fname)
    Dim hlpStr As String
    Open "c:\ftpKomento.dat" For Input As #1
    hlpStr = Input$(LOF(1), 1): Close #1
    For i = 1 To Len(hlpStr)
      If LCase(Mid(hlpStr, i, 5)) = "quote" Then
        hlpStr = Left(hlpStr, i - 1) & _
        "ls \*.* c:\ftpPalaute.dat" & _
        Right(hlpStr, Len(hlpStr) - (i + 4))
        Exit For
      End If
    Next i
    Open "c:\ftpKomento.dat" For Output As #1
    Print #1, hlpStr: Close #1: hlpStr = ""
    fname = "c:\ftpKomento.dat"
    tsekkaaStatus (fname)
    Shell "c:\ftpYhteys.bat", vbHide
    fname = "c:\ftpPalaute.dat"
    tsekkaaStatus (fname)
    lue_ftpPalaute (1)
  End If
  tappolaskuri
  CommandButton2.Enabled = True
  jatka = True
  palvelin = TextBox1.Text
  portti = TextBox2.Text
  tunnus = TextBox3.Text
  salasana = TextBox4.Text
  Unload Me
End Sub

Private Sub TextBox1_Change()
  If Len(TextBox1.Text) = 1 _
    And TextBox1.Text = "." Or _
    Len(TextBox1.Text) = 1 And _
    IsNumeric(TextBox1.Text) Then
    TextBox1.Text = ""
  End If
  If InStr(TextBox1.Text, "..") > 0 Then
    TextBox1.Text = Replace(TextBox1.Text, "..", ".")
  End If
End Sub

Private Sub TextBox1_KeyUp(ByVal _
KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
   For i = 0 To 255
     Select Case i
       Case 0 To 45, 47, 59 To 96, 123 To 255
       TextBox1.Text = Replace(TextBox1.Text, CStr(Chr(i)), "")
    End Select
  Next
End Sub

Private Sub TextBox2_Change()
If Not IsNumeric(Right(TextBox2.Text, 1)) Then
 Select Case Len(TextBox2.Text)
   Case 1
     TextBox2.Text = ""
   Case Is > 1
     TextBox2.Text = Left(TextBox2.Text, _
     Len(TextBox2.Text) - 1)
  End Select
 End If
End Sub

Private Sub TextBox2_KeyUp(ByVal _
KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  TextBox2.SelStart = Len(TextBox2.Text)
  If TextBox2.Text = "21" Then
    Label2.Visible = True
  Else: Label2.Visible = False
  End If
End Sub

Sub tsekkaa_boxit(ByVal idx As Integer)
   Select Case idx
   Case 1
   For i = 1 To Len(TextBox1.Text)
     If Mid(TextBox1.Text, i, 1) = "." Then
       j = j + 1
       If j > 3 Then
         MsgBox "palvelin-osoite on virheellinen ", _
         vbExclamation, "Virheinfo"
         TextBox1.SetFocus: virhe = True: Exit Sub
       End If
     End If
   Next i
   If Right(TextBox1.Text, 1) = "." Then
     MsgBox _
    "palvelin-osoite ei voi päättyä pisteeseen", _
    vbExclamation, "Virheinfo"
     TextBox1.SetFocus: virhe = True: Exit Sub
   ElseIf Len(TextBox1.Text) = 0 Then
     MsgBox "palvelin-osoite puuttuu ", vbExclamation, "Virheinfo"
     TextBox1.SetFocus: virhe = True: Exit Sub
   ElseIf Len(TextBox1.Text) > 0 And Len(TextBox1.Text) < 6 Or _
   Len(TextBox1.Text) > 0 And InStr(TextBox1.Text, ".") = 0 Then
     MsgBox "palvelin-osoite on virheellinen ", _
     vbExclamation, "Virheinfo"
    TextBox1.SetFocus: virhe = True: Exit Sub
   End If
   Case 2
   If CLng(TextBox2.Text) < 21 Then
     MsgBox "puuttuva tai virheellinen parametri (portti)" & _
     "palautetaan ftp-portin oletusarvo", _
     vbExclamation, "Virheinfo"
     TextBox2.Text = "21"
     Label2.Visible = True
     TextBox2.SetFocus: virhe = True: Exit Sub
   End If
    Case 3
      If Len(TextBox3.Text) = 0 Then
        MsgBox "Käyttäjätunnus puuttuu", _
        vbExclamation, "Virheinfo"
        TextBox3.SetFocus: virhe = True: Exit Sub
      End If
    Case 4
      If Len(TextBox4.Text) = 0 Then
        MsgBox "Salasana puuttuu", _
        vbExclamation, "Virheinfo"
        TextBox4.SetFocus: virhe = True: Exit Sub
      End If
  End Select
End Sub

Private Sub CommandButton1_Click()
  jatka = False: Unload Me
End Sub

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

Sub tsekkaaStatus(ByVal fname As String)
  On Error Resume Next
  Open fname For Input As #1
    If Err > 0 Then
      Err.Clear: Viive 0.25: tsekkaaStatus (fname)
    End If
  Close #1
  On Error GoTo 0
End Sub

Sub lue_ftpPalaute(ByRef tapaus As Integer)
  Dim palaute As String
  On Error Resume Next
  Open "c:\ftpPalaute.dat" For Input As #1
  If Err > 0 Then
    Err.Clear: Viive 0.25: lue_ftpPalaute (tapaus)
  End If
  Viive 1
  Select Case tapaus
    Case 0
      palaute = Input$(LOF(1), 1): Close #1
      ReDim virheet(0) As String
      If InStr(palaute, "ftp> Kohteeseen Tuntematon") > 0 Then
        virheet(UBound(virheet)) = "1"
        ReDim Preserve virheet(UBound(virheet) + 1)
      End If
      If palaute = "ftp> Kohteeseen" Then
        virheet(UBound(virheet)) = "2"
        ReDim Preserve virheet(UBound(virheet) + 1)
      End If
      If InStr(palaute, "incorrect") > 0 Then
        virheet(UBound(virheet)) = "3"
        ReDim Preserve virheet(UBound(virheet) + 1)
      End If
      palaute = ""
    Case 1
      ReDim rKansiot(0) '[k]varoiks...[/k]
      Do While Not EOF(1)
        Input #1, rKansiot(UBound(rKansiot))
        ReDim Preserve rKansiot(UBound(rKansiot) + 1)
      Loop
     Case 2
      uppaus = Input$(LOF(1), 1): Close #1
      Viive 1
  End Select
  Close #1
End Sub

Sub tapa_tempData(ByVal fname As String)
  On Error Resume Next
  Kill fname
  If Err > 0 Then
     Err.Clear: Viive 0.25: tapa_tempData (fname)
  End If
End Sub

Sub tappolaskuri()
 Static laskuri As Integer
  laskuri = 0
  For laskuri = 1 To 3
    Select Case laskuri
      Case 1: tapa_tempData ("c:\ftpYhteys.bat")
      Case 2: tapa_tempData ("c:\ftpKomento.dat")
      Case 3: tapa_tempData ("c:\ftpPalaute.dat")
    End Select
  Next laskuri
End Sub

Option Explicit

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 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 InternetWriteFile Lib "wininet.dll" _
  (ByVal hFile As Long, ByVal sBuffer As String, _
  ByVal lNumberOfBytesToRead As Long, _
  lNumberOfBytesRead As Long) As Integer

Private Declare Function FtpOpenFile Lib "wininet.dll" Alias _
  "FtpOpenFileA" (ByVal hFtpSession As Long, _
  ByVal sFileName As String, ByVal lAccess As Long, _
  ByVal lFlags As Long, ByVal lContext As Long) As Long

Private Declare Function InternetCloseHandle Lib "wininet.dll" _
  (ByVal hInet As Long) As Integer

  Dim yhteys As Long, avaa As Long
  Dim hFilu As Long, z As Integer


Private Sub Command1_Click()
  Dim filu As String

  'avataan filu servulla
  filu = txtF & String(5, 0)
  hFilu = FtpOpenFile(yhteys, filu, 1073741824, 2&, 0&)

  DoEvents
  Debug.Print Err.LastDllError

  z = InternetWriteFile(hFilu, txtW, Len(txtW), Len(txtW))
  DoEvents
  Debug.Print Err.LastDllError

End Sub

Private Sub Form_Load()
  Dim tn As String, pw As String
  Dim blnRC As Integer, ftpp As String

  avaa = InternetOpen("avaus", 1, vbNullString, vbNullString, 0)
  ftpp = "ftppalvelin"
  tn = "ktunnus"
  pw = "salasana"
  yhteys = InternetConnect(avaa, ftpp, 21, tn, pw, 1, 0, 0)

End Sub

Private Sub Form_Unload(Cancel As Integer)

  InternetCloseHandle yhteys
  InternetCloseHandle avaa

End Sub

'formille:Inet kontrolli, pari textboxia & nappi
Private Sub Form_Load()
  Me.Caption = "Kamaa nettiin..."
  Me.Command1.Caption = "Lähetä"
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  DoEvents
  If Inet1.StillExecuting Then Cancel = True
End Sub

Private Sub Command1_Click()
  Select Case Command1.Caption
    Case "Lähetä"
      If Text1 <> "" And Text2 <> "" Then
        Dim filu As String,
        filu = "c:\filu.txt"
        filuStr = Text1 & vbCrLf & Text2
        Open filu For Output As #1
        Print #1, filuStr: Close #1
        tsekkaa (filu)
        With Inet1
                 'tähän alle tulee 'sun' ftp-palvelimes osoite
          .URL = "ftp-palvelin"
                      'tähän alle tulee sun ftp-käyttäjätunnukses
          .UserName = "käyttäjätunnus"
                      'tähän alle tulee sun ftp-salasanas
          .Password = "salasana"
          .AccessType = icDirect
          .Protocol = icFTP
          .RemotePort = 21
          .Execute .URL, "PUT " & filu & " /testi.txt"
          Do While .StillExecuting: DoEvents: Loop
          .Execute .URL, "CLOSE"
        End With
        Kill filu: Text1 = "": Text2 = "":
        Me.Caption = "Tesekataan netistä..."
        Command1.Caption = "Tsekkaa"
      Else: MsgBox "Täyttele boxit!", vbExclamation, "Viestiloota"
        If Text1 = "" Then
          Text1.SetFocus
        Else: Text2.SetFocus
        End If
        Exit Sub
      End If
    Case "Tsekkaa"
           'tähän alle tulee sun selaimes polku ja .exe nimi
     Shell "C:\Program Files\Internet Explorer\iexplore.exe " & _
           "http://www.palvelin.com/sivusto/testi.txt", vbMaximizedFocus
 'tähän ylle 'sun' www.palvelimen osoite/kotisivukansio/testi.txt
     Me.Caption = "Kamaa nettiin..."
     Command1.Caption = "Lähetä"
  End Select
End Sub

Sub tsekkaa(filu)
  On Error Resume Next
  Open filu For Input As #1
  If Err > 0 Then
   Err.Clear: tsekkaa (filu)
  End If
  Close #1
  On Error GoTo 0
End Sub