frmfile.frm

NOPAD的VB6原碼,寫的還蠻齊全的,請參考

VERSION 5.00
Begin VB.Form frmFile 
   BorderStyle     =   3  'Fixed Dialog
   ClientHeight    =   4575
   ClientLeft      =   1425
   ClientTop       =   1485
   ClientWidth     =   6630
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4575
   ScaleWidth      =   6630
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton btnCancel 
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   435
      Left            =   4170
      TabIndex        =   9
      Top             =   3900
      Width           =   1005
   End
   Begin VB.CommandButton btnOK 
      Caption         =   "&OK"
      Default         =   -1  'True
      Height          =   435
      Left            =   5310
      TabIndex        =   8
      Top             =   3900
      Width           =   1005
   End
   Begin VB.DirListBox Dir1 
      Height          =   2730
      Left            =   3510
      TabIndex        =   6
      Top             =   870
      Width           =   2805
   End
   Begin VB.DriveListBox Drive1 
      Height          =   315
      Left            =   3480
      TabIndex        =   5
      Top             =   420
      Width           =   2805
   End
   Begin VB.ComboBox Type1 
      Height          =   315
      Left            =   300
      TabIndex        =   3
      Text            =   "Combo1"
      Top             =   3990
      Width           =   2835
   End
   Begin VB.FileListBox File1 
      Height          =   2625
      Left            =   300
      MultiSelect     =   2  'Extended
      TabIndex        =   2
      Top             =   870
      Width           =   2805
   End
   Begin VB.TextBox Name1 
      Height          =   315
      Left            =   300
      TabIndex        =   1
      Top             =   420
      Width           =   2775
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "Drives"
      Height          =   195
      Index           =   2
      Left            =   3480
      TabIndex        =   7
      Top             =   210
      Width           =   450
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "List files by type"
      Height          =   195
      Index           =   1
      Left            =   300
      TabIndex        =   4
      Top             =   3780
      Width           =   1110
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "File Name"
      Height          =   195
      Index           =   0
      Left            =   300
      TabIndex        =   0
      Top             =   210
      Width           =   705
   End
End
Attribute VB_Name = "frmFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public DefaultExt As String
Public Filter As String
Public FilterIndex As Integer

Public Action As Integer
Public LastOpen As String
Public LastSave As String

Dim InitFlag As Integer

Public Function CountDelimiters(List As String, Delimiter As String) As Integer

Dim Temp As String
Dim RecNum As Integer
Dim Del1 As Integer

Temp = List
Del1 = InStr(Temp, Delimiter)

While Del1 > 0
    RecNum = RecNum + 1
    Temp = Mid$(Temp, Del1 + 1)
    Del1 = InStr(Temp, Delimiter)
Wend

CountDelimiters = RecNum

End Function


Public Function GetFilename(FP As String) As String

For x = Len(FP) To 1 Step -1
    If Mid$(FP, x, 1) = "\" Or Mid$(FP, x, 1) = ":" Then
        GetFilename = Mid$(FP, x + 1)
        Exit Function
    End If
Next x

GetFilename = ""

End Function

Public Function GetPath(FP As String) As String

For x = Len(FP) To 1 Step -1
    If Mid(FP, x, 1) = "\" Then
        GetPath = Left$(FP, x)
        Exit Function
    End If
Next x

'check for drive and colon without backslash
If Right$(FP, 1) = ":" Then
    GetPath = FP & "\"
Else
    GetPath = ""
End If


End Function


Sub BuildTypeList()

Dim List As String
Dim Del1 As Integer, Del2 As Integer

List = Me.Filter
Type1.Clear

While List <> ""
    Del1 = InStr(List, "|")
    Del2 = InStr(Del1 + 1, List, "|")
    
    Type1.AddItem Left$(List, Del1 - 1)
        
    If Del2 > 0 Then
        List = Mid$(List, Del2 + 1)
    Else
        List = ""
    End If
Wend
        
End Sub


Public Function GetExt(Ext As String) As String

For x = Len(Ext) To 1 Step -1
    If Mid$(Ext, x, 1) = "." Then
        GetExt = Mid$(Ext, x + 1)
        Exit Function
    End If
Next x

GetExt = ""

End Function

Function GetNextFilename(FileList As String) As String

Dim Del1 As Integer

