Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/vbdb/gfilebox.frm

Visual Basic Form | 1995-09-06 | 9.0 KB | 300 lines

VERSION 2.00
Begin Form GetFileBox
   BorderStyle     =   3  'Fixed Double
   ClientHeight    =   2640
   ClientLeft      =   1725
   ClientTop       =   2445
   ClientWidth     =   5055
   Height          =   3045
   Left            =   1665
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2640
   ScaleWidth      =   5055
   Top             =   2100
   Width           =   5175
   Begin ListBox Dirs
      Height          =   1200
      Left            =   1848
      Sorted          =   -1  'True
      TabIndex        =   4
      Top             =   1260
      Width           =   1530
   End
   Begin ListBox Files
      Height          =   1590
      Left            =   168
      Sorted          =   -1  'True
      TabIndex        =   3
      Top             =   912
      Width           =   1530
   End
   Begin CommandButton Command2
      Caption         =   "Cancel"
      Height          =   348
      Left            =   3948
      TabIndex        =   6
      Top             =   600
      Width           =   936
   End
   Begin CommandButton Command1
      Caption         =   "OK"
      Height          =   348
      Left            =   3948
      TabIndex        =   5
      Top             =   120
      Width           =   936
   End
   Begin TextBox FileSpec
      Height          =   288
      Left            =   1176
      TabIndex        =   2
      Top             =   132
      Width           =   2616
   End
   Begin Label Label2
      Caption         =   "&Directories:"
      Height          =   180
      Left            =   1848
      TabIndex        =   1
      Top             =   1008
      Width           =   1020
   End
   Begin Label Path
      Height          =   180
      Left            =   1848
      TabIndex        =   8
      Top             =   672
      Width           =   1992
   End
   Begin Label Label1
      Caption         =   "&Files:"
      Height          =   180
      Left            =   168
      TabIndex        =   0
      Top             =   672
      Width           =   600
   End
   Begin Label Label3
      Caption         =   "File &Name"
      Height          =   180
      Left            =   168
      TabIndex        =   7
      Top             =   168
      Width           =   936
   End
'Code for Visual Basic 1.0 and Windows 3.0
'(C)1991 Marquis Computing. All Rights Reserved.
'File Dialog box manager. Uses Windows system calls to increase
'speed and give a dialog box that dosen't have "visual basic"
'stamped all over it!
DefInt A-Z
Declare Function DlgDirList Lib "User" (ByVal hDlg As Integer, ByVal lpPathSpec As String, ByVal nIDListBox As Integer, ByVal nIDStaticPath As Integer, ByVal wFiletype As Integer) As Integer
Const TRUE = -1
Const FALSE = 0
'--- these constants are used by GetFileBox form
Const File_Box = &H7
Const Dir_Box = &H9
Const DrivesAndDir = &H10 Or &H4000 Or &H8000
Const FilesOnly = &H1
Dim File_Mask As String
Sub ChangeTo (FileSpec$)
    On Error GoTo ErrorHandler
    OldPath$ = CurDir$("")
    If InStr(FileSpec$, "[-") Then      'drive
        Drive$ = Mid$(FileSpec$, 3, Len(FileSpec$) - 3)
        ChDrive Drive$
        UpDateForm
    ElseIf InStr(FileSpec$, "[") Then   'dir
        SDir$ = Mid$(FileSpec$, 2, Len(FileSpec$) - 2)
        ChDir SDir$
        UpDateForm
    Else
    End If
    Exit Sub
ErrorHandler:
    ChDrive OldPath$
    ChDir OldPath$
    Exit Sub
End Sub
Sub Command1_Click ()
    GetFileBox.Hide
    GetFileBox.Path = CurDir$
End Sub
Sub Command2_Click ()
    GetFileBox.FileSpec.Text = ""
    GetFileBox.Hide
End Sub
Sub Dirs_DblClick ()
    '
    '
    '
    FileSpec.Text = File_Mask
    NewFileSpec$ = Dirs.Text
    ChangeTo NewFileSpec$
End Sub
Sub Dirs_KeyDown (KeyCode As Integer, Shift As Integer)
    FileSpec.Text = ProcessDir()
End Sub
Sub Dirs_KeyPress (KeyAscii As Integer)
    If KeyAscii = 13 Then
        FileSpec.Text = File_Mask
        NewFileSpec$ = Dirs.Text
        ChangeTo NewFileSpec$
    End If
End Sub
Sub Dirs_KeyUp (KeyCode As Integer, Shift As Integer)
FileSpec.Text = ProcessDir()
End Sub
Sub Dirs_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single)
FileSpec.Text = ProcessDir()
End Sub
Sub Files_DblClick ()
    '
    '
    '
    GetFileBox.Hide
End Sub
Sub Files_KeyDown (KeyCode As Integer, Shift As Integer)
    FileSpec.Text = Files.Text
End Sub
Sub Files_KeyPress (KeyAscii As Integer)
        If KeyAscii = 13 Then GetFileBox.Hide
End Sub
Sub Files_KeyUp (KeyCode As Integer, Shift As Integer)
    FileSpec.Text = Files.Text
End Sub
Sub Files_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single)
    FileSpec.Text = Files.Text
End Sub
Sub FileSpec_KeyPress (KeyAscii As Integer)
    If KeyAscii = 13 Then
        FileSpec.Text = UCase$(FileSpec.Text)
        KeyAscii = 0
        UpDateForm
    End If
End Sub
Sub Form_Load ()
    '
    'Center form
    '
    '--- Center form
    Screen.MousePointer = 11
    WinWidth = (Screen.Width - GetFileBox.Width) \ 2
    WinHieght = (Screen.Height - GetFileBox.Height) \ 2
    GetFileBox.Move WinWidth, WinHieght
    '--- load the files box
    If FileSpec.Text = "" Then FileSpec.Text = "*.*"
    '--- display current path
    ThisDir$ = LCase$(CurDir$)
    If Len(ThisDir$) > 20 Then
      ThisDir1$ = Left$(ThisDir$, 3)
      ThisDir2$ = "..."
      ThisDir3$ = Right$(ThisDir$, 15)
      ThisDir$ = ThisDir1$ + ThisDir2$ + ThisDir3$
    End If
    GetFileBox.Path.Caption = ThisDir$
    Screen.MousePointer = 0
End Sub
Sub Form_Resize ()
    File_Mask = FileSpec.Text
    '--- load the files box
    LoadDir File_Box, File_Mask, FilesOnly
    '--- load the dir/drive box
    LoadDir Dir_Box, File_Mask, DrivesAndDir
End Sub
Function GetMask$ (FileSpec$)
    '
    '
    '

    For X = Len(FileSpec$) To 1 Step -1
      If Mid$(FileSpec$, X, 1) = "." Then
        GetMask$ = "*" + Mid$(FileSpec$, X)
        Exit For
      End If
    Next
End Function
Sub LoadDir (ListBox, Mask$, Item)
    '
    'Loads a listbox with a variety of disk file items. Usually the array
    'of items are file(s), dir(s) or drive(s). Uses a windows system call
    'for enhanced speed and versatility.
    '
    'On entry
    '---------------------------------------------------------------------
    'ListBox:   the number of the list box (i.e., 1,2 etc.)
    '
    'Mask$  :   a file specification mask (i.e., *.DBF, ?.DAT, *.SY?)
    '
    'Item   :   an integer which represents the type of item to load into
    '           the list box where:
    '
    '           &H0     = read/write files only
    '           &H1     = read-only files
    '           &H2     = hidden files
    '           &H4     = system files
    '           &H10    = sub dirs
    '           &H20    = archive
    '           &H4000  = drives
    '           &H8000  = force ONLY those items meeting Mask$ and Item%
    '                     criteria to be loaded.
    '
    'NOTE:  Items may be OR'd to combine -- for example to load system files
    '       and drives ONLY, you would set up Item% as follows:
    '
    '               Item% = &H4 Or &H4000 Or &H8000
    'on exit
    '--------------------------------------------
    'The list box is filled with contents specified (if any found)
    '
    '

     '--- get windows handle of form
     hDlg = GetFileBox.hWnd

     '--- ASCIIZ file spec
     lpPathSpec$ = LTrim$(RTrim$(Mask$)) + Chr$(0)
     '--- assign list box number
     nIDListBox = ListBox
     '--- no static path id
     nIDStaticPath = 0

     '--- assign item
     wFiletype = Item

     '--- call windows
     dummy = DlgDirList(hDlg, lpPathSpec$, nIDListBox, nIDStaticPath, wFiletype)
End Sub
Function ProcessDir$ ()
    '
    '
    '
    Item$ = Dirs.Text
    If InStr(Item$, "[-") Then          'drive
        Item$ = Mid$(Item$, 3, 1) + ":"
    ElseIf InStr(Item$, "[") Then      'directory
        Item$ = Mid$(Item$, 2, Len(Item$) - 2)
    End If
    ProcessDir$ = Item$ + "\" + File_Mask
End Function
Sub UpDateForm ()
    '
    'Updates a form based on new filespec
    '
    NewFileSpec$ = GetFileBox.FileSpec.Text
    LoadDir File_Box, NewFileSpec$, FilesOnly
    LoadDir Dir_Box, NewFileSpec$, DrivesAndDir
    GetFileBox.FileSpec.Text = GetMask(NewFileSpec$)
    ThisDir$ = LCase$(CurDir$)
    If Len(ThisDir$) > 20 Then
      ThisDir1$ = Left$(ThisDir$, 3)
      ThisDir2$ = "..."
      ThisDir3$ = Right$(ThisDir$, 15)
      ThisDir$ = ThisDir1$ + ThisDir2$ + ThisDir3$
    End If
    GetFileBox.Path.Caption = ThisDir$
End Sub