Planet Source Code Jumbo …e CD Visual Basic 1 to 7/1_2002.ISO/Data/Zips/CODE_UPLOAD170663142001.psc/frmMain.frm

Visual Basic Form | 2001-03-15 | 13.0 KB | 373 lines

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmMain
   Caption         =   "My Multi Downloader"
   ClientHeight    =   4500
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   8535
   LinkTopic       =   "Form1"
   OLEDropMode     =   1  '
   ScaleHeight     =   4500
   ScaleWidth      =   8535
   StartUpPosition =   3  'Windows
   Begin VB.TextBox txtMaxActive
      Height          =   270
      Left            =   1320
      TabIndex        =   17
      Text            =   "20"
      Top             =   3000
      Width           =   375
   End
   Begin MSComDlg.CommonDialog CommonDialog1
      Left            =   3840
      Top             =   3720
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Timer Timer1
      Left            =   3240
      Top             =   3720
   End
   Begin VB.CommandButton cmdClear
      Caption         =   "Clear"
      Height          =   375
      Left            =   7680
      TabIndex        =   15
      Top             =   240
      Width           =   735
   End
   Begin VB.CommandButton cmdRemove
      Caption         =   "Remove"
      Height          =   375
      Left            =   6600
      TabIndex        =   14
      Top             =   240
      Width           =   975
   End
   Begin VB.CheckBox chkOnTop
      Caption         =   "Always on top "
      Height          =   255
      Left            =   6840
      TabIndex        =   13
      Top             =   3000
      Value           =   1  '
      Width           =   1575
   End
   Begin VB.CommandButton cmdChangePath
      Caption         =   "Change"
      Height          =   375
      Left            =   120
      TabIndex        =   12
      Top             =   3720
      Width           =   855
   End
   Begin VB.TextBox txtSavePath
      Height          =   270
      Left            =   1320
      TabIndex        =   11
      Top             =   3360
      Width           =   7095
   End
   Begin VB.TextBox txtExtension
      Height          =   270
      Left            =   5640
      TabIndex        =   9
      Text            =   "au"
      Top             =   3000
      Width           =   615
   End
   Begin VB.CheckBox chkRenameExtension
      Caption         =   "Rename extension:"
      Height          =   375
      Left            =   4320
      TabIndex        =   8
      Top             =   2925
      Width           =   1215
   End
   Begin VB.ListBox listSave
      Height          =   240
      Left            =   3120
      OLEDropMode     =   1  '
      TabIndex        =   7
      Top             =   3000
      Visible         =   0   'False
      Width           =   495
   End
   Begin VB.CommandButton cmdAdd
      Caption         =   "Add"
      Height          =   375
      Left            =   5760
      TabIndex        =   6
      Top             =   240
      Width           =   735
   End
   Begin VB.ComboBox cboURL
      Height          =   300
      Left            =   120
      OLEDropMode     =   1  '
      TabIndex        =   5
      Top             =   240
      Width           =   5535
   End
   Begin VB.ListBox listURL
      Height          =   2040
      Left            =   120
      OLEDropMode     =   1  '
      TabIndex        =   4
      Top             =   720
      Width           =   8295
   End
   Begin VB.CommandButton cmdStop
      Caption         =   "Stop"
      Height          =   375
      Left            =   7560
      TabIndex        =   3
      Top             =   3720
      Width           =   855
   End
   Begin VB.CommandButton cmdStart
      Caption         =   "Start"
      Height          =   375
      Left            =   6600
      TabIndex        =   2
      Top             =   3720
      Width           =   855
   End
   Begin MSComctlLib.ProgressBar ProgressBar1
      Height          =   255
      Left            =   240
      TabIndex        =   1
      Top             =   7200
      Width           =   3495
      _ExtentX        =   6165
      _ExtentY        =   450
      _Version        =   393216
      Appearance      =   1
   End
   Begin MSComctlLib.StatusBar StatusBar
      Align           =   2  '
      Height          =   330
      Left            =   0
      TabIndex        =   0
      Top             =   4170
      Width           =   8535
      _ExtentX        =   15055
      _ExtentY        =   582
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
         NumPanels       =   2
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
            Object.Width           =   5292
            MinWidth        =   5292
         EndProperty
         BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
            Object.Width           =   8819
            MinWidth        =   8819
         EndProperty
      EndProperty
   End
   Begin VB.Label lblMaxActive
      Caption         =   "Max active:"
      Height          =   255
      Left            =   120
      TabIndex        =   16
      Top             =   3000
      Width           =   1095
   End
   Begin VB.Label lblSavePath
      Caption         =   "Save path:"
      Height          =   255
      Left            =   120
      TabIndex        =   10
      Top             =   3375
      Width           =   1095
   End
   Begin VB.Menu mnuPopup
      Caption         =   "Popup"
      Begin VB.Menu mnuPopupFileOpen
         Caption         =   "Open File"
      End
      Begin VB.Menu mnuPopupFileSave
         Caption         =   "Save As"
      End
      Begin VB.Menu bar1
         Caption         =   "-"
      End
      Begin VB.Menu mnuPopupOpenURL
         Caption         =   "Open URL"
      End
      Begin VB.Menu mnuPopupOpenDownload
         Caption         =   "Open Downlaoded File"
      End
   End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'----------------------------------------------------------------------------------------'