Del1 = InStr(FileList, ", ")

'if only 1 name in list
If Del1 = 0 Then
    GetNextFilename = FileList
    Exit Function
End If

GetNextFilename = Left$(FileList, Del1 - 1)

End Function

Public Sub Init()

Dim F As Form

'if File Save As then set F to the active text form
If Me.Action = 0 Then
    Me.Caption = "Open File..."
    Set F = Nothing
Else
    Me.Caption = "Save File As..."
    Set F = frmMain.ActiveForm
End If

'init file controls
If Me.Action = 0 Then   'if File Open
    
    'if any file has been opened, set controls to LastOpen qualified path
    If Me.LastOpen <> "" Then
        Drive1.Drive = Left$(Me.LastOpen, 1)
        Dir1.Path = GetPath(Me.LastOpen)
        File1.Path = GetPath(Me.LastOpen)
    Else
         'if no files have yet been opened this session, the file
         'controls will default to the current directory
    End If
  
Else    'if File Save As

    'if file was opened from disk, use its properties
    If Not Left$(F.Caption, 3) = "NEW" Then
         Drive1.Drive = Left$(F.Drive, 1)
         Dir1.Path = F.Dir
         File1.Path = F.Dir
    
    Else    'If file is newly created
        
        'if a file has been saved previously, default to its path
        If LastSave <> "" Then
            Drive1.Drive = Left$(LastSave, 1)
            Dir1.Path = LastSave
            File1.Path = LastSave
        Else
            'if no files have yet been saved this session, the file
            'controls will default to the current directory
        End If
    End If
End If

'deselect any previously selected filenames
For x = 0 To File1.ListCount - 1
    File1.Selected(x) = False
Next x
 
'build list of file definitions in Type1 from form's Filter property
BuildTypeList

'init Name1
If Me.Action = 0 Then   'if File Open
    Name1 = ""
    Type1.ListIndex = Me.FilterIndex

Else    'If File Save As
    
    'init file definition combo
    Type1.ListIndex = 0
    
    'if newly created file
    If F.File = "" Then
        Name1 = F.Caption
    Else
        Name1 = F.File
        
        'if recognized extension, set Type1 to proper index
        Select Case GetExt(F.File)
        Case "htm", "html"
            Type1.ListIndex = 1
        Case "txt"
            Type1.ListIndex = 2
        End Select
    End If
End If

    
'init Type1 (Name1 is subsequently initialized as well)
Type1_Click
 
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2

'if not initial opening of this dialog
If InitFlag = False Then
    Show
    Name1.SetFocus  'move to the filename field
End If

End Sub

Function RemoveNextFilename(FileList As String) As String

Dim Del1 As String

Del1 = InStr(FileList, ", ")

If Del1 = 0 Then
    RemoveNextFilename = ""
    Exit Function
End If

RemoveNextFilename = Mid$(FileList, Del1 + 2)

End Function

Function SwapExt(Filename, Ext) As String

Dim Del1 As Integer     'holds position of "." delimiter

'find the extension delimiter
Del1 = InStr(Filename, ".")

SwapExt = Mid$(Filename, 1, Del1) & Ext



End Function

Private Sub btnCancel_Click()

UserCancel = True

Me.Hide

End Sub


Private Sub btnOK_Click()

Dim FileNum As Integer
Dim F As Form
Dim TempFile As String

'hide file dialog
Me.Hide

'decide if dialog is to be used for File Open or File Save As
Select Case Me.Action
Case 0
'---------------------------------------------------------------------------
'                              FILE OPEN SEQUENCE
'---------------------------------------------------------------------------
'declare vars for Action = 0 (open)
Dim FileList As String
Dim Flag As Integer
Dim FlagErr As Integer
Dim FileCount As Integer
Dim FileTotal As Integer

'CALL TO ERROR HANDLER 1
On Error GoTo frmFilebtnOKClickError1

'assign contents of Name1 to local var for manipulation
FileList = Name1

'count total number of records for Progress indicator
FileTotal = CountDelimiters(FileList, ", ") + 1

'assign total number of records to Progress indicators max property
frmMain.Progress.Max = FileTotal

'turn Stop button on
frmMain.Toolbar.Buttons("Stop").Image = "StopOn"

'loop through all records in file list
While FileList <> "" And frmMain.UserMsgChoice <> "Cancel"