Programming Languages Suite/ProgramD2.iso/Database Designers/Erwin 3.0/DISK15/DATA.15/Support/ERWIN30.BAS

BASIC Source File | 1996-01-04 | 17.6 KB | 737 lines

Option Explicit

Type TranslateItem
    Item As Variant ' index into control or field array
    Value As Variant
End Type

Type ListItem
    DisplayVal As String
    DataVal As String
End Type

Declare Function GetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Long
Declare Function SetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long

Function er_ActionNeedsUpdate (Action As Integer)
    Select Case Action
    Case DATA_ACTIONMOVEFIRST To DATA_ACTIONMOVELAST
        er_ActionNeedsUpdate = True
    Case DATA_ACTIONADDNEW, DATA_ACTIONDELETE
        er_ActionNeedsUpdate = True
    Case DATA_ACTIONCLOSE, DATA_ACTIONUNLOAD
        er_ActionNeedsUpdate = True
    Case DATA_ACTIONBOOKMARK
        er_ActionNeedsUpdate = True
    Case Else
        er_ActionNeedsUpdate = False
    End Select
End Function

Function er_CB_ControlValue (cb As Control, fld As Field) As Variant
    er_CB_ControlValue = er_CB_ControlXlateValue(cb, fld, "Y", "N")

End Function

Function er_CB_ControlXlateValue (cb As Control, fld As Field, sOn As String, sOff As String) As Variant
    Dim nValue As Integer
    Dim sValue As String
    Dim sMsg As String
    Dim nOff As Integer
    Dim nOn As Integer


    Select Case Abs(cb.Value)
    Case 0
    sValue = sOff
    nValue = Val(sOff)
    Case 1
    sValue = sOn
    nValue = Val(sOn)
    Case Else
        sValue = ""
    End Select

    Select Case True
    Case er_FieldIsNumeric(fld)
    er_CB_ControlXlateValue = nValue
    Case er_FieldIsString(fld)
        er_CB_ControlXlateValue = sValue
    Case Else
        Beep
        sMsg = fld.Name & " uses a data type that is not supported by ERwin's code translation feature."
        MsgBox sMsg, MB_OK + MB_ICONEXCLAMATION, "ERwin for Visual Basic"
    End Select

End Function

Function er_CB_FieldValue (cb As Control, fld As Field) As Integer
    er_CB_FieldValue = er_CB_FieldXlateValue(cb, fld, "Y", "N")

End Function

Function er_CB_FieldXlateValue (cb As Control, fld As Field, sOn As String, sOff As String) As Integer
    Dim sMsg As String
    Dim sBuff As String


    If IsNull(fld) Then
    er_CB_FieldXlateValue = 2
    Else
    Select Case True
    Case er_FieldIsNumeric(fld)
        If fld = Val(sOff) Then
        er_CB_FieldXlateValue = 0
        ElseIf fld = Val(sOn) Then
        er_CB_FieldXlateValue = 1
        Else
        er_CB_FieldXlateValue = 2
        End If
    Case er_FieldIsString(fld)
        sBuff = fld
        sBuff = Trim(sBuff)

        If sBuff = sOff Then
        er_CB_FieldXlateValue = 0
        ElseIf sBuff = sOn Then
        er_CB_FieldXlateValue = 1
        Else
        er_CB_FieldXlateValue = 2
        End If
    Case Else
        Beep
        sMsg = fld.Name & " uses a data type that is not supported by ERwin's code translation feature."
        MsgBox sMsg, MB_OK + MB_ICONEXCLAMATION, "ERwin for Visual Basic"
    End Select
    End If

End Function

Sub er_ClearChangedFlags (axCtrl() As Control, abFlag() As Integer)
    Dim iMax As Integer
    Dim i As Integer

    iMax = UBound(axCtrl)

    For i = 0 To iMax - 1
    axCtrl(i).DataChanged = False
    abFlag(i) = False
    Next i

End Sub

Function er_CurrRowExists (ds As Data)
    Dim sBookMark As String
    Dim vValue As Variant

    On Error GoTo CurrRowExists_Handler
    er_CurrRowExists = True

    ' Try to cause the "no current record" error
    'sBookMark = ds.Recordset.Bookmark
    vValue = ds.Recordset.Fields(0)

    If ds.EditMode = dbEditAdd Then
    er_CurrRowExists = False
    End If

    Exit Function