' Multi Downloader using multithreadings
' Created by Suk Yong Kim, 03/14/2001
' This project is my first project to upload to the PSC.
' Many persons contribute to create this project
' I really appreicate their efforts and codes and the great server PSC.
' if any question, mail to : [e-mail]
'----------------------------------------------------------------------------------------'
'API Declarations
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
'API  and constant for listbox tool tip
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const LB_ITEMFROMPOINT = &H1A9
Private Const EM_GETLINECOUNT = &HBA
'Flag to diable the list box click event when open a file
Public bDisableClickEvent As Boolean
'Class Module Collection for control of multi threads
Private cThreadControls As New clsThreadings
'Winddow minimum size value
Private sglFixedWidth As Single
Private sglFixedHeight As Single
'put the form on top or take down
Private Sub chkOnTop_Click()
    If chkOnTop.Value = vbChecked Then
        Call putMeOnTop(Me)
    Else
        Call takeMeDown(Me)
    End If
End Sub
'Rename the extension when save to the local folder
Private Sub chkRenameExtension_Click()
    txtExtension.Enabled = IIf(chkRenameExtension.Value = vbChecked, True, False)
End Sub
'Add the text in the combo box  to the list box
Private Sub cmdAdd_Click()
    Call AddURL(cboURL.Text)
End Sub
'To show the current total of list box items
Sub ShowSatus()
    StatusBar.Panels(1).Text = "Total: " & listURL.ListCount
    If listURL.ListIndex < 0 Then
        StatusBar.Panels(2).Text = ""
    Else
        StatusBar.Panels(2).Text = fnGetShortName(listSave.List(listURL.ListIndex))
    End If
End Sub
'Add the URL obtained through drag and drop or combo box to lis box
Function AddURL(ByVal Item As String)
    Dim ItemSave As String
    Item = Trim(Replace(Item, vbCrLf, Space(1))) 'convert vbcrlf to space
    If Len(Item) = 0 Then Exit Function
    If Not IsInList(listURL, Item) Then ' if not in list box, add it
        Dim IsWebURL As Boolean
        If fnIsURL(Item, , , IsWebURL) And IsWebURL Then 'check it is web url, not local url
            cboURL.AddItem Item
            listURL.AddItem Item
        End If
    End If
    Call ShowSatus
    Call ChangeSaveFileName
