Visual Basic Source Code

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / extrac / extract.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1995-05-08 | 16.2 KB | 295 lines

VERSION 2.00 Begin Form Extract BackColor = &H00C0C0C0& Caption = "EXTRACTION D'ICONES" ClientHeight = 1995 ClientLeft = 4140 ClientTop = 3990 ClientWidth = 4890 Height = 2400 Icon = EXTRACT.FRX:0000 Left = 4080 LinkTopic = "EXTRACTION D'ICONES" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 1995 ScaleWidth = 4890 Top = 3645 Width = 5010 Begin FileListBox File1 Height = 1980 Left = 90 TabIndex = 10 Top = 2340 Width = 2055 End Begin DirListBox Dir1 Height = 1605 Left = 2280 TabIndex = 9 Top = 2730 Width = 2475 End Begin DriveListBox Drive1 Height = 315 Left = 2280 TabIndex = 8 Top = 2340 Width = 2475 End Begin CommandButton Command3 Caption = "&Liste Fichier" Height = 345 Left = 3030 TabIndex = 7 Top = 870 Width = 1695 End Begin HScrollBar Barre Height = 285 Left = 2130 TabIndex = 6 Top = 1290 Visible = 0 'False Width = 2655 End Begin PictureBox Picture2 Height = 885 Left = 960 ScaleHeight = 855 ScaleWidth = 885 TabIndex = 4 Top = 210 Width = 915 Begin PictureBox Picture1 BackColor = &H00FFFFFF& BorderStyle = 0 'None Height = 480 Left = 210 ScaleHeight = 480 ScaleWidth = 480 TabIndex = 5 Top = 180 Width = 480 End End Begin CommandButton Command2 Caption = "&Quitter" Height = 345 Left = 3060 TabIndex = 3 Top = 90 Width = 1695 End Begin CommandButton Command1 Caption = "&Icone" Height = 345 Left = 3060 TabIndex = 2 Top = 480 Width = 1695 End Begin TextBox Text1 Height = 315 Left = 90 TabIndex = 0 Top = 1650 Width = 4725 End Begin Label Label2 BackColor = &H00C0C0C0& Height = 225 Left = 120 TabIndex = 11 Top = 2070 Width = 4605 End Begin Label Label1 BackColor = &H00C0C0C0& Caption = "Nom du fichier:" Height = 195 Left = 90 TabIndex = 1 Top = 1440 Width = 2445 End ' ' ' ' 'Permet l'extraction des Ic nes ' ' ' ' ' Option Explicit Dim hInst As Integer Dim hIcon As Integer ' ' 'Program made by ' 'Christophe Tricaud, Paris, France N 100412,2653 ' 'If you find it usefull just tell it to me ' 'If you have good tips, just send them to me.... ' ' ' ' ' Sub Barre_Change () Dim Res As Integer ' ' ' ' 'On a fait d filer la barre ' ' ' ' ' hIcon = ExtractIcon(hInst, Text1, Barre.Value - 1) Picture1.Picture = LoadPicture("") Res = DrawIcon%(Picture1.hDC, 0, 0, hIcon) End Sub Sub Command1_Click () Dim NbIcon As Integer Dim A As String ' ' ' ' 'Lorsque l'utilisateur click, on cherche l'ic ne ' ' ' ' ' 'On contr le si le fichier existe ' On Local Error Resume Next Err = 0 A = Dir$(Text1) If Err <> 0 Then Beep MsgBox "Le fichier que vous avez indiqu est inextistant.", 64, "Erreur Saisie" Exit Sub End If If Dir$(Text1) = "" Then Beep MsgBox "Le fichier que vous avez indiqu est inextistant.", 64, "Erreur Saisie" Exit Sub End If 'On regarde le nombre d'ic nes contenues ' NbIcon = ExtractIcon(hInst, Text1, -1) If NbIcon = 0 Then Beep MsgBox "Le fichier que vous avez indiqu ne contient pas d'ic nes.", 64, "Erreur Saisie" Exit Sub End If 'On regarde si on met l' chelle ' If NbIcon > 1 Then Barre.Visible = -1 Barre.Max = NbIcon Barre.Min = 1 Barre.Value = 1 End If 'On extrait la premi re icone ' Barre_Change End Sub Sub Command2_Click () Unload Me End Sub Sub Command3_Click () ' ' ' ' 'On affiche ou non les r pertoires ' ' ' ' ' If Height = 2400 Then Height = 4860 Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2 Dir1.Enabled = -1 Drive1.Enabled = -1 File1.Enabled = -1 File1.SetFocus Else Height = 2400 Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2 Dir1.Enabled = 0 Drive1.Enabled = 0 File1.Enabled = 0 Text1.SetFocus End If End Sub Sub Dir1_Change () ' ' ' ' 'On modifie le r pertoire. ' ' ' ' ' File1.Path = Dir1.Path Label2.Caption = Dir1.Path If Right$(Label2.Caption, 1) <> "\" Then Label2.Caption = Label2.Caption + "\" End Sub Sub Dir1_KeyPress (KeyAscii As Integer) Dir1.Path = Dir1.List(Dir1.ListIndex) End Sub Sub Dir1_LostFocus () Dir1.Path = Dir1.List(Dir1.ListIndex) End Sub Sub Drive1_Change () On Local Error GoTo ErrUnite Dir1.Path = Drive1.Drive Exit Sub ErrUnite: MsgBox "L'unit n'est pas disponible", 48, "Erreur S lection Unit Drive1.Drive = Dir1.Path On Error GoTo 0 Exit Sub Resume End Sub Sub File1_Click () If Right$(Dir1.Path, 1) = "\" Then Label2.Caption = Dir1.Path + File1.FileName Else Label2.Caption = Dir1.Path + "\" + File1.FileName End If End Sub Sub File1_DblClick () If Right$(Dir1.Path, 1) = "\" Then Text1 = Dir1.Path + File1.FileName Else Text1 = Dir1.Path + "\" + File1.FileName End If Command1_Click End Sub Sub File1_GotFocus () If Right$(Dir1.Path, 1) = "\" Then Label2.Caption = Dir1.Path + File1.FileName Else Label2.Caption = Dir1.Path + "\" + File1.FileName End If End Sub Sub File1_PathChange () If Right$(Dir1.Path, 1) = "\" Then Label2.Caption = Dir1.Path + File1.FileName Else Label2.Caption = Dir1.Path + "\" + File1.FileName End If End Sub Sub Form_Load () 'Calcul du Handle ' hInst% = GetWindowWord(Me.hWnd, GWW_HINSTANCE) Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2 Dir1.Enabled = 0 Drive1.Enabled = 0 File1.Enabled = 0 End Sub Sub Text1_Change () Barre.Visible = 0 Barre.Max = 1 Barre.Min = 1 Picture1 = LoadPicture("") End Sub Sub Text1_KeyPress (KeyAscii As Integer) If KeyAscii = 13 Then KeyAscii = 0: Command1_Click End Sub