mdlmain.bas

游戏《家园》源码

        'Check and set lear read-only attribute
        If (nDBAttribs And vbReadOnly) <> 0 Then Call SetAttr(sDBFile, nDBAttribs And vbReadOnly)
    End If
    
    'Clear database flag
    bDBFlag = False
End Sub

Sub RollbackDB()
    'Check database flag
    If bDBFlag = False Then Exit Sub
    
    'Rollback changes
    wspCurrent.Rollback
    wspCurrent.BeginTrans
    
    'Clear flags
    bUndoFlag = False
End Sub

Sub CommitDB(ByVal sInfo As String)
    'Check database flag
    If bDBFlag = False Then Exit Sub
    
    'Set undo info
    sUndoInfo = sInfo

    'Commit changes
    wspCurrent.CommitTrans
    wspCurrent.BeginTrans

    'Set flags
    bUndoFlag = True
End Sub

Function OpenRecordSetByQuery(ByVal sQStr As String, rsQRecSet As Recordset, ByVal sDBStr As String)
    Dim sDBFileName As String
    
    'Default
    OpenRecordSetByQuery = False

    'Check database
    If sDBStr = "" Then
        'Set error handler for database
        On Error GoTo QDFErr
        
        'Set query string
        qdfMission.SQL = sQStr
    
        ' Create recordset
        Set rsQRecSet = qdfMission.OpenRecordset()
    Else
        'Set error handler for database
        On Error GoTo DBErr
          
        'Open database
        Set dbClipboard = wspCurrent.OpenDatabase(sDBStr)
        
        'Create query definition
        Set qdfClipboard = dbClipboard.CreateQueryDef("")
        
        'Set error handler for database
        On Error GoTo QDFErr
        
        'Set query string
        qdfClipboard.SQL = sQStr
    
        ' Create recordset
        Set rsQRecSet = qdfClipboard.OpenRecordset()
    End If
        
    'Check recordset
    If rsQRecSet.BOF = True Then
        'Close temporary recordset
        Call CloseRecordSetByQuery(rsQRecSet, sDBFileName)
        Exit Function
    End If
    
    'Success
    OpenRecordSetByQuery = True
    Exit Function
  
DBErr:
    'Inform user
    Call MsgBox("Error: Unable to open database " + sDBStr + "!", vbOKOnly Or vbExclamation, "MissionMan")
    Exit Function

QDFErr:
    'Inform user
    Call MsgBox("Error: Unable to perform SQL query (" + sQStr + ")!", vbOKOnly Or vbExclamation, "MissionMan")
    Exit Function
End Function

Sub CloseRecordSetByQuery(rsQRecSet As Recordset, ByVal sDBStr As String)
    'Close recordset
    rsQRecSet.Close
    
    'Check database
    If sDBStr = "" Then Exit Sub
    
    'Close query definitions
    qdfClipboard.Close
    
    'Close database
    dbClipboard.Close
End Sub

Function FileStr(ByVal sData As String) As String
    Dim nPos As Long
    
    'Set default
    FileStr = ""
    
    'Get filename
    sData = Dir(sData)
    
    'Get position of period character in string
    nPos = InStr(sData, ".")
    
    'If possible, truncate string at period character
    If nPos > 0 Then FileStr = Left(sData, nPos - 1)
End Function

Function TruncStr(ByVal sData As String) As String
    Dim nPos As Long
    
    'Set default
    TruncStr = ""
    
    'Get position of null character in C string
    nPos = InStr(sData, Chr(0))
    
    'If possible, truncate C string at null character
    If nPos > 0 Then TruncStr = Left(sData, nPos - 1)
End Function

Function FirstStr(ByVal sData As String, ByVal sSep As String) As String
    Dim nPos As Long
    
    'Set default
    FirstStr = ""
    
    'Get position of separator character in string
    nPos = InStr(sData, sSep)
        
    'If possible, truncate string at separator character
    If nPos > 0 Then
        'Get string
        FirstStr = Left(sData, nPos - 1)
        sData = Mid(sData, nPos + 1, Len(sData))
    Else
        'Get string
        FirstStr = sData
    End If
End Function

Function NextStr(ByVal sData As String, ByVal sSub As String, ByVal sSep As String) As String
    Dim nPos As Long
    
    'Set default
    NextStr = ""
    
    'Get position of sub-string in string
    nPos = InStr(sData + " ", sSub + " ")
        
    'If possible, truncate string at sub-string
    If nPos > 0 Then
        'Get string
        NextStr = FirstStr(Mid(sData, nPos + Len(sSub) + 1), sSep)
    End If
        
    'Check string
    If NextStr = "" Then NextStr = FirstStr(sData, sSep)
