frmwebzip.frm

在线ZIP在线ZIP在线ZIP在线ZIP在线ZIP在线ZIP

Private Const SMALL_ICON As Integer = 16
Private Const MAX_PATH = 260

Private Const ILD_TRANSPARENT = &H1       'Display transparent

'ShellInfo Flags
Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_EXETYPE = &H2000
Private Const SHGFI_SYSICONINDEX = &H4000 'System icon index
Private Const SHGFI_LARGEICON = &H0       'Large icon
Private Const SHGFI_SMALLICON = &H1       'Small icon
Private Const SHGFI_SHELLICONSIZE = &H4
Private Const SHGFI_TYPENAME = &H400

Private Const BASIC_SHGFI_FLAGS = SHGFI_TYPENAME _
        Or SHGFI_SHELLICONSIZE Or SHGFI_SYSICONINDEX _
        Or SHGFI_DISPLAYNAME Or SHGFI_EXETYPE

Private Type SHFILEINFO                   'As required by ShInfo
  hIcon As Long
  iIcon As Long
  dwAttributes As Long
  szDisplayName As String * MAX_PATH
  szTypeName As String * 80
End Type


'----------------------------------------------------------
'Functions & Procedures
'----------------------------------------------------------
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _
    (ByVal pszPath As String, _
    ByVal dwFileAttributes As Long, _
    psfi As SHFILEINFO, _
    ByVal cbSizeFileInfo As Long, _
    ByVal uFlags As Long) As Long

Private Declare Function ImageList_Draw Lib "comctl32.dll" _
    (ByVal himl&, ByVal i&, ByVal hdcDest&, _
    ByVal x&, ByVal Y&, ByVal Flags&) As Long


'----------------------------------------------------------
'Private variables
'----------------------------------------------------------
Private ShInfo As SHFILEINFO

Dim WithEvents zipReader As zipReader
Attribute zipReader.VB_VarHelpID = -1
Dim ZipFile As ZipFile
Dim file As file

Dim WithEvents ft As FileTransfer
Attribute ft.VB_VarHelpID = -1
        


Dim nLen As Long
Dim nPos As Long
Dim szThisURL As String
Dim szServer As String
Dim icmpPing As ICMP_ECHO_REPLY



   
Private Function GetIcon(Filename As String) As Long
    '---------------------------------------------------------------------
    'Extract an individual icon
    '---------------------------------------------------------------------
    Dim hLIcon As Long, hSIcon As Long    'Large & Small Icons
    Dim imgObj As ListImage               'Single bmp in imagelist.listimages collection
    Dim r As Long
    
    On Error Resume Next
    
    Dim szFile As String
    szFile = Right(Filename, Len(Filename) - (InStr(Filename, "/")))
    'MsgBox szFile
    'szFile = Filename
    Open szFile For Append As FreeFile: Close
    
    'Get a handle to the small icon
    hSIcon = SHGetFileInfo(szFile, 0&, ShInfo, Len(ShInfo), _
             BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)
    
    If FileLen(szFile) = 0 Then Kill szFile
    
    'MsgBox hSIcon
    
    'If the handle(s) exists, load it into the picture box(es)
    If hSIcon <> 0 Then
      With pic16
        Set .Picture = LoadPicture("")
        .AutoRedraw = True
        r = ImageList_Draw(hSIcon, ShInfo.iIcon, pic16.hdc, 0, 0, ILD_TRANSPARENT)
        .Refresh
      End With
      
    End If
End Function

Private Sub cmdAbout_Click()
    Load frmAbout
    frmAbout.Show
    
End Sub

Private Sub cmdDownload_Click()
    
End Sub

Private Sub cmdGet_Click()
    
    Dim szURL As String
    Dim szHeader As String
    
    szThisURL = cboURL.text
        
    szURL = Replace(LCase(cboURL.text), "http://", "")
    szServer = Trim(Left(szURL, InStr(szURL, "/") - 1))
    
    'Ping the server
    icmpPing.Data = String(32, Int(Rnd * 255) + 1)
    sbStatus.SimpleText = "Status: Reply from " & szServer & " -> " & Ping(szServer, icmpPing) & " ms"
    
    'Check to make sure file exists
    inCheck.Execute "http://" & szURL
