Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/fopen/fopen.frm

Visual Basic Form | 1995-05-08 | 13.1 KB | 431 lines

VERSION 2.00
Begin Form FOpenForm
   BorderStyle     =   3  'Fixed Double
   Caption         =   "File Open"
   ClientHeight    =   3150
   ClientLeft      =   3000
   ClientTop       =   2460
   ClientWidth     =   4980
   Height          =   3555
   Icon            =   FOPEN.FRX:0000
   Left            =   2940
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3150
   ScaleWidth      =   4980
   Top             =   2115
   Width           =   5100
   Begin ListBox List1
      Height          =   1785
      Left            =   1965
      TabIndex        =   1
      Top             =   1170
      Width           =   1575
   End
   Begin FileListBox File1
      Height          =   1785
      Left            =   165
      TabIndex        =   3
      Top             =   1170
      Width           =   1575
   End
   Begin CommandButton Command2
      Caption         =   "&Cancel"
      Height          =   375
      Left            =   3705
      TabIndex        =   7
      Top             =   615
      Width           =   1095
   End
   Begin CommandButton Command1
      Caption         =   "&Open"
      Default         =   -1  'True
      Height          =   375
      Left            =   3705
      TabIndex        =   6
      Top             =   135
      Width           =   1095
   End
   Begin TextBox Text1
      Height          =   315
      Left            =   1140
      TabIndex        =   5
      Text            =   "FileName"
      Top             =   165
      Width           =   2400
   End
   Begin Label DirLabel
      Caption         =   "&Directories:"
      Height          =   195
      Left            =   1970
      TabIndex        =   0
      Top             =   900
      Width           =   1035
   End
   Begin Label FilesLabel
      AutoSize        =   -1  'True
      Caption         =   "&Files:"
      Height          =   195
      Left            =   170
      TabIndex        =   2
      Top             =   915
      Width           =   465
   End
   Begin Label Label1
      Caption         =   "Label1"
      Height          =   255
      Left            =   1155
      TabIndex        =   9
      Top             =   580
      Width           =   2310
   End
   Begin Label Label4
      Caption         =   "Directory:"
      Height          =   255
      Left            =   170
      TabIndex        =   8
      Top             =   580
      Width           =   855
   End
   Begin Label FNameLabel
      Caption         =   "File &Name:"
      Height          =   255
      Left            =   170
      TabIndex        =   4
      Top             =   210
      Width           =   975
   End
'You are welcome to use FOPEN in your programs free of charge.
'If you make any improvements send me a copy at CIS-MAL 73667,1755
'Costas Kitsos
DefInt A-Z
Dim TheFocus%                   ' Handle for Drive/Subdirectory ListBox
Dim List1Flag%                  ' Flag for Drive/Subdirectory ListBox 0 or 1
Dim Text1Flag%                  ' Flag for EM_LIMITTEXT
Dim TheDrive$                   ' The selected drive
Dim LastChange As Integer       ' Flag used when processing selections
Function BuildSpec (fpath As String) As String
 ' builds the spec for SendMessage
    If Right$(fpath, 1) <> "\" Then
    s$ = fpath + "\*.*"
    Else
    s$ = fpath + "*.*"
    End If
    BuildSpec = s$
    s$ = ""
End Function
Sub ChangeDir (b$)
' change to the new directory and update List1
 List1.SetFocus
 TheFocus% = GetFocus()
 If InStr(b$, ":") Then b$ = Right$(b$, Len(b$) - 2)
 If Left$(b$, 1) <> "\" Then b$ = "\" + b$
 On Error Resume Next
   File1.Path = TheDrive$ + b$
   Label1.caption = File1.Path
   y& = SendMessage(TheFocus%, LB_RESETCONTENT, 0, ByVal "")
   x& = SendMessage(TheFocus%, LB_DIR, &HC010, ByVal BuildSpec((File1.Path)))
 If Err Then
 ' you may add a MsgBox error message here if you think it's
 ' necessary.
 End If
End Sub
Sub ChangeDrive (a$, ErrState%)
    OldPath$ = File1.Path
    List1.SetFocus
    TheFocus% = GetFocus()
 ' try to change to the new drive
    On Error Resume Next
        File1.Path = a$ + ":"
        y& = SendMessage(TheFocus%, LB_RESETCONTENT, 0, ByVal "")
        s$ = a$ + ":*.*"
        x& = SendMessage(TheFocus%, LB_DIR, &HC010, ByVal s$)
        Label1.caption = File1.Path
        TheDrive$ = a$ + ":"
        ErrState% = False
 ' if an error occurred go back to the way things were
    If Err Then
        MsgBox (Error$ + Chr$(13) + Chr$(10) + TheDrive$), 16, FormTitle
        TheDrive$ = Left$(OldPath$, 2)
        File1.Path = OldPath$
        If Right$(File1.Path, 1) <> "\" Then
        s$ = File1.Path + "\*.*"
        Else
        s$ = File1.Path + "*.*"
        End If
        y& = SendMessage(TheFocus%, LB_RESETCONTENT, 0, ByVal "")
        x& = SendMessage(TheFocus%, LB_DIR, &HC010, ByVal s$)
        Label1.caption = File1.Path
        Text1.Text = ThePattern
        ErrState% = True    'change the flag so Text1 knows
    End If