CurrRowExists_Handler:
    Select Case Err
    Case 3021   ' Error: No current record
        er_CurrRowExists = False
        Resume Next
    Case 91     ' Object variable not set
        er_CurrRowExists = False
        Resume Next
    Case Else
        er_DisplayError (Err)
        Resume Next
    End Select

End Function

Sub er_DeleteButton (ds As Data)
    If ds.EditMode <> dbEditAdd Then
        er_ffDeleteRow ds
    Else
    'bNoSave = True
    MoveFromCurrRow ds
    'bNoSave = False
    End If

End Sub

Sub er_DisplayError (ErrNum As Integer)
    Beep
    MsgBox "Error:" & Str(ErrNum) & " - " & Error(ErrNum)

End Sub

Function er_DS_FieldsAvailable (ds As Data)
    er_DS_FieldsAvailable = er_CurrRowExists(ds) Or ds.EditMode <> DATA_EDITNONE
End Function

Sub er_DS_Update (Frm As Form, ds As Data, nNoRepos As Integer, bUpdateFailed As Integer)
    Dim bNew As Integer
    Dim bUpdating As Integer

    On Error GoTo DS_Update_Handler

    bUpdateFailed = False   'MAR

    If er_CurrRowExists(ds) = False Then
        bNew = True
    End If

'    If er_CurrRowExists(ds) Or ds.EditMode = dbEditAdd Then
    If ds.EditMode <> DATA_EDITNONE Then
    nNoRepos = nNoRepos + 1
    bUpdating = True
    ds.Recordset.Update
    bUpdating = False
    nNoRepos = nNoRepos - 1

    If bNew And Not bUpdateFailed And ds.Recordset.RecordCount Then
        ds.Recordset.MoveLast
        bNew = False
        End If
    End If

    Exit Sub

DS_Update_Handler:
    Select Case Err
    Case 3020   ' Error: Update without Add New or Edit
        Resume Next

        Case 3021   ' Error: No current record
            Resume Next

        Case Else
            er_DisplayError (Err)
        If bUpdating Then bUpdateFailed = True  'MAR
            Resume Next
    End Select


End Sub

Function er_ErrorPrompt (ErrNum As Integer, sQuestion As String, nButtons As Integer, sTitle As String)
    Dim sMsg As String

    If sQuestion = "" Then
    sQuestion = "Do you wish to retry the operation?"
    nButtons = vbYesNo Or vbExclamation
    End If

    If sTitle = "" Then
    sTitle = "Application Error"
    End If

    Beep
    sMsg = "Error:" & Str(ErrNum) & " - " & Error(ErrNum)
    sMsg = sMsg + String(2, Chr(13)) & sQuestion
    er_ErrorPrompt = MsgBox(sMsg, nButtons, sTitle)

End Function

Sub er_ffDeleteRow (ds As Data)
    If ds.Recordset.RecordCount = 0 Then Exit Sub

    On Error GoTo ErrorHandler
    ds.Recordset.Delete
    If Not er_CurrRowExists(ds) Then    'MAR, may not work in VB3
    MoveFromCurrRow ds
    End If
    If ds.Recordset.RecordCount = 0 Then
    'ds.Recordset.AddNew    'MAR replaced by next line
    ds.Refresh
    End If

er_ffDeleteRow_Done:
    Exit Sub

ErrorHandler:

    Select Case Err
    'Case 3197   ' Error: Data has changed, operation stopped
    '    ds.Recordset.Update
    '    Resume

    Case 3021   ' Error: No current record
        Resume Next

    Case 444    ' Method not applicable in this context
        Resume Next

    Case Else
        er_DisplayError (Err)
        Resume er_ffDeleteRow_Done
    End Select

End Sub

Function er_FieldIsNumeric (fld As Field) As Integer
    Select Case fld.Type
    Case DB_BOOLEAN
        er_FieldIsNumeric = True
    Case DB_BYTE
        er_FieldIsNumeric = True
    Case DB_INTEGER
        er_FieldIsNumeric = True
    Case DB_LONG
        er_FieldIsNumeric = True
    Case DB_CURRENCY
        er_FieldIsNumeric = True
    Case DB_SINGLE
        er_FieldIsNumeric = True
    Case DB_DOUBLE
        er_FieldIsNumeric = True
    Case Else
        er_FieldIsNumeric = False
    End Select