End Function

Sub FromClipboard()
    Dim nPos As Long
    
    Dim sClipboard As String
    Dim sRef As String
    Dim sFlag As String

    'Set defaults
    sCopyKey = ""
    bDelFlag = False
    sCopyFile = ""
    
    'Get data from clipboard
    sClipboard = Clipboard.GetText
    
    'Check data
    If sClipboard = "" Then Exit Sub
    
    'Get position of reference in data
    nPos = InStr(sClipboard, "|")
    If nPos > 0 Then
        'Get reference
        sRef = Left(sClipboard, nPos - 1)
        sClipboard = Mid(sClipboard, nPos + 1, Len(sClipboard))
    Else
        'Get reference
        sRef = sClipboard
        Exit Sub
    End If
    
    'Check reference
    If sRef <> MIS_REF_ID Then Exit Sub
    
    'Get position of list in data
    nPos = InStr(sClipboard, "|")
    If nPos > 0 Then
        'Get list
        sCopyKey = Left(sClipboard, nPos - 1)
        sClipboard = Mid(sClipboard, nPos + 1, Len(sClipboard))
    Else
        'Get list
        sCopyKey = sClipboard
        Exit Sub
    End If
    
    'Get position of flag in data
    nPos = InStr(sClipboard, "|")
    If nPos > 0 Then
        'Get flag
        sFlag = Left(sClipboard, nPos - 1)
        If Val(sFlag) > 0 Then bDelFlag = True
        If Val(sFlag) <= 0 Then bDelFlag = False
        sClipboard = Mid(sClipboard, nPos + 1, Len(sClipboard))
    Else
        'Get flag
        sFlag = sClipboard
        If Val(sFlag) > 0 Then bDelFlag = True
        If Val(sFlag) <= 0 Then bDelFlag = False
        Exit Sub
    End If
    
    'Get position of file in data
    nPos = InStr(sClipboard, "|")
    If nPos > 0 Then
        'Get file
        sCopyFile = Left(sClipboard, nPos - 1)
        If sCopyFile = sDBFile Then
            sCopyFile = ""
        Else
            bDelFlag = False
        End If
        sClipboard = Mid(sClipboard, nPos + 1, Len(sClipboard))
    Else
        'Get file
        sCopyFile = sClipboard
        If sCopyFile = sDBFile Then
            sCopyFile = ""
        Else
            bDelFlag = False
        End If
    End If
End Sub

Sub ToClipboard()
    Dim sFlag As String
    
    'Get flag
    If bDelFlag = True Then sFlag = "1"
    If bDelFlag = False Then sFlag = "0"
    
    'Put data in clipboard
    Clipboard.Clear
    Clipboard.SetText (MIS_REF_ID + "|" + sCopyKey + "|" + sFlag + "|" + sDBFile)
End Sub

