VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "HttpTranz"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Dim IPName As String
Dim Anfor As String
Dim HeaderCompl As Boolean
Dim DestinationPath As String
Dim LFileSize As Long
Dim StartTime As Single
Dim FreeFileH As Integer
Dim FileFinger As Long
Dim NoLen As Boolean
Dim LastServerIP As String
Dim LastServerPort As Long

Public State As Integer
Public Buffer As String
Public FileSize As Long

Event Connected()
Event Error(ErrorDescr As String)
Event DownloadCompleat()
Event ConnectionClosed()
Event RecPaket(Bytes As Long, Speed As Long)

Private WithEvents wins As CSocket
Attribute wins.VB_VarHelpID = -1

Public Sub TimerEvent(TimerID As Integer)
  RaiseEvent Error("Time out")
  If wins.State > 1 Then
    CloseConnection
  End If
End Sub


Public Sub LoadFromURL(wURL As String, Optional DestPath As String)
  Dim PortN As Long
  Dim I As Integer
  Dim I2 As Integer
  Dim I3 As Integer
  StartTime = Timer
  HeaderCompl = False
  NoLen = False
  Buffer = ""
  FileFinger = 0
  FreeFileH = 0
  State = 1
  DestinationPath = DestPath
  If UCase(Left(wURL, 7)) = "HTTP://" Then I = 7
  I2 = InStr(I + 1, wURL, ":")
  I3 = InStr(I + 1, wURL, "/")
  If I3 = 0 Then I3 = Len(wURL) + 1
  If I2 = 0 Or I2 > I3 Then
    I2 = I3
    PortN = 80
  Else
    PortN = Val(Mid(wURL, I2 + 1, I3 - I2 - 1))
  End If
  If I2 = 0 Then I2 = Len(wURL) + 2
  IPName = Mid(wURL, I + 1, I2 - I - 1)
  If I3 = Len(wURL) + 1 Then
    Anfor = "/"
  Else
    Anfor = Right(wURL, Len(wURL) - I3 + 1)
  End If

  If LastServerIP <> IPName Or LastServerPort <> PortN Or wins.State <> 4 Then
    Do Until wins.State = sockClosed
      wins.Disconnect
    Loop
    wins.LocalPort = 0
    wins.Connect IPName, PortN
    LastServerIP = IPName
    LastServerPort = PortN
    StartTimer Me, 15000, 1
  Else
    SendRequest
  End If
End Sub

Private Sub wins_Closed()
  If NoLen = True Then
    RaiseEvent DownloadCompleat
  ElseIf State = 2 Then
    RaiseEvent Error("Server closed connection")
  End If
  CloseConnection
End Sub

Public Sub CloseConnection()
  If FreeFileH > 0 Then
    Close FreeFileH
    FreeFileH = 0
    On Error Resume Next
    Kill DestinationPath
    On Error GoTo 0
  End If
  KillTimerByID 1, Me
  Do Until wins.State = sockClosed
    wins.Disconnect
  Loop
  State = 0
  RaiseEvent ConnectionClosed
End Sub

Private Sub wins_Connected()
  SendRequest
End Sub

Private Sub SendRequest()
  Dim HttpRe As String
  State = 2
  RaiseEvent Connected
  HttpRe = "GET " + Anfor + " HTTP/1.0" + Chr(13) + Chr(10)
  HttpRe = HttpRe + "Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*" + Chr(13) + Chr(10)
  HttpRe = HttpRe + "Accept-Language: de" + Chr(13) + Chr(10)
  HttpRe = HttpRe + "Accept-Encoding: gzip, deflate" + Chr(13) + Chr(10)
  HttpRe = HttpRe + "User-Agent: Mozilla/4.0 (compatible; " + uAppName + "-" + "Update)" + Chr(13) + Chr(10)
  HttpRe = HttpRe + "Host: " + IPName + Chr(13) + Chr(10)
  HttpRe = HttpRe + "Connection: Keep-Alive" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
  wins.SendData HttpRe
  Buffer = ""
  StartTimer Me, 15000, 1
End Sub

Private Sub WinS_DataArrival()
  Dim I As Long
  Dim I2 As Long
  Dim I3 As Long
  Dim BinData() As Byte
  
  wins.Recive BinData
  
  StartTimer Me, 15000, 1
  LFileSize = LFileSize + UBound(BinData) + 1
  Buffer = Buffer + StrConv(BinData, vbUnicode)
  
  If Len(Buffer) = 0 Then Exit Sub
  If HeaderCompl = False Then
    I3 = InStr(1, Buffer, vbNewLine + vbNewLine)
    If I3 > 0 Then
      HeaderCompl = True
      I = InStr(1, Buffer, "Location: ", vbTextCompare)
      If I > 0 Then
        I2 = InStr(I, Buffer, Chr(13) + Chr(10))
        LoadFromURL Mid(Buffer, I + 10, I2 - I - 10), DestinationPath
        Exit Sub
      End If
      
      I = InStr(1, Buffer, " ")
      I2 = InStr(I + 1, Buffer, " ")
      
      If Val(Mid(Buffer, I + 1, I2 - I - 1)) <> 200 Then
        I = InStr(I2 + 1, Buffer, vbNewLine)
        RaiseEvent Error(Mid(Buffer, I2 + 1, I - I2 - 1))
        CloseConnection
        Exit Sub
      End If
      
      I = InStr(1, Buffer, "Content-Length: ", vbTextCompare)
      If I > 0 Then
        I2 = InStr(I, Buffer, Chr(13) + Chr(10))
        FileSize = Val(Mid(Buffer, I + 16, I2 - I - 16))
      Else
        NoLen = True
      End If
      Buffer = Mid(Buffer, I3 + 4)
      LFileSize = Len(Buffer)
    End If
  End If
  
  If HeaderCompl = True Then
    If Len(DestinationPath) > 0 Then
      If FreeFileH = 0 Then
        FreeFileH = FreeFile
        On Error Resume Next
        Open DestinationPath For Binary As #FreeFileH
        If Err <> 0 Then
          MsgBox Err.Description + vbNewLine + "Vergewissern Sie sich, dass Sie Schreibrechte für den Ordner haben.", vbCritical
          CloseConnection
          Exit Sub
        End If
        On Error GoTo 0
      End If
      If Len(Buffer) > CDbl(16) * 1024 Then
        Put FreeFileH, FileFinger + 1, Buffer
        FileFinger = FileFinger + Len(Buffer)
        Buffer = ""
        If Timer > StartTime Then I = LFileSize / (Timer - CDbl(StartTime)) Else I = 0
        RaiseEvent RecPaket(LFileSize, I)
      End If
    Else
      If Timer > StartTime Then I = LFileSize / (Timer - CDbl(StartTime)) Else I = 0
      RaiseEvent RecPaket(LFileSize, I)
    End If
    If FileSize = LFileSize Then
      If Len(Buffer) > 0 And FreeFileH > 0 Then Put FreeFileH, FileFinger + 1, Buffer
      If FreeFileH > 0 Then Close FreeFileH: FreeFileH = 0
      State = 3
      RaiseEvent DownloadCompleat
      KillTimerByID 1, Me
    End If
  End If
End Sub

Private Sub Class_Initialize()
  Set wins = New CSocket
End Sub

Private Sub Class_Terminate()
  KillTimerByID 1, Me
  CloseConnection
  Set wins = Nothing
End Sub