End Function

Function er_FieldIsString (fld As Field) As Integer
    Select Case fld.Type
    Case DB_TEXT
        er_FieldIsString = True
    Case DB_LONGBINARY
        er_FieldIsString = True
    Case DB_MEMO
        er_FieldIsString = True
    Case Else
        er_FieldIsString = False
    End Select

End Function

' Translates a display value into a data value using the specified ListItem array
' sDisplayVal: (Input)The display value to translate
' axList(): (Input) The ListItem array
' sDataVal: (Output) The translated value
' Returns: True if sDisplayVal was found in the list, sDataVal is the translated value.
'          False if sDisplayVal was not found in the list, sDataVal is sDisplayVal.
'==================================================================================
Function er_GetDataValue (sDisplayVal As String, axList() As ListItem, sDataVal As String)
    Dim iMax As Integer
    Dim i As Integer

    iMax = UBound(axList)

    For i = LBound(axList) To iMax - 1
    If sDisplayVal = axList(i).DisplayVal Then
        sDataVal = axList(i).DataVal
        er_GetDataValue = True
        Exit Function
    End If
    Next i

    er_GetDataValue = False
    sDataVal = sDisplayVal

End Function

' Translates a data value into a display value using the specified ListItem array
' sDataVal: (Input)The data value to translate
' axList(): (Input) The ListItem array
' sDisplayVal: (Output) The translated value
' Returns: True if sDataVal was found in the list, sDisplayVal is the translated value.
'          False if sDataVal was not found in the list, sDisplayVal is sDataVal.
'==================================================================================
Function er_GetDisplayValue (sDataVal As String, axList() As ListItem, sDisplayVal As String)
    Dim iMax As Integer
    Dim i As Integer
    Dim sTrimmedString As String

    sTrimmedString = Trim(sDataVal)
    iMax = UBound(axList)

    For i = LBound(axList) To iMax - 1
    If sTrimmedString = axList(i).DataVal Then
        sDisplayVal = axList(i).DisplayVal
        er_GetDisplayValue = True
        Exit Function
    End If
    Next i

    er_GetDisplayValue = False
    sDisplayVal = sTrimmedString

End Function

Sub er_LoadList (ListCtrl As Control, ListItems() As ListItem)
    Dim i As Integer

    For i = 0 To UBound(ListItems) - 1
    ListCtrl.AddItem ListItems(i).DisplayVal
    ListCtrl.ItemData(ListCtrl.NewIndex) = i
    Next
End Sub

Sub er_NewButton (Frm As Form, ds As Data, nNoRepos As Integer, bUpdateFailed As Integer)

    bUpdateFailed = False   'MAR, MB2
    'If er_CurrRowExists(ds) And ds.EditMode <> dbEditNone Then  'MAR line replaced
    If ds.EditMode <> dbEditNone Then
    er_DS_Update Frm, ds, nNoRepos, bUpdateFailed
    End If

    If Not bUpdateFailed Then   'MAR
    ds.Recordset.AddNew
    End If  'MAR

End Sub

Function er_NullValue (fld As Field) As Variant
    Select Case fld.Type
    Case DB_BOOLEAN
        er_NullValue = 0
    Case DB_BYTE
        er_NullValue = 0
    Case DB_INTEGER
        er_NullValue = 0
    Case DB_LONG
        er_NullValue = 0
    Case DB_CURRENCY
        er_NullValue = 0
    Case DB_SINGLE
        er_NullValue = 0
    Case DB_DOUBLE
        er_NullValue = 0
    Case DB_DATE
        er_NullValue = ""
    Case DB_TEXT
        er_NullValue = ""
    Case DB_LONGBINARY
        er_NullValue = ""
    Case DB_MEMO
        er_NullValue = ""
    End Select

End Function

Function er_ObjectSet (ds As Data) As Integer
    Dim iMode As Integer
    On Error GoTo ObjectSet_Handler

    er_ObjectSet = True

    ' Try to cause an error by accessing the data control
    If ds.EditMode = dbEditAdd Then iMode = 0 'no op

    Exit Function

ObjectSet_Handler:
    Select Case Err
    Case 91
        er_ObjectSet = False
        Resume Next

    Case Else
        er_DisplayError (Err)
        Resume Next
    End Select