Function DecodeEnv(ByVal sDir As String) As String
    Dim nPos As Long
    
    Dim sVar As String
    Dim sReg As String

    'Set default
    DecodeEnv = ""
    
    'Check directory
    If sDir = "" Then Exit Function
    
    'Append \ character
    If Mid(sDir, Len(sDir)) <> "\" Then sDir = sDir + "\"
    
    'Set default
    DecodeEnv = sDir
    
    'Check for application path
    If Left(sDir, 1) = "~" Then
        'Remove ~ character
        sDir = Mid(sDir, 2)
    
        'Get application path
        sVar = App.Path
        If Mid(sVar, Len(sVar)) <> "\" Then sVar = sVar + "\"
        
        'Truncate at \ character
        nPos = InStr(sDir, "\")
        If nPos > 0 Then
            'Get path
            DecodeEnv = sVar + Mid(sDir, nPos + 1)
            Exit Function
        Else
            'Get path
            DecodeEnv = sVar
            Exit Function
        End If
        Exit Function
    End If
    
    'Check for environment variable
    If Left(sDir, 1) = "%" Then
        'Remove % character
        sDir = Mid(sDir, 2)
    
        'Truncate at \ character
        nPos = InStr(sDir, "\")
        If nPos > 0 Then
            'Get environment variable
            sVar = Environ(Left(sDir, nPos - 1))
            If sVar <> "" Then
                'Append \ character
                If Mid(sVar, Len(sDir)) <> "\" Then sVar = sVar + "\"
                DecodeEnv = sVar + Mid(sDir, nPos + 1)
                Exit Function
            End If
            
            'Set environment variable
            sVar = Left(sDir, nPos - 1)
        Else
            'Get environment variable
            sVar = Environ(sDir)
            If sVar <> "" Then
                DecodeEnv = sVar
                Exit Function
            End If
            
            'Set environment variable
            sVar = sDir
        End If
        
        'Inform user
        Call MsgBox("Error: Unable to find environment variable (" + sVar + ")!", vbOKOnly Or vbExclamation, "MissionMan")
        Exit Function
    End If
    
    'Check for registry entry
    If Left(sDir, 1) = "$" Then
        'Remove $ character
        sDir = Mid(sDir, 2)
    
        'Get registry key
        Call misGetVal(MIS_SEC_COM, MIS_KEY_REGK, sReg, MIS_MOD_CFG)
        sReg = TruncStr(sReg)
        If sReg = "" Then
            'Set registry value
            sVar = sDir
            
            'Inform user
            Call MsgBox("Error: Unable to find registry key (" + sVar + ")!", vbOKOnly Or vbExclamation, "MissionMan")
            Exit Function
        End If
        
        'Truncate at \ character
        nPos = InStr(sDir, "\")
        If nPos > 0 Then
            'Get registry value
            Call misGetVal(sReg, Left(sDir, nPos - 1), sVar, MIS_MOD_REG)
            sVar = TruncStr(sVar)
            If sVar <> "" Then
                'Append \ character
                If Mid(sVar, Len(sDir)) <> "\" Then sVar = sVar + "\"
                DecodeEnv = sVar + Mid(sDir, nPos + 1)
                Exit Function
            End If
            
            'Set registry value
            sVar = Left(sDir, nPos - 1)
        Else
            'Get registry value
            Call misGetVal(sReg, sDir, sVar, MIS_MOD_REG)
            sVar = TruncStr(sVar)
            If sVar <> "" Then
                DecodeEnv = sVar
                Exit Function
            End If
            
            'Set registry value
            sVar = sDir
        End If
        
        'Inform user
        Call MsgBox("Error: Unable to find registry value (" + sVar + ")!", vbOKOnly Or vbExclamation, "MissionMan")
    End If
End Function

Function EncodeEnv(ByVal sDir As String) As String
    Dim nInd As Integer
    Dim nPos As Long
    
    Dim sLine As String
    Dim sVar As String
    Dim sReg As String

    'Set default
    EncodeEnv = sDir
    
    'Check directory
    If sDir = "" Then Exit Function
    
    'Get application path
    sVar = App.Path
    If Mid(sVar, Len(sVar)) <> "\" Then sVar = sVar + "\"
        
    'Set application path
    If InStr(1, sDir, sVar, vbTextCompare) > 0 Then
        EncodeEnv = "~\" + Mid(sDir, Len(sVar) + 1)
        Exit Function
    End If
    
    'Reset index
    nInd = 1
    
    'Loop
    Do
        'Get environment variable
        sLine = Environ(nInd)
        If sLine = "" Then Exit Do
        
        'Check environment variable
        If InStr(1, sLine, MIS_ENV_VAR, vbTextCompare) > 0 Then
            'Truncate at = character
            nPos = InStr(sLine, "=")
            
            'Append \ character
            sVar = Mid(sLine, nPos + 1)
            If Mid(sVar, Len(sVar)) <> "\" Then sVar = sVar + "\"
            
            'Set environment variable
            If InStr(1, sDir, sVar, vbTextCompare) > 0 Then
                EncodeEnv = "%" + Left(sLine, nPos - 1) + "\" + Mid(sDir, Len(sVar) + 1)
                Exit Function
            End If
        End If
        
        'Increment index
        nInd = nInd + 1
    Loop
    
    'Get registry key
    Call misGetVal(MIS_SEC_COM, MIS_KEY_REGK, sReg, MIS_MOD_CFG)
    sReg = TruncStr(sReg)
    If sReg = "" Then Exit Function
    
    'Reset index
    nInd = 0
    
    'Loop
    Do
        'Get registry value
        Call misGetVal(sReg, "#" + Trim(Str(nInd)), sLine, MIS_MOD_REG)
        sLine = TruncStr(sLine)
        If sLine = "" Then Exit Do
        
        'Check registry value
        If InStr(1, sLine, MIS_ENV_VAR, vbTextCompare) > 0 Then
            'Truncate at = character
            nPos = InStr(sLine, "=")
            
            'Append \ character
            sVar = Mid(sLine, nPos + 1)
            If Mid(sVar, Len(sVar)) <> "\" Then sVar = sVar + "\"
            
            'Set environment variable
            If InStr(1, sDir, sVar, vbTextCompare) > 0 Then
                EncodeEnv = "$" + Left(sLine, nPos - 1) + "\" + Mid(sDir, Len(sVar) + 1)
                Exit Function
            End If
        End If
        
        'Increment index
        nInd = nInd + 1
    Loop
End Function