Wait1:
    While inCheck.StillExecuting
        DoEvents
    Wend
    If inCheck.StillExecuting Then GoTo Wait1
    
    inCheck.GetChunk 1, icByteArray
    szHeader = inCheck.GetHeader
    If InStr(szHeader, "404 object not found") Then
        sbStatus.SimpleText = "Status: File not found"
        Exit Sub
    End If
    
    'Check to make sure resuming is supported
    'HTTP 1.1
    If Val(Mid(szHeader, 6, 3)) < 1.1 Then
        sbStatus.SimpleText = "Status: Cannot retrieve ZIP information (Cannot find server, or server does not support resuming)"
        Exit Sub
    End If
        
    'Continue
    Set lvFiles.SmallIcons = Nothing
    lvFiles.ListItems.Clear
    iml16.ListImages.Clear
    
    zipReader.Server = Trim(Left(szURL, InStr(szURL, "/") - 1))
    zipReader.Filename = Trim(Right(szURL, Len(szURL) - Len(zipReader.Server)))
        
    If Not ZipFile Is Nothing Then
        Do Until ZipFile.Files.Count = 0
            ZipFile.Files.Remove 1
            DoEvents
        Loop
    End If
        
    Set ZipFile = zipReader.GetFiles()
    
    For Each file In ZipFile.Files
        GetIcon file.Filename
        iml16.ListImages.Add file.Index, , pic16.Image
    Next
    
    Set lvFiles.SmallIcons = iml16
    
    For Each file In ZipFile.Files
        With lvFiles
            .ListItems.Add , , file.Filename
            .ListItems(.ListItems.Count).SubItems(1) = file.Index
            .ListItems(.ListItems.Count).SmallIcon = file.Index
            .ListItems(.ListItems.Count).SubItems(3) = IIf(CLng(file.PackedSize / 1024) >= 1, CLng(file.PackedSize / 1024) & " KB", "<1 KB")
            .ListItems(.ListItems.Count).SubItems(2) = IIf(CLng(file.RealSize / 1024) >= 1, CLng(file.RealSize / 1024) & " KB", "<1 KB")
            .ListItems(.ListItems.Count).SubItems(4) = file.CRC32
            .ListItems(.ListItems.Count).SubItems(5) = file.PacketPosition
        End With
    Next
    
    
End Sub

Private Sub cmdStop_Click()
    zipReader.DLStop
    
End Sub

Private Sub Form_Load()
    Set zipReader = New zipReader
    Set ft = New FileTransfer
    pic16.BackColor = lvFiles.BackColor
    Dim szVer As String
    SocketsInitialize szVer
    sbStatus.SimpleText = "Status: Idle (Winsock version " & szVer & ")"
    
    dlgZip.Flags = cdlOFNOverwritePrompt Or cdlOFNPathMustExist Or cdlOFNReadOnly Or cdlOFNFileMustExist
    
End Sub

Private Sub ft_Progress(ByVal nPercent As Long, ByVal nReceivedTotal As Long)
    pbProgress.Value = nPercent
    
End Sub

Private Sub ft_Status(ByVal szStatus As String)
    sbStatus.SimpleText = "Status: " & szStatus
    If LCase(szStatus) = "download complete" Then pbProgress.Value = 0
    
    
End Sub

Private Sub lvFiles_DblClick()
    Dim file As file
    Set file = ZipFile.Files(lvFiles.SelectedItem.Index)
    szTemp = Right(lvFiles.SelectedItem.text, Len(lvFiles.SelectedItem.text) - (InStr(lvFiles.SelectedItem.text, "/")))
    If Dir(App.Path & "\" & szTemp & ".zip") <> "" Then
        Select Case MsgBox("The file """ & App.Path & "\" & szTemp & ".zip"" already exists. Do you want to overwrite it?", vbQuestion + vbYesNo, "WebZip")
        Case vbYes
            file.SaveAs App.Path & "\" & szTemp & ".zip"
            MsgBox "File saved as """ & App.Path & "\" & szTemp & ".zip""", vbInformation, "WebZip 1.0"
        End Select
    Else
        file.SaveAs App.Path & "\" & szTemp & ".zip"
        MsgBox "File saved as """ & App.Path & "\" & szTemp & ".zip""", vbInformation, "WebZip 1.0"
    End If
    
End Sub

Private Sub tbr_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    If Button.Caption = "Download Zip" Then
        If szThisURL = "" Then
            MsgBox "No ZIP file chosen.", vbExclamation, "WebZip 1.0"
            Exit Sub
        End If
        
        dlgZip.ShowSave
        If Err = 0 Then
            ft.Download szThisURL, dlgZip.Filename
        End If
    ElseIf Button.Caption = "About" Then
        Load frmAbout
        frmAbout.Show
        
    End If
    
End Sub

Private Sub ZIPGet_DLComplete()
    sbStatus.SimpleText = "Status: Download complete"
    pbProgress.Value = 0
    
End Sub

Private Sub ZIPGet_Percent(lPercent As Long)
    pbProgress.Value = lPercent
    
End Sub

Private Sub ZIPGet_StatusChange(lpStatus As String)
    sbStatus.SimpleText = "Status: " & lpStatus
End Sub

Private Sub ZIPGet_TimeLeft(lpTime As String)
    sbStatus.SimpleText = "Status: Downloading ZIP package " & szThisURL & " (" & lpTime & " remaining)"
End Sub

Private Sub timPing_Timer()
    
End Sub

Private Sub zipReader_Inform(ByVal text As String)
    sbStatus.SimpleText = "Status: " & text
    
End Sub

Private Sub zipReader_ProgressChange(ByVal nProg As Integer)
    On Error Resume Next
    pbProgress.Value = nProg
    
End Sub