End Function

Function er_PreValidate (ds As Data, Action As Integer, Save As Integer) As Integer
    er_PreValidate = False

    Select Case Action
    'Case DATA_ACTIONMOVEFIRST To DATA_ACTIONMOVELAST, DATA_ACTIONDELETE    'MAR removed
    Case DATA_ACTIONMOVEFIRST To DATA_ACTIONMOVELAST
        If ds.Recordset.RecordCount = 0 And Save = False Then
        'Action = DATA_ACTIONCANCEL 'MAR removed
            Save = False
            er_PreValidate = True
        End If

    Case DATA_ACTIONDELETE
    If ds.Recordset.RecordCount = 0 And Save = False Then
        Action = DATA_ACTIONCANCEL
        Save = False
        er_PreValidate = True
    End If

    Case DATA_ACTIONUPDATE
        If Save = False Then
            Action = DATA_ACTIONCANCEL
            er_PreValidate = True
        End If

    Case DATA_ACTIONBOOKMARK
        If Save = False Then
        er_PreValidate = True
        End If
    End Select

    Exit Function

PreVal_Handler:
    Select Case Err
    Case 3021   ' Error: No current record
        Beep
        Resume Next

    Case Else
        er_DisplayError (Err)
        Resume Next
    End Select

End Function

Sub er_RestoreChangedFlags (axCtrl() As Control, abFlag() As Integer)
    Dim iMax As Integer
    Dim i As Integer

    iMax = UBound(axCtrl)

    For i = 0 To iMax - 1
    axCtrl(i).DataChanged = abFlag(i)
    Next i

End Sub

Sub er_SaveChangedFlags (axCtrl() As Control, abFlag() As Integer)
    Dim iMax As Integer
    Dim i As Integer

    iMax = UBound(axCtrl)

    For i = 0 To iMax - 1
    abFlag(i) = axCtrl(i).DataChanged
    Next i

End Sub

Sub er_SetEditMode (ds As Data)
    On Error GoTo SetEditMode_Handler

    If er_CurrRowExists(ds) And ds.EditMode = dbEditNone Then
        ds.Recordset.Edit
    End If

    Exit Sub

SetEditMode_Handler:
    Select Case Err
    'Case 3197   ' Error: Data has changed, operation stopped
    '    Resume

    Case Else
        er_DisplayError (Err)
        Resume Next
    End Select

End Sub

Sub er_SetFieldToNull (fld As Field)
    Select Case fld.Type
    Case DB_BOOLEAN
        fld = 0
    Case DB_BYTE
        fld = 0
    Case DB_INTEGER
        fld = 0
    Case DB_LONG
        fld = 0
    Case DB_CURRENCY
        fld = 0
    Case DB_SINGLE
            fld = 0
    Case DB_DOUBLE
        fld = 0
    Case DB_DATE
        fld = Date
    Case DB_TEXT
        fld = ""
    Case DB_LONGBINARY
        fld = ""
    Case DB_MEMO
        fld = ""
    End Select

End Sub

Function er_SQLValue (ds As Data, sFldName As String)
    Dim bQuotes As Integer
    Dim sValue As String
    Dim vValue As Variant

    Select Case ds.Recordset(sFldName).Type
    Case DB_TEXT
        bQuotes = True
    Case DB_MEMO
        bQuotes = True
    Case Else
        bQuotes = False
    End Select

    If IsNull(ds.Recordset(sFldName)) Then
    vValue = er_NullValue(ds.Recordset(sFldName))
    sValue = vValue
    Else
    sValue = LTrim(RTrim(ds.Recordset(sFldName)))
    End If

    If bQuotes Then
        sValue = "'" & sValue & "'"
    End If

    er_SQLValue = sValue

End Function

Function erwAddDisplayFieldTranslation (ctlData As Data, strFieldName As String, varValue As Variant, udtTranslateList() As TranslateItem, nListCount As Integer)
    Dim nTmpListCount As Integer
    Dim nTmpListBound As Integer
    Dim udtTmpTranslateItem As TranslateItem

    nTmpListCount = nListCount
'   nTmpListBound = UBound(udtTranslateList)

