SetFile.frm
CASP (Computer Aided Service Planning) is a suite of programs designed to help clinicians construct and track treatment plans. CASP is used in mental health clinics and hospitals nationwide.
This form is one of the main objects in an internal utility (not distributed to customers) which creates license files for CASP. It is instantiated as an MDI child window. The MDI parent is responsible for interacting with the common dialog control to provide file open/save functionality.
New instances of this form are created using this pattern:
Case mcnMnuFileNewIdx
' create a new set file
Set objSetFile = New FSetFile
objSetFile.Initialize
objSetFile.Show
...and are destroyed using this one:
Case mcnMnuFileCloseIdx
' close the current set file
Debug.Assert Not (objSetFile Is Nothing)
objSetFile.Terminate
Set objSetFile = Nothing
| The FSetFile form: | Names of the controls on the FSetFile form: |
|
|
|
'
' FSetFile (SetFile.frm)
' (c) Copyright 1999 by UBH
' ALL RIGHTS RESERVED
'
' MDI child representing a single set file (Casp license).
'
' Unlike most Casp forms, this is intended to be instantiated;
' hence the 'F' prefix instead of the Casp-standard 'frm' prefix.
' All common dialog interface code is in the controlling MDI parent.
'
' 28-Jun-1999 Marc Wallace Final Y2K Assessment
' 24-Jun-1999 Marc Wallace Original Write
'
Option Explicit
'''''''''''''''''''
' Private constants
Private Const mcnDefaultTitle = "[[unsaved set file]]"
Private Const mcnDateFormat = "mm/dd/yyyy"
' option button indices
Private Const mcnVersionFullIdx = 0
Private Const mcnVersionDemoIdx = 1
' type id ranges
Private Const mcnTypeIdFullStart = 2000
Private Const mcnTypeIdDemoStart = 6000
Private Const mcnTypeIdRange = 2000
'''''''''''''''''
' Private members
Private mbDirty As Boolean
Private msFilename As String
' set file record data
Private mbIsDemo As Boolean ' demo or full version
Private mnType As Integer ' type id (determines type)
Private msCustomer As String ' customer name
Private mdtStartDate As Date ' starting date of license
Private mdtEndDate As Date ' ending date of license
''''''''''''''''''
' Property methods
' Return true if contents have changed since the last save
Public Property Get Dirty() As Boolean
Dirty = mbDirty
End Property
' Set the dirty flag (only from within this object)
Private Property Let Dirty(IsDirty As Boolean)
mbDirty = IsDirty
' the window caption reflects the 'dirty' state
Call UpdateCaption
End Property
Public Property Let FileName(NewFileName As String)
msFilename = Trim$(NewFileName)
Dirty = True
End Property
Public Property Get HasFileName() As Boolean
HasFileName = (Len(msFilename) > 0)
End Property
''''''''''''''''
' Public methods
' Initialize object
Public Sub Initialize(Optional InitialFileName As String)
'- Assert valid parameters
'- Pass parameters to ByRef members
If Not IsMissing(InitialFileName) Then
msFilename = InitialFileName
End If
'- Call Initialize() for ByVal members
End Sub
' Load the record's data from a set file
' Returns true if data was loaded
Public Function Load() As Boolean
Dim bLoaded As Boolean
' load the file
bLoaded = LoadSetFile(msFilename)
If bLoaded Then
' populate the UI
Call ParseToUI
Dirty = False
End If
' Set return value
Load = bLoaded
End Function
' Save the record's data to a set file
' Returns true if data was saved
Public Function Save(Optional NewFileName As Boolean) As Boolean
Dim bSaved As Boolean
' populate internal variables from the UI
' if this fails, we cannot save the set file
If ParseFromUI() Then
' save the set file
bSaved = SaveSetFile(msFilename)
' If saved, no longer dirty
If bSaved Then
Dirty = False
End If
End If
' Set return value
Save = bSaved
End Function
' Terminate object
Public Sub Terminate()
'- Call Terminate() for ByVal members
'- Release local references
'- Destroy ourselves
Unload Me
End Sub
'''''''''''''''''
' Private methods
' Generate a random type id for the type of program (demo/full)
Private Function CreateTypeId(IsDemo As Boolean) As Integer
Randomize CLng(Time)
CreateTypeId = IIf(IsDemo, mcnTypeIdDemoStart, mcnTypeIdFullStart) _
+ CInt(mcnTypeIdRange * Rnd())
End Function
' Convert a type id into the type of program (demo/full)
Private Function IsDemoType(TypeID As Integer) As Boolean
IsDemoType = IIf(mcnTypeIdFullStart <= TypeID And TypeID <= mcnTypeIdFullStart + mcnTypeIdRange, False, True)
End Function
' Loads data from a set file into internal variables
' Returns false if the load failed for whatever reason
Private Function LoadSetFile(FileName As String) As Boolean
Dim lFileNo As Long
Dim sError As String
Dim sCryptLine As String
Dim sLine As String
Dim bValid As Boolean
Dim bReturn As Boolean
Dim bIsDemo As Boolean
Dim nType As Integer
Dim sCustomer As String
Dim dtStartDate As Date
Dim dtEndDate As Date
On Local Error GoTo Local_ErrTrap
lFileNo = FreeFile
Open FileName For Input Shared As #lFileNo
' read the four encrypted lines
' encryption alternates between 'text' and 'numeric' cyphers
' type
Line Input #lFileNo, sCryptLine
sLine = Unencript(sCryptLine, gcENCRIPT_NUMBERS)
bIsDemo = IsDemoType(CLng(sLine))
' start date
Line Input #lFileNo, sCryptLine
sLine = Unencript(sCryptLine, gcENCRIPT_TEXT)
dtStartDate = CDate(sLine)
' end date
Line Input #lFileNo, sCryptLine
sLine = Unencript(sCryptLine, gcENCRIPT_NUMBERS)
dtEndDate = CDate(sLine)
' customer name
Line Input #lFileNo, sCryptLine
sLine = Unencript(sCryptLine, gcENCRIPT_TEXT)
sCustomer = Trim$(sLine)
Close #lFileNo
' all data was read successfully
mbIsDemo = bIsDemo
mdtStartDate = dtStartDate
mdtEndDate = dtEndDate
msCustomer = sCustomer
' Success!
bReturn = True
Local_Exit:
LoadSetFile = bReturn
Exit Function
Local_Error:
On Local Error Resume Next
If lFileNo > 0 Then
Close #lFileNo
End If
GoTo Local_Exit
Local_ErrTrap:
bReturn = False
MsgBox FileName & vbCr & vbCr & "is not a valid Casp set file.", vbCritical, "Set File error!"
Resume Local_Error
End Function
' Transfer data from UI components into internal variables
' Returns false (and displays error) if conversion could not occur
Private Function ParseFromUI(Optional ErrorMsg As String) As Boolean
Dim sError As String
Dim bCanConvert As Boolean
' see if the current UI data is in a usable format
bCanConvert = True
If Len(Trim$(txtCustomer)) < 1 Then
sError = sError & vbCr & "Customer name cannot be blank."
bCanConvert = False
End If
If Not optVersion(mcnVersionFullIdx) And Not optVersion(mcnVersionDemoIdx) Then
sError = sError & vbCr & "A version type must be selected."
bCanConvert = False
End If
If Not IsDate(txtEffective) Then
sError = sError & vbCr & "Effective date must be a valid date."
bCanConvert = False
End If
If Not IsDate(txtExpires) Then
sError = sError & vbCr & "Expire date must be a valid date."
bCanConvert = False
End If
If bCanConvert Then
' convert the data
msCustomer = Trim$(txtCustomer)
mbIsDemo = optVersion(mcnVersionDemoIdx)
mdtStartDate = CDate(txtEffective)
mdtEndDate = CDate(txtExpires)
Else
' tell the user why the set file is incomplete
MsgBox "This set file is incomplete for the following reasons:" & vbCr & sError, vbExclamation, "Set file error"
End If
' Success (if conversion could occur)
ParseFromUI = bCanConvert
End Function
' Transfer data from internal variables into UI components
Private Function ParseToUI() As Boolean
txtCustomer = msCustomer
If mbIsDemo Then
optVersion(mcnVersionDemoIdx).Value = True
Else
optVersion(mcnVersionFullIdx).Value = True
End If
txtEffective = Format$(mdtStartDate, mcnDateFormat)
txtExpires = Format$(mdtEndDate, mcnDateFormat)
' Success (guaranteed)
ParseToUI = True
End Function
' Save data from internal variables into a set file
' Returns false if the save failed for whatever reason
Private Function SaveSetFile(FileName As String) As Boolean
Dim lFileNo As Long
Dim sError As String
Dim sCryptLine As String
Dim bValid As Boolean
Dim bReturn As Boolean
Dim bIsDemo As Boolean
Dim nType As Integer
Dim sCustomer As String
Dim dtStartDate As Date
Dim dtEndDate As Date
On Local Error GoTo Local_ErrTrap
lFileNo = FreeFile
Open FileName For Output Shared As #lFileNo
' write the four encrypted lines
' encryption alternates between 'text' and 'numeric' cyphers
' type
sCryptLine = Encript(CStr(CreateTypeId(mbIsDemo)), gcENCRIPT_NUMBERS)
Print #lFileNo, sCryptLine
' start date
sCryptLine = Encript(Format$(mdtStartDate, mcnDateFormat), gcENCRIPT_TEXT)
Print #lFileNo, sCryptLine
' end date
sCryptLine = Encript(Format$(mdtEndDate, mcnDateFormat), gcENCRIPT_NUMBERS)
Print #lFileNo, sCryptLine
' customer name
sCryptLine = Encript(msCustomer, gcENCRIPT_TEXT)
Print #lFileNo, sCryptLine
Close #lFileNo
' Success!
bReturn = True
Local_Exit:
SaveSetFile = bReturn
Exit Function
Local_Error:
On Local Error Resume Next
If lFileNo > 0 Then
Close #lFileNo
End If
GoTo Local_Exit
Local_ErrTrap:
bReturn = False
MsgBox "Error #" & CStr(Err.Number) & " writing to set file '" & FileName & "':" & vbCr & vbCr & Err.Description, vbCritical, "Saving error!"
Resume Local_Error
End Function
' update the form's caption to reflect filename and dirty state
Private Sub UpdateCaption()
If Len(msFilename) > 0 Then
Caption = msFilename & IIf(Me.Dirty, " *", "")
Else
Caption = mcnDefaultTitle
End If
End Sub
''''''''''''''''
' Event handlers
Private Sub cmdCustomerList_Click()
Dim frmCustomerList As FCustomers
' display the customer list form
Set frmCustomerList = New FCustomers
With frmCustomerList
.Initialize gcnSelectMode
.Show vbModal
' if a customer was selected...
If Not .Cancelled Then
' ...put it in the customer field
txtCustomer = .Customer
End If
.Terminate
End With
Set frmCustomerList = Nothing
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim nResponse As Integer
Dim sMessage As String
Select Case UnloadMode
Case vbFormControlMenu, vbFormCode
' user or code driven event
' if data is not saved, ask the user if they're sure
If Me.Dirty And Me.Visible Then
If Len(msFilename) > 0 Then
sMessage = "This set file has changed since the last save."
Else
sMessage = "This set file has not been saved yet."
End If
nResponse = MsgBox(sMessage & vbCr & vbCr & "Do you want to close it and lose all changes?", vbQuestion + vbYesNo, "Data has changed!")
If nResponse = vbNo Then
Cancel = True
End If
End If
Case Else
' OS or application close event
' do nothing and accept the cancel
End Select
End Sub
Private Sub optVersion_Click(Index As Integer)
If optVersion(Index).Value <> True Then
optVersion(Index).Value = True
Dirty = True
End If
End Sub
Private Sub txtCustomer_Change()
Dirty = True
End Sub
Private Sub txtEffective_Change()
Dirty = True
End Sub
Private Sub txtEffective_LostFocus()
Dim sDate As String
' if it's a date, reformat it using a standard format
If IsDate(txtEffective) Then
sDate = Format$(txtEffective, mcnDateFormat)
If sDate <> txtEffective Then
txtEffective = sDate
End If
End If
End Sub
Private Sub txtExpires_Change()
Dirty = True
End Sub
Private Sub txtExpires_LostFocus()
Dim sDate As String
' if it's a date, reformat it using a standard format
If IsDate(txtExpires) Then
sDate = Format$(txtExpires, mcnDateFormat)
If sDate <> txtExpires Then
txtExpires = sDate
End If
End If
End Sub
Source code is:
© Copyright 1999, United Behavioral Health. All rights reserved.