End Function
Function ChangeSaveFileName()
    'when filenames are same, change it
    'this function is also used to show the list box tool tips and statusbar text
    'which shows thelocal save files names of the selected lisbox item
    'to do this, it use the a hidden list box, listSave
    Dim ItemSaveName As String
    Dim ItemSavePathName As String
    Dim ItemSavePath As String
    listSave.Clear 'Clear the listSave
    ItemSavePath = fnGetPathRemoveEndDelimeter(txtSavePath)
    Dim i As Long
    For i = 0 To listURL.ListCount - 1 'Get local save filenames

        ItemSaveName = fnGetFileName(listURL.List(i), True)
        ItemSavePathName = ItemSavePath & "\" & ItemSaveName

        If IsInList(listSave, ItemSavePathName) Then
            Dim strTempName As String
            Dim strTempExt As String, strTemp As String
            Dim iNum As Integer
            strTempName = fnGetNetFileName(ItemSaveName)
            strTempExt = fnGetExtension(ItemSaveName)
            strTemp = strTempName & "." & strTempExt

            iNum = 1
            Do
               strTemp = ItemSavePath & "\" & strTempName & "(" & iNum & ")" & "." & strTempExt
               iNum = iNum + 1
            Loop Until Not IsInList(listSave, strTemp)

            ItemSavePathName = strTemp
        End If
        'rename the extension if check box is checked
        If chkRenameExtension.Value = vbChecked And Len(txtExtension) > 0 Then
                ItemSavePathName = ItemSavePathName & "." & txtExtension
        End If

        listSave.AddItem ItemSavePathName 'Add the local save filenames
    Next
End Function
Function IsInList(list_box As ListBox, Item As String) 'used to check an item is already in the list box
    Dim i  As Long
    For i = 0 To list_box.ListCount - 1
        If list_box.List(i) = Item Then IsInList = True: Exit For
    Next
End Function
Private Sub cmdChangePath_Click()
    Dim Folder As String
    Call takeMeDown(Me) 'take down the form that the browser for foder window is on the top
    Folder = BrowseForFolder(txtSavePath, "Select the folder to save downloads.")
    If Len(Folder) Then ' if not the cancel button is clicked
        txtSavePath = Folder
        Call ChangeSaveFileName 'change the listSave items to reflect the change of save  path
        If listURL.ListIndex < 0 Then
            StatusBar.Panels(2).Text = ""
        Else
            StatusBar.Panels(2).Text = fnGetShortName(listSave.List(listURL.ListIndex))
        End If
    End If
     'put the form on top if chck box is chekced
    If Me.chkOnTop.Value = vbChecked Then Call putMeOnTop(Me)
End Sub
Private Sub cmdClear_Click()
    listURL.Clear
    Call ShowSatus
End Sub
Private Sub cmdRemove_Click()
    Dim i As Long
    For i = listURL.ListCount - 1 To 0 Step -1
        If listURL.Selected(i) Then
            listURL.RemoveItem i
            Exit For
        End If
    Next
    If i = 0 And listURL.ListCount > 0 Then
        listURL.ListIndex = 0 'select first item
    ElseIf i <= listURL.ListCount - 1 Then
        listURL.ListIndex = i 'select next item
    ElseIf listURL.ListCount > 0 Then 'select last item
        listURL.ListIndex = listURL.ListCount - 1
    End If
    Call ChangeSaveFileName 'refelct the change of list items
    Call ShowSatus
End Sub
Private Sub cmdStart_Click()
    On Error Resume Next
    If listURL.ListCount < 1 Then Exit Sub 'if there is no item to download, exit sub
     'if the save path does not exists
     'ask whether to create i  CaBItem to download, e5        u'ask f the sav,ecke        If list_box.List(i) = Item Then IsInList = True: Exit For
    Next
End Function
EnEnE Then  ThenOemp
     ndexenOemp    S     listURL.ListIndex = i 'select st_Click()
    On Error      =  OX Exit For
    Next
 the sav,eiwnlseiwnlseiwkI8ie6        ItemSavlick()
   br to create i  CaBItems3
ossssl42od'e i  CTsTempName & "." & strTempExt