DP Tool Club 16/CD_ASCQ_16_0994.iso/news/4609/tx4vb/file.ba_/file.ba

Text File | 1994-03-31 | 10KB | 338 lines

Option Explicit

Global Const GET_FILE_HANDLE = 2    ' Constant for FileAttr function

Const CONTROL_VERSION& = 20         ' Version number for document files

Type FILE_HEADER                    ' Structure for document file header
    lVersion As Long
End Type

'-------------------------------------------------------------------------
' FileOpenProc
'
' This function is called when the user selects the "Open File..." menu
' or the corresponding button in the button bar. The function calls
' the "file open" common dialog box and passes the filename to OpenFile().
'
' Parameters: -
'-------------------------------------------------------------------------
Sub FileOpenProc ()
    Dim Filename As String
    On Error Resume Next

    frmMDIParent.CMDialog1.DialogTitle = "Open file"
    frmMDIParent.CMDialog1.Filename = ""
    frmMDIParent.CMDialog1.Filter = "Text Control Demo (*.txm)|*.txm|Rich Text Format (*.rtf)|*.rtf"
    frmMDIParent.CMDialog1.FilterIndex = 1
    frmMDIParent.CMDialog1.Flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
    frmMDIParent.CMDialog1.CancelError = True
    frmMDIParent.CMDialog1.Action = DLG_FILE_OPEN
    If Err Then Exit Sub

    Filename = frmMDIParent.CMDialog1.Filename
    If UCase$(Right$(Filename, 3)) = "RTF" Then
    OpenFile Filename, RTF_FILE
    Else
    OpenFile Filename, TXM_FILE
    End If
End Sub

'-------------------------------------------------------------------------
' FileSaveAsProc
'
' gets new text filename and saves text
'-------------------------------------------------------------------------
Sub FileSaveAsProc ()
    Dim Filename As String

    Filename = GetSaveFileName()
    If Filename <> "" Then SaveFile (Filename)

End Sub

'-------------------------------------------------------------------------
' FileSaveProc
'
' saves current text
'-------------------------------------------------------------------------
Sub FileSaveProc ()
    Dim Filename As String

    If Left(frmMDIParent.ActiveForm.Caption, 8) = "Untitled" Then
    ' The file hasn't been saved yet,
    ' get the filename, then call the
    ' save procedure
    Filename = GetSaveFileName()
    Else
    ' The caption contains the name of the open file
    Filename = frmMDIParent.ActiveForm.Caption
    End If
    ' call the save procedure, if Filename = Empty then
    ' the user selected Cancel in the Save As dialog, otherwise
    ' save the file
    If Filename <> "" Then
    SaveFile Filename
    End If

End Sub

'-------------------------------------------------------------------------
' GetSaveFileName
'
' queries a text filename
'-------------------------------------------------------------------------
Function GetSaveFileName ()
    'Displays a Save As dialog and returns a file name
    'or an empty string if the user cancels
    On Error Resume Next

    frmMDIParent.CMDialog1.DialogTitle = "Save As"
    frmMDIParent.CMDialog1.Filter = "Text Control Demo (*.txm)|*.txm|Rich Text Format (*.rtf)|*.rtf"
    frmMDIParent.CMDialog1.DefaultExt = "*.txm"
    frmMDIParent.CMDialog1.Filename = ""
    frmMDIParent.CMDialog1.Flags = OFN_PATHMUSTEXIST Or OFN_OVERWRITEPROMPT
    frmMDIParent.CMDialog1.CancelError = True
    frmMDIParent.CMDialog1.Action = DLG_FILE_SAVE

    If Err Then      'User cancelled dialog
    GetSaveFileName = ""
    Else
    GetSaveFileName = frmMDIParent.CMDialog1.Filename
    End If
End Function

'-------------------------------------------------------------------------
' InsertImageProc
'
' gets image file name and inserts image
'-------------------------------------------------------------------------
Sub InsertImageProc ()
    On Error Resume Next

    frmMDIParent.CMDialog1.DialogTitle = "Insert Image"
    frmMDIParent.CMDialog1.Filename = ""
    frmMDIParent.CMDialog1.Filter = "TIFF (*.tif)|*.tif|Bitmap Format (*.bmp *.dib)|*.bmp *.dib|Windows Metafile (*.wmf)|*.wmf"
    frmMDIParent.CMDialog1.FilterIndex = 1
    frmMDIParent.CMDialog1.Flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
    frmMDIParent.CMDialog1.CancelError = True
    frmMDIParent.CMDialog1.Action = DLG_FILE_OPEN
    If Err Then Exit Sub

    frmMDIParent.ActiveForm.TextControl1.ImageInsert = frmMDIParent.CMDialog1.Filename
End Sub