'    If nTmpListBound = nTmpListCount Then
'        ReDim udtTranslateList(nTmpListBound + 20)
'    End If

    udtTmpTranslateItem.Item = ctlData.Recordset.Fields(strFieldName).OrdinalPosition
    udtTmpTranslateItem.Value = varValue
    udtTranslateList(nTmpListCount) = udtTmpTranslateItem

    erwAddDisplayFieldTranslation = nTmpListCount + 1
End Function

Function erwDoDisplayFieldTranslation (ctlData As Data, TranslateList() As TranslateItem, nListCount As Integer)
    Dim i As Integer
    Dim nCount As Integer

    For i = 0 To nListCount - 1
    If TranslateList(i).Item >= 0 Then
            ctlData.Recordset.Fields(TranslateList(i).Item) = TranslateList(i).Value
            nCount = nCount + 1
        End If
    Next
    erwDoDisplayFieldTranslation = True
End Function

Sub erwGetNewListField (ListCtrl As Control, DataCtrl As Data, FieldName As String, ListItems() As ListItem, bNoClick As Integer)
    Dim GstrCount As Integer
    Dim GStrIndex As Integer
    Dim ListCount As Integer
    Dim i As Integer
    Dim FieldValue As String
    Dim DisplayValue As String

    Err = 0
    GStrIndex = -1
    On Error Resume Next
    If IsNull(DataCtrl.Recordset.Fields(FieldName)) Then
    FieldValue = ""
    Else
    FieldValue = Trim(DataCtrl.Recordset.Fields(FieldName))
    End If
    GstrCount = UBound(ListItems)
    For i = 0 To GstrCount - 1
    If ListItems(i).DataVal = FieldValue Then
        GStrIndex = i
        DisplayValue = ListItems(i).DisplayVal
        Exit For
    End If
    Next

    If GStrIndex = -1 Then
    bNoClick = True
    ListCtrl.ListIndex = -1
    bNoClick = False
    If TypeOf ListCtrl Is ComboBox Then
        bNoClick = True
        ListCtrl.Text = FieldValue
        bNoClick = False
    End If
    Else
'                ListCtrl.Text = DisplayValue
    ListCount = ListCtrl.ListCount
    For i = 0 To ListCount - 1
        If ListCtrl.ItemData(i) = GStrIndex Then
        bNoClick = True
        ListCtrl.ListIndex = i
        bNoClick = False
        Exit For
       End If
    Next
    End If
End Sub

Function erwSetNewListField (ListCtrl As Control, DataCtrl As Data, FieldName As String, ListItems() As ListItem, bValidate As Integer, bNoClick As Integer)
    Dim i As Integer
    Dim ListIndex As Integer
    Dim GStrIndex As Long
    Dim FieldValue As String
    Dim bRetVal

    bRetVal = True
    Err = 0
    On Error Resume Next
    ListIndex = ListCtrl.ListIndex

    'If no list selection, see if typed in text is on list and select it if so
    If ListIndex = -1 Then
    If TypeOf ListCtrl Is ComboBox Then
        For i = 0 To ListCtrl.ListCount - 1
            If ListCtrl.List(i) = ListCtrl.Text Then
            bNoClick = True
            ListCtrl.ListIndex = i
            bNoClick = False
            Exit For
            End If
        Next
        End If
    End If

    'If still no selection, do validation/translation
    ListIndex = ListCtrl.ListIndex
    If ListIndex = -1 Then
    If bValidate Then
        bRetVal = False
    Else
        DataCtrl.Recordset.Fields(FieldName) = ListCtrl.Text
        End If
    Else
        GStrIndex = ListCtrl.ItemData(ListIndex)
        FieldValue = ListItems(GStrIndex).DataVal
        DataCtrl.Recordset.Fields(FieldName) = FieldValue
    End If

    erwSetNewListField = bRetVal
End Function

Sub MoveFromCurrRow (ds As Data)
    On Error GoTo MoveFrom_Handler

    ds.Recordset.MoveNext
    If ds.Recordset.EOF Then
        If ds.Recordset.RecordCount > 0 Then
            ds.Recordset.MovePrevious
    Else
        ds.Recordset.AddNew
    End If
    End If

    Exit Sub

MoveFrom_Handler:
    Select Case Err
    Case 3021   ' Error: No current record
        Resume Next

    Case Else
        er_DisplayError (Err)
        Resume Next
    End Select

End Sub