home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD13434152001.psc / DownloadForm.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2000-09-12  |  15.1 KB  |  429 lines

  1. VERSION 5.00
  2. Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
  3. Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
  4. Object = "{48E59290-9880-11CF-9754-00AA00C00908}#1.0#0"; "MSINET.OCX"
  5. Begin VB.Form DownloadForm 
  6.    BorderStyle     =   3  'Fixed Dialog
  7.    ClientHeight    =   3540
  8.    ClientLeft      =   45
  9.    ClientTop       =   330
  10.    ClientWidth     =   5520
  11.    FontTransparent =   0   'False
  12.    HasDC           =   0   'False
  13.    Icon            =   "DownloadForm.frx":0000
  14.    KeyPreview      =   -1  'True
  15.    LinkTopic       =   "Form1"
  16.    MaxButton       =   0   'False
  17.    ScaleHeight     =   3540
  18.    ScaleWidth      =   5520
  19.    Begin InetCtlsObjects.Inet Inet1 
  20.       Left            =   0
  21.       Top             =   2880
  22.       _ExtentX        =   1005
  23.       _ExtentY        =   1005
  24.       _Version        =   393216
  25.    End
  26.    Begin MSComctlLib.ProgressBar ProgressBar 
  27.       Height          =   225
  28.       Left            =   120
  29.       TabIndex        =   4
  30.       Top             =   1485
  31.       Width           =   5235
  32.       _ExtentX        =   9234
  33.       _ExtentY        =   397
  34.       _Version        =   393216
  35.       Appearance      =   1
  36.    End
  37.    Begin MSComCtl2.Animation Animation1 
  38.       Height          =   615
  39.       Left            =   120
  40.       TabIndex        =   3
  41.       TabStop         =   0   'False
  42.       Top             =   0
  43.       Width           =   4695
  44.       _ExtentX        =   8281
  45.       _ExtentY        =   1085
  46.       _Version        =   393216
  47.       FullWidth       =   313
  48.       FullHeight      =   41
  49.    End
  50.    Begin VB.CommandButton CancelButton 
  51.       Cancel          =   -1  'True
  52.       Caption         =   "Cancel"
  53.       CausesValidation=   0   'False
  54.       Default         =   -1  'True
  55.       Height          =   375
  56.       Left            =   2197
  57.       TabIndex        =   0
  58.       Top             =   3050
  59.       Width           =   1215
  60.    End
  61.    Begin VB.Label RateLabel 
  62.       Caption         =   "RateLabel"
  63.       Height          =   255
  64.       Left            =   1560
  65.       TabIndex        =   10
  66.       Top             =   2400
  67.       Width           =   3615
  68.    End
  69.    Begin VB.Label TransferRate 
  70.       Caption         =   "Transfer rate:"
  71.       Height          =   255
  72.       Left            =   120
  73.       TabIndex        =   9
  74.       Top             =   2400
  75.       Width           =   1575
  76.    End
  77.    Begin VB.Label ToLabel 
  78.       AutoSize        =   -1  'True
  79.       Caption         =   "ToLabel"
  80.       Height          =   195
  81.       Left            =   1560
  82.       TabIndex        =   8
  83.       Top             =   2100
  84.       Width           =   585
  85.    End
  86.    Begin VB.Label DownloadTo 
  87.       Caption         =   "Download to:"
  88.       Height          =   255
  89.       Left            =   120
  90.       TabIndex        =   7
  91.       Top             =   2100
  92.       Width           =   1575
  93.    End
  94.    Begin VB.Label TimeLabel 
  95.       Caption         =   "TimeLabel"
  96.       Height          =   255
  97.       Left            =   1560
  98.       TabIndex        =   6
  99.       Top             =   1800
  100.       Width           =   3855
  101.    End
  102.    Begin VB.Label SourceLabel 
  103.       AutoSize        =   -1  'True
  104.       Caption         =   "SourceLabel"
  105.       Height          =   195
  106.       Left            =   120
  107.       TabIndex        =   5
  108.       Top             =   1200
  109.       Width           =   900
  110.    End
  111.    Begin VB.Label EstimatedTimeLeft 
  112.       Caption         =   "Estimated time left:"
  113.       Height          =   255
  114.       Left            =   120
  115.       TabIndex        =   2
  116.       Top             =   1800
  117.       Width           =   1455
  118.    End
  119.    Begin VB.Label StatusLabel 
  120.       Caption         =   "StatusLabel"
  121.       Height          =   195
  122.       Left            =   120
  123.       TabIndex        =   1
  124.       Top             =   915
  125.       Width           =   5235
  126.    End
  127. Attribute VB_Name = "DownloadForm"
  128. Attribute VB_GlobalNameSpace = False
  129. Attribute VB_Creatable = False
  130. Attribute VB_PredeclaredId = True
  131. Attribute VB_Exposed = False
  132. Private CancelSearch As Boolean
  133. Public DownloadSuccess As Boolean
  134. Public Function DownloadFile(strURL As String, _
  135.                              strDestination As String, _
  136.                              Optional UserName As String = Empty, _
  137.                              Optional Password As String = Empty) _
  138.                              As Boolean
  139. ' Funtion DownloadFile: Download a file via HTTP
  140. ' Author:   Jeff Cockayne
  141. ' Inputs:   strURL String; the source URL of the file
  142. '           strDestination; valid Win95/NT path to where you want it
  143. '           (i.e. "C:\Program Files\My Stuff\Purina.pdf")
  144. ' Returns:  Boolean; Was the download successful?
  145. Const CHUNK_SIZE As Long = 1024 ' Download chunk size
  146. Const ROLLBACK As Long = 4096   ' Bytes to roll back on resume
  147.                                 ' You can be less conservative,
  148.                                 ' and roll back less, but I
  149.                                 ' don't recommend it.
  150. Dim bData() As Byte             ' Data var
  151. Dim blnResume As Boolean        ' True if resuming download
  152. Dim intFile As Integer          ' FreeFile var
  153. Dim lngBytesReceived As Long    ' Bytes received so far
  154. Dim lngFileLength As Long       ' Total length of file in bytes
  155. Dim lngX                        ' Temp long var
  156. Dim lastTime As Single          ' Time last chunk received
  157. Dim sglRate As Single           ' Var to hold transfer rate
  158. Dim sglTime As Single           ' Var to hold time remaining
  159. Dim strFile As String           ' Temp filename var
  160. Dim strHeader As String         ' HTTP header store
  161. Dim strHost As String           ' HTTP Host
  162. On Local Error GoTo InternetErrorHandler
  163. ' Start with Cancel flag = False
  164. CancelSearch = False
  165. ' Get just filename (without dirs) for display
  166. strFile = ReturnFileOrFolder(strDestination, True)
  167. strHost = ReturnFileOrFolder(strURL, True, True)
  168.               
  169. SourceLabel = Empty
  170. TimeLabel = Empty
  171. ToLabel = Empty
  172. RateLabel = Empty
  173. ' Show the download status form
  174. Me.Show
  175. ' Move form into view
  176. Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
  177. StartDownload:
  178. If blnResume Then
  179.     StatusLabel = "Resuming download..."
  180.     lngBytesReceived = lngBytesReceived - ROLLBACK
  181.     If lngBytesReceived < 0 Then lngBytesReceived = 0
  182.     StatusLabel = "Getting file information..."
  183. End If
  184. ' Give the system time to update the form gracefully
  185. DoEvents
  186. ' Download file
  187. With Inet1
  188.     .URL = strURL
  189.     .UserName = UserName
  190.     .Password = Password
  191.     If blnResume Then
  192.         .Execute , "GET", , "Range: bytes=" & CStr(lngBytesReceived) & "-" & vbCrLf
  193.     Else
  194.         .Execute , "GET"
  195.     End If
  196. End With
  197. ' While initiating connection, yield CPU to Windows
  198. While Inet1.StillExecuting
  199.     DoEvents
  200.     ' If user pressed Cancel button on StatusForm
  201.     ' then fail, cancel, and exit this download
  202.     If CancelSearch Then
  203.         GoTo ExitDownload
  204.     End If
  205. StatusLabel = "Saving:"
  206. SourceLabel = strHost & " from " & Inet1.RemoteHost
  207. ToLabel = strDestination
  208. If ToLabel.Left + ToLabel.Width > ProgressBar.Width Then
  209.     For lngX = (Len(ToLabel) \ 2) - 2 To 1 Step -1
  210.         ToLabel = Left(ToLabel, lngX) & "..." & Right(ToLabel, lngX)
  211.         If ToLabel.Left + ToLabel.Width <= ProgressBar.Width Then Exit For
  212.     Next
  213. End If
  214. ' Get first header ("HTTP/X.X XXX ...")
  215. strHeader = Inet1.GetHeader
  216. ' Trap common HTTP response codes
  217. Select Case Mid(strHeader, 10, 3)
  218.     Case "200"  ' OK
  219.         ' If resuming, however, this is a failure
  220.         If blnResume Then
  221.             ' Delete partially downloaded file
  222.             Kill strDestination
  223.             ' Prompt
  224.             If MsgBox("The server is unable to resume this download." & _
  225.                       vbCr & vbCr & _
  226.                       "Do you want to continue anyway?", _
  227.                       vbExclamation + vbYesNo, _
  228.                       "Unable to Resume Download") = vbYes Then
  229.                     ' Yes - continue anyway:
  230.                     ' Set resume flag to False
  231.                     blnResume = False
  232.                 Else
  233.                     ' No - cancel
  234.                     CancelSearch = True
  235.                     GoTo ExitDownload
  236.                 End If
  237.             End If
  238.             
  239.     Case "206"  ' 206=Partial Content, which is GREAT when resuming!
  240.     Case "204"  ' No content
  241.         MsgBox "Nothing to download!", _
  242.                vbInformation, _
  243.                "No Content"
  244.         GoTo ExitDownload
  245.         
  246.     Case "401"  ' Not authorized
  247.         MsgBox "Authorization failed!", _
  248.                vbCritical, _
  249.                "Unauthorized"
  250.         GoTo ExitDownload
  251.     Case "404"  ' File Not Found
  252.         MsgBox "The file, " & _
  253.                """" & Inet1.URL & """" & _
  254.                " was not found!", _
  255.                vbCritical, _
  256.                "File Not Found"
  257.         GoTo ExitDownload
  258.         
  259.     Case vbCrLf ' Empty header
  260.         MsgBox "Cannot establish connection." & vbCr & vbCr & _
  261.                "Check your Internet connection and try again.", _
  262.                vbExclamation, _
  263.                "Cannot Establish Connection"
  264.         GoTo ExitDownload
  265.         
  266.     Case Else
  267.         ' Miscellaneous unexpected errors
  268.         strHeader = Left(strHeader, InStr(strHeader, vbCr))
  269.         If strHeader = Empty Then strHeader = "<nothing>"
  270.         MsgBox "The server returned the following response:" & vbCr & vbCr & _
  271.                strHeader, _
  272.                vbCritical, _
  273.                "Error Downloading File"
  274.         GoTo ExitDownload
  275. End Select
  276. ' Get file length with "Content-Length" header request
  277. If blnResume = False Then
  278.     ' Set timer for gauging download speed
  279.     lastTime = Timer - 1
  280.     strHeader = Inet1.GetHeader("Content-Length")
  281.     lngFileLength = Val(strHeader)
  282.     If lngFileLength = 0 Then
  283.         GoTo ExitDownload
  284.     End If
  285. End If
  286. ' Check for available disk space first...
  287. ' If on a physical or mapped drive. Can't with a UNC path.
  288. If Mid(strDestination, 2, 2) = ":\" Then
  289.     If DiskFreeSpace(Left(strDestination, _
  290.                           InStr(strDestination, "\"))) < lngFileLength Then
  291.         ' Not enough free space to download file
  292.         MsgBox "There is not enough free space on disk for this file." _
  293.                & vbCr & vbCr & "Please free up some disk space and try again.", _
  294.                vbCritical, _
  295.                "Insufficient Disk Space"
  296.         GoTo ExitDownload
  297.     End If
  298. End If
  299. ' Prepare display
  300. ' Progress Bar
  301. With ProgressBar
  302.     .Value = 0
  303.     .Max = lngFileLength
  304. End With
  305. ' Play the AVI;
  306. ' Note: it will only play when this form
  307. '       is compiled into EXE.
  308. With Animation1
  309.     .AutoPlay = True
  310.     SendMessage .hWnd, ACM_OPEN, ByVal App.hInstance, ByVal "AVIDOWNLOAD"
  311. End With
  312. ' Give system a chance to show AVI
  313. DoEvents
  314. ' Reset bytes received counter if not resuming
  315. If blnResume = False Then lngBytesReceived = 0
  316. On Local Error GoTo FileErrorHandler
  317. ' Create destination directory, if necessary
  318. strHeader = ReturnFileOrFolder(strDestination, False)
  319. If Dir(strHeader, vbDirectory) = Empty Then
  320.     MkDir strHeader
  321. End If
  322. ' If no errors occurred, then spank the file to disk
  323. intFile = FreeFile()        ' Set intFile to an unused file.
  324. ' Open a file to write to.
  325. Open strDestination For Binary Access Write As #intFile
  326. ' If resuming, then seek byte position in downloaded file
  327. ' where we last left off...
  328. If blnResume Then Seek #intFile, lngBytesReceived + 1
  329.     ' Get chunks...
  330.     bData = Inet1.GetChunk(CHUNK_SIZE, icByteArray)
  331.     Put #intFile, , bData   ' Put it into our destination file
  332.     If CancelSearch Then
  333.         Exit Do
  334.     End If
  335.     lngBytesReceived = lngBytesReceived + UBound(bData, 1) + 1
  336.     sglRate = lngBytesReceived / (Timer - lastTime)
  337.     sglTime = (lngFileLength - lngBytesReceived) / sglRate
  338.     TimeLabel = FormatTime(sglTime) & _
  339.                    " (" & _
  340.                    FormatFileSize(lngBytesReceived) & _
  341.                    " of " & _
  342.                    FormatFileSize(lngFileLength) & _
  343.                    " copied)"
  344.     RateLabel = Format(sglRate / 1024, "###,##0.0") & " KB/Sec"
  345.     ProgressBar.Value = lngBytesReceived
  346.     Me.Caption = Format((lngBytesReceived / lngFileLength), "##0%") & _
  347.                  " of " & strFile & " Completed"
  348. Loop While UBound(bData, 1) > 0       ' Loop while there's still data...
  349. Close #intFile
  350. ExitDownload:
  351. ' Success if the # of bytes transferred = content length
  352. If lngBytesReceived = lngFileLength Then
  353.     StatusLabel = "Download completed!"
  354.     DownloadSuccess = True
  355.     If Dir(strDestination) = Empty Then
  356.         CancelSearch = True
  357.     Else
  358.         ' Resume? (If not cancelled)
  359.         If CancelSearch = False Then
  360.             If MsgBox("The connection with the server was reset." & _
  361.                       vbCr & vbCr & _
  362.                       "Click ""Retry"" to resume downloading the file." & _
  363.                       vbCr & "(Approximate time remaining: " & FormatTime(sglTime) & ")" & _
  364.                       vbCr & vbCr & _
  365.                       "Click ""Cancel"" to cancel downloading the file.", _
  366.                       vbExclamation + vbRetryCancel, _
  367.                       "Download Incomplete") = vbRetry Then
  368.                     ' Yes
  369.                     blnResume = True
  370.                     GoTo StartDownload
  371.             End If
  372.         End If
  373.     End If
  374.     ' No or unresumable failure:
  375.     ' Delete partially downloaded file
  376.     Kill strDestination
  377.     DownloadSuccess = False
  378. End If
  379. CleanUp:
  380. ' Close AVI
  381. Animation1.Close
  382. ' Make sure that the Internet connection is closed...
  383. Inet1.Cancel
  384. ' ...and exit this function
  385. Unload Me
  386. Exit Function
  387. InternetErrorHandler:
  388.     ' This is a catch-all that hasn't been fired once in the
  389.     ' almost 2 yrs this code has existed, so...
  390.     CancelSearch = True
  391.     MsgBox "Error: " & Err.Description & " occurred.", _
  392.            vbCritical, _
  393.            "Error Downloading File"
  394.     Resume Next
  395. FileErrorHandler:
  396.     If Err.Number <> 9 Then
  397.         ' Err# 9 occurs when UBound(bData,1) < 0
  398.         MsgBox "Cannot write file to disk." & _
  399.                vbCr & vbCr & _
  400.                "Error " & Err.Number & ": " & Err.Description, _
  401.                vbCritical, _
  402.                "Error Downloading File"
  403.         CancelSearch = True
  404.     End If
  405.     Err.Clear
  406.     GoTo CleanUp
  407. End Function
  408. Private Sub CancelButton_Click()
  409.     Inet1.Cancel
  410.     CancelSearch = True
  411.     Unload Me
  412. End Sub
  413. Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  414. ' For some reason, the Cancel=True and Default=True
  415. ' Properties of the "Cancel" button are not working...
  416. ' This is the first time that's ever happened to me.
  417. ' Any ideas?
  418. If KeyCode = vbKeyEscape Then CancelButton_Click
  419. End Sub
  420. Private Sub Form_Load()
  421. ' Move form off-screen until it is ready (completely drawn)
  422. Me.Move -Me.Width, -Me.Height
  423. End Sub
  424. Private Sub Form_Unload(Cancel As Integer)
  425.     ' Move form off-screen so that it disappears "instantly"
  426.     Me.Move -Me.Width, -Me.Height
  427.     DoEvents
  428. End Sub
  429.