'-------------------------------------------------------------------------
' InsertTextProc
'
' gets text file name and imports text
'-------------------------------------------------------------------------
Sub InsertTextProc ()
    Dim Filename As String      'current file name
    Dim NameEnd As String
    Dim Text As String          'file contents
    Dim bOpen As Integer        'file open flag

    On Error Resume Next
    bOpen = False

    NameEnd = UCase$(Right$(frmMDIParent.CMDialog1.Filename, 3))
    If NameEnd = "RTF" Then
    frmMDIParent.CMDialog1.FilterIndex = 2
    Else
    frmMDIParent.CMDialog1.FilterIndex = 1
    If NameEnd <> "TXT" Then
        frmMDIParent.CMDialog1.Filename = ""
    End If
    End If

    frmMDIParent.CMDialog1.DialogTitle = "Insert Text"
    frmMDIParent.CMDialog1.Filter = "Text (*.txt)|*.txt|RTF Format (*.rtf)|*.rtf"
    frmMDIParent.CMDialog1.Flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
    frmMDIParent.CMDialog1.CancelError = True
    frmMDIParent.CMDialog1.Action = DLG_FILE_OPEN
    If Err Then Exit Sub

    Filename = frmMDIParent.CMDialog1.Filename
    frmMDIParent.CMDialog1.Filename = frmMDIParent.CMDialog1.Filetitle

    screen.MousePointer = HOURGLASS

    If UCase$(Right$(Filename, 3)) = "RTF" Then
    frmMDIParent.ActiveForm.TextControl1.RTFImport = Filename
    If Err Then
        MsgBox "Can't import file: " + Filename
    End If
    Else
    Open Filename For Binary As #1
    If Err Then
        MsgBox "Can't open file: " + Filename
        GoTo cleanup_it
    End If
    bOpen = True

    'check size limit

    If LOF(1) + Len(frmMDIParent.ActiveForm.TextControl1.Text) > 64000 Then
        MsgBox "Textfile too big: " + Filename
        GoTo cleanup_it
    End If

    'import text

    Text = String$(LOF(1), " ")
    Get #1, , Text

    If Err Then
        MsgBox "Can't import file: " + Filename
        GoTo cleanup_it
    End If
    frmMDIParent.ActiveForm.TextControl1.SelText = Text
    End If

cleanup_it:
    If bOpen = True Then
    Close #1
    End If
    screen.MousePointer = DEFAULT

End Sub

'-------------------------------------------------------------------------
' OpenFile
'
' Opens the file given in the "filename" parameter, creates a new MDI
' child and text control and loads the file contents.
'
' Parameters: FileName: Name of the file to be loaded (string)
'             FileType: Type (TXM_FILE ot RTF_FILE)
'-------------------------------------------------------------------------
Sub OpenFile (Filename As String, FileType As Integer)
    Dim FileHeader As FILE_HEADER
    Dim fIndex As Integer
    Dim bOpen As Integer
    Dim bError As Integer

    On Error Resume Next

    bOpen = False
    bError = True

    ' Create new document window
    screen.MousePointer = HOURGLASS
    fIndex = FindFreeIndex()
    If fIndex = 0 Then GoTo cleanup_of
    document(fIndex).Tag = fIndex

    If (FileType = RTF_FILE) Then
    ' Load RTF file
    document(fIndex).TextControl1.RTFImport = Filename
    If Err Then
        MsgBox "Can't load file: " + Filename
        GoTo cleanup_of
    End If
    Else
    ' open the selected file
    Open Filename For Binary As #1
    If Err Then
        MsgBox "Can't open file: " + Filename
        GoTo cleanup_of
    End If
    bOpen = True

    ' Read TXM file header
    Get #1, , FileHeader
    If FileHeader.lVersion <> CONTROL_VERSION Then
        MsgBox "Wrong file type: " + Filename
        GoTo cleanup_of
    End If
    ' Use the FileAttr function to get a DOS file handle
    ' from the VisualBasic file number and pass it on to TX
    document(fIndex).TextControl1.Load = FileAttr(1, GET_FILE_HANDLE)
    If Err Then
        MsgBox "Can't load file: " + Filename
        GoTo cleanup_of
    End If
    End If

    ' Change form's caption and display new text
    document(fIndex).Caption = UCase$(Filename)
    document(fIndex).TXRuler1.ScaleUnits = SCALE_MM

    document(fIndex).Show
    bError = False

cleanup_of:
    If bOpen = True Then
    Close #1
    End If

    If fIndex <> 0 Then
    FState(fIndex).Ignore = True
    FState(fIndex).Dirty = False

    If bError = True Then
        FState(fIndex).Deleted = True
        Unload document(fIndex)
    End If
    End If
    screen.MousePointer = DEFAULT

End Sub

'-------------------------------------------------------------------------
' SaveFile
'
' Saves the contents of the active form in the file file given in the
' "filename" parameter.
'
' Parameters: FileName: Name of the file to be loaded (string)
'-------------------------------------------------------------------------
Sub SaveFile (Filename)
    Dim FileHeader As FILE_HEADER
    Dim FileType As Integer
    On Error Resume Next

    ' Determine file type from filename extension
    If UCase$(Right$(Filename, 3)) = "RTF" Then
    FileType = RTF_FILE
    Else
    FileType = TXM_FILE
    End If

    screen.MousePointer = HOURGLASS

    If (FileType = RTF_FILE) Then
    ' Save RTF file
    frmMDIParent.ActiveForm.TextControl1.RTFExport = Filename
    Else
    ' Open the file
    Open Filename For Binary As #1
    If Err Then
        MsgBox "Can't open file: " + Filename
        GoTo cleanup_sf
    End If
    ' Write file header
    FileHeader.lVersion = CONTROL_VERSION
    Put #1, , FileHeader
    ' Write text control contents
    frmMDIParent.ActiveForm.TextControl1.Save = FileAttr(1, GET_FILE_HANDLE)
    Close #1
    End If

    If Err Then
    MsgBox "Can't save file: " + Filename
    GoTo cleanup_sf
    End If

    ' Set the window caption
    frmMDIParent.ActiveForm.Caption = UCase$(Filename)
    ' reset the dirty flag
    FState(frmMDIParent.ActiveForm.Tag).Dirty = False

cleanup_sf:
    screen.MousePointer = DEFAULT

End Sub