End Sub
Sub Command1_Click ()
    Select Case LastChange
      Case 1  'process Text1 entry
        Text1_KeyPress (13)
    Case 2  'we have a file, put together the FullName
        ThePath = File1.Path
        TheFileName = File1.FileName
        FullName = Left$(BuildSpec((File1.Path)), Len(BuildSpec((File1.Path))) - 3) + File1.FileName
        FOpenForm.Hide
    Case 3  'let List1 know
        List1_Dblclick
    Case 4  'we have a file and a FullName
        FOpenForm.Hide
    Case 5  'we have a file, put together the FullName
        ThePath = File1.Path
        FullName = Left$(BuildSpec((File1.Path)), Len(BuildSpec((File1.Path))) - 3) + TheFileName
        FOpenForm.Hide
    Case Else
    End Select
End Sub
Sub Command2_Click ()
 ' did the user press cancel?  Change FullName into an empty string
 ' so the Parent knows.
    FullName = ""
    FOpenForm.Hide
End Sub
Sub File1_Click ()
' update the textbox and the lastchange flag
  Text1.Text = File1.FileName
  LastChange = 2
End Sub
Sub File1_DblClick ()
' Good, we have a file, let's tell Command1
    LastChange = 2
    Command1_Click
End Sub
Sub File1_KeyPress (KeyAscii As Integer)
' if Return, select File1_DblClick
    If KeyAscii = 13 Then
    If File1.Listindex > -1 Then File1_DblClick
    End If
End Sub
Sub Form_GotFocus ()
    If List1Flag% = 0 Then
    List1.SetFocus          ' Set the Focus on List1 to fill the ListBox
    End If
End Sub
Sub Form_Load ()
 ' Set the flags for List1 and Text1
    List1Flag% = 0  ' Update Drive/Subdirectory listbox
    Text1Flag% = 0  ' Limit text length
 ' If the Parent didn't specify a FormTitle use the one that's built in.
    If FormTitle = "" Then
    FOpenForm.caption = "File Open"
    FormTitle = FOpenForm.caption
 ' otherwise honor the Parent's specification
    Else
    FOpenForm.caption = FormTitle
    End If
 ' If there is a path specification use it, otherwise use the default.
    If ThePath <> "" Then
    If Right$(ThePath, 1) = "\" Then
        ThePath = Left$(ThePath, (Len(ThePath) - 1))
        If Right$(ThePath, 1) = ":" Then ThePath = ThePath + "\"
    End If
    File1.Path = ThePath
    End If
    If ThePath = "" Then ThePath = File1.Path
 ' If the Parent specified a new pattern then use it.
    If ThePattern <> "" Then
    File1.Pattern = ThePattern
    End If
 ' Finish up loading the form.
    Text1.Text = File1.Pattern
    TheDrive$ = Left$(File1.Path, 2)
    Label1.caption = File1.Path
End Sub
Sub List1_Click ()
 ' let Command1 know
    LastChange = 3
End Sub
Sub List1_Dblclick ()
' List1 holds both drives and subdirectories
 If List1.Listindex > -1 Then
    curnt$ = List1.List(List1.Listindex)        'get the current selection
    OldPath$ = File1.Path                       'save the old path in case of error
 ' if the user chose a drive parse it and change to it
    If Left$(curnt$, 2) = "[-" And Len(curnt$) = 5 Then
    If Right$(curnt$, 2) = "-]" Then
        a$ = Mid$(curnt$, 3, 1)
        ChangeDrive a$, ErrState%
    End If
 ' if the user chose a subdirectory change to it
    Else
    On Error Resume Next
    b$ = Mid$(curnt$, 2, Len(curnt$) - 2)
    File1.Path = TheDrive$ + b$
    Label1.caption = File1.Path
 ' LB_RESETCONTENT clears the list fast
 ' LB_DIR specifies the type of listbox, &HC010 specifies drives and subdirectories only.
    y& = SendMessage(TheFocus%, LB_RESETCONTENT, 0, ByVal "")
    x& = SendMessage(TheFocus%, LB_DIR, &HC010, ByVal BuildSpec((File1.Path)))
 ' if there was an error let the user know.
    If Err Then
    MsgBox Error$ + Chr$(13) + Chr$(10) + File1.Path, 16, FormTitle
    Text1.Text = File1.Pattern
    End If
    End If
 End If
End Sub
Sub List1_GotFocus ()
If List1Flag% = 0 Then
' get the handle of the ListBox
    TheFocus% = GetFocus()
' fill it with the Drive/Subdirectory listing
    x& = SendMessage(TheFocus%, LB_DIR, &HC010, ByVal BuildSpec((File1.Path)))
' update the flag so we don't go through this every time
    List1Flag% = 1
' highlight Text1
    Text1.selstart = 0
    Text1.sellength = Len(Text1.Text)
    If visible Then Text1.SetFocus
End If
TheFocus% = GetFocus()
End Sub
Sub List1_KeyPress (KeyAscii As Integer)
 ' if the user presses the Return key while on a valid entry, invoke a List1_DblClick
    If KeyAscii = 13 Then
    If List1.Listindex > -1 Then
        List1_Dblclick
    End If
    End If
End Sub
Function ProcessEntry (a$, b$) As Integer
 ' we'll use this if/when we have to use OpenFile
  Dim TheStruct As OfStruct
 ' if a$(newd$) isn't empty change to it.
 If a$ <> "" Then
    If Len(a$) > 1 Then
    a$ = Left$(a$, Len(a$) - 1)
    ChangeDir (a$)
    End If
 End If
 'if b$(tempo$) isn't empty let's see what it could be.
 If Len(b$) > 0 Then
 'if it's a new pattern then let File1.List know
    If InStr(b$, "*") > 0 Or InStr(b$, "?") > 0 Then
    File1.Pattern = b$
    Text1.Text = File1.Pattern
    ProcessEntry = True
    Exit Function
    Else
 'otherwise could it be a file?
    If Right$(File1.Path, 1) <> "\" Then
        test$ = File1.Path + "\"
    Else
        test$ = File1.Path
    End If
    test$ = test$ + b$
 'use OpenFile to see if it exists.  If so x% will return a file handle.
 'This is a very useful API function.
    x% = OpenFile(test$, TheStruct, OF_EXIST)
 'close the file
    i% = lclose(x%)
 'if we have a file handle, we're done let's tell Command1
        If x% > 0 Then
        ThePath = File1.Path
        TheFileName = b$
        FullName = test$
        LastChange = 4
        Command1_Click
        Else
 'no handle? The user probably specified a subdirectory.
        ChangeDir (test$)
        End If
    ProcessEntry = True
    End If
 End If
End Function
Function RemoveSpaces (TheText$) As String
' squeezes out spaces
    t$ = TheText$
    i% = 1
    Do
      i% = InStr(i%, t$, " ")
      If i% = 0 Then
         Exit Do
      End If
      t$ = Left$(t$, i% - 1) + Mid$(t$, i% + 1)
      i% = i%
    Loop
    RemoveSpaces = t$
    t$ = ""
End Function
Sub Text1_Change ()
 'needed by Command1
    LastChange = 1
End Sub
Sub Text1_GotFocus ()
 If Text1Flag% = 0 Then
  ' Do this only once
  ' send the message to limit the text entry to not more than 127 characters
    maxi% = 127
    TextLimit& = SendMessage(GetFocus(), EM_LIMITTEXT, maxi%, ByVal "")
    Text1Flag% = 1
 End If
 Text1Flag% = 1
End Sub
Sub Text1_KeyPress (KeyAscii As Integer)
' process whatever the user typed in Text1
 If KeyAscii = 13 Then KeyAscii = 0   ' get rid of the beep (Mark, thanks for the tip)
 If KeyAscii = 0 Then
' remove any space characters.  Some users put a space after a period out of habit.
    temp$ = RemoveSpaces((Text1.Text))
' see if the file is in File1.List. If it is, we're done so let's tell Command1.
    For ind% = 0 To File1.Listcount
    If File1.List(ind%) = temp$ Then
        TheFileName = temp$
        Foundit = True
        LastChange = 5
        Command1_Click
        Exit For
    End If
    Next ind%
 ' if the file is not in File1.List let's see what the user is trying to do.
    If Foundit <> True Then
    cp = InStr(temp$, ":")  'drive?
    bp = InStr(temp$, "\")  'subdirectory?
    sp = InStr(temp$, "*")  'wildcards?
    qp = InStr(temp$, "?")
    ErrState% = False       'flag used by ChangeDrive
    If cp Then      'if we found a drive change to it
       ChangeDrive (Mid$(temp$, cp - 1, 1)), ErrState%
    End If
 ' If changing to the drive didn't cause any errors or if a drive wasn't specified
    If Not ErrState% Then
 ' if a subdirectory was specified
    If bp Then
        tempo$ = temp$
        While InStr(tempo$, "\")
            newd$ = newd$ + Left$(tempo$, InStr(tempo$, "\"))
            tempo$ = Right$(tempo$, Len(tempo$) - InStr(tempo$, "\"))
        Wend
 ' newd$ holds everything to the left of the last backslash
 ' tempo$ hold the rest.  Now, process them.
        pe% = ProcessEntry(newd$, tempo$)
    End If
 ' did the user specify only a new pattern?
    If pe% = False Then
        If sp Or qp Then
        If cp Then
            File1.Pattern = Right$(temp$, Len(temp$) - 2)
        Else
            File1.Pattern = temp$
        End If
        Text1.Text = File1.Pattern
        End If
    End If
    End If
 End If
 ' highlight the text
 Text1.selstart = 0
 Text1.sellength = Len(Text1.Text)
 If visible Then Text1.SetFocus
End If
End Sub