modiohandler.bas

一个把VB原代码转换为VC原代码的软件代码。

Attribute VB_Name = "ModIOHandler"
' -------------------------------------
' VB2Cpp - Visual Basic to C++ translator.
' Copyright (C) 2002-2003 Franck Charlet.
'
' VB2Cpp is free software; you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation; either version 2, or (at your option)
' any later version.
'
' VB2Cpp is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU General Public License for more details.
'
' You should have received a copy of the GNU General Public License
' along with VB2Cpp; see the file Copying.txt.  If not, write to
' the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
' Boston, MA 02111-1307, USA.
' -------------------------------------
' Input/Output files handling
' -------------------------------------

Option Explicit

' --- Variables --- '
Public FileInput As Long
Public FileOutput As Long
Public BytesWritten As Long
Public BytesReaded As Long
Public FileLength As Long
Public FileLenHigh As Long
Public FileMem As Long
Public FileReaded As Long
Public VCLibDir As String

' --- Emit a String in output file --- '
Public Sub WriteOut(EMTxt As String)
    EMTxt = Replace(EMTxt, "\n", Chr(13) & Chr(10))
    WriteFile FileOutput, ByVal EMTxt, Len(EMTxt), BytesWritten, 0
End Sub

' --- Set environment --- '
Public Sub SetEnv()
    TempProjectName = App.Path & "\TmpOut.ini"
    PrefsIniFile = App.Path & "\VB2Cpp.ini"
End Sub

' --- Create temporary file --- '
Public Sub AlloctempFile()
    FileOutput = OpenFileW(TempProjectName)
End Sub

' --- Free main files --- '
Public Sub FreeFiles()
    If FileOutput <> 0 Then CloseHandle FileOutput
    If FileInput <> 0 Then CloseHandle FileInput
End Sub

' --- Init main context (check and open project file) --- '
Public Function InitConversionContext() As Boolean
    If FileExist(ProjectName) = 0 Then
        WriteText "*** Fatal error: can't find project file:\n" & ProjectName & ".\n"
        Exit Function
    End If
    If FileExist(VCLibDir) = 0 Then
        WriteText "*** Fatal error: can't find Visual C++ libraries dir:\n" & VCLibDir & ".\n"
        Exit Function
    End If
    ProjectDirectory = GetDirectory(ProjectName)
    If Right(ProjectDirectory, 1) <> "\" Then ProjectDirectory = ProjectDirectory & "\"
    FileInput = OpenFileR(ProjectName)
    InitConversionContext = True
End Function

' --- Load a file into a memory block --- '
' Returns number of bytes in FileReaded
Public Function LoadFileIntoMemory(FileHandle As Long) As Long
    FileLength = GetFileSize(FileHandle, FileLenHigh)
    LoadFileIntoMemory = AllocMem(FileLength)
    ReadFile FileHandle, ByVal LoadFileIntoMemory, FileLength, FileReaded, 0
End Function

' --- Open a file for reading --- '
Public Function OpenFileR(FileNR As String) As Long
    Dim RSecu As SECURITY_ATTRIBUTES
    RSecu.nLength = Len(RSecu)
    RSecu.lpSecurityDescriptor = 0
    RSecu.bInheritHandle = -1
    OpenFileR = CreateFile(FileNR, GENERIC_READ, FILE_SHARE_READ, RSecu, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
End Function

' --- Open a file for writing --- '
Public Function OpenFileW(FileNW As String) As Long
    Dim WSecu As SECURITY_ATTRIBUTES
    WSecu.nLength = Len(WSecu)
    WSecu.lpSecurityDescriptor = 0
    WSecu.bInheritHandle = -1
    OpenFileW = CreateFile(FileNW, GENERIC_WRITE, 0, WSecu, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
End Function

' --- Read .ini value --- '
Public Function IniReadKey(Section As String, Key As String, File As String) As String
    Dim RetSec As String
    Dim CheckNull As Long
    RetSec = Space(4096)
    GetPrivateProfileString Section, Key, "", RetSec, 4096, File
    CheckNull = lstrlen(RetSec)
    If CheckNull = 0 Then Exit Function
    IniReadKey = Mid(RetSec, 1, CheckNull)
End Function

' --- Write .ini value --- '
Public Sub IniWriteKey(Section As String, Key As String, Value As String, File As String)
    WritePrivateProfileString Section, Key, Value, File
End Sub

' --- Extract the directory from a filename --- '
Public Function GetDirectory(FileName As String) As String
    Dim i As Long
    Dim PosInStr As Long
    GetDirectory = ""
    PosInStr = Len(FileName)
    For i = 1 To PosInStr Step 1
        If Mid(FileName, PosInStr, 1) = "\" Then
            GetDirectory = left(FileName, PosInStr)
            Exit For
        End If
        PosInStr = PosInStr - 1
    Next
End Function

' --- Remove the extension of a filename --- '
Public Function RemoveFileExtension(FileName As String) As String
    Dim ResultValue As String
    Dim RemExtPos As Long
    Dim i As Long
    RemExtPos = lstrlen(FileName)
    For i = 0 To RemExtPos Step 1
        If RemExtPos = 0 Then Exit For
        If lstrcmp(Mid(FileName, RemExtPos, 1), ".") = 0 Then Exit For
        RemExtPos = RemExtPos - 1
    Next
    If RemExtPos = 0 Then
        ResultValue = FileName
    Else
        ResultValue = left(FileName, RemExtPos - 1)
    End If
    RemoveFileExtension = ResultValue
End Function

' --- Replace the extension of a filename --- '
Public Function ReplaceFileExtension(FileName As String, NewExtension As String) As String
    Dim ResultValue As String
    Dim ReplExtPos As Long
    Dim i As Long
    ReplExtPos = lstrlen(FileName)
    For i = 0 To ReplExtPos Step 1
        If ReplExtPos = 0 Then Exit For
        If lstrcmp(Mid(FileName, ReplExtPos, 1), ".") = 0 Then Exit For
        ReplExtPos = ReplExtPos - 1
    Next
    If ReplExtPos = 0 Then
        ResultValue = FileName & "." & NewExtension
    Else
        ResultValue = left(FileName, ReplExtPos) & NewExtension
    End If
    ReplaceFileExtension = ResultValue
End Function

' --- Extract a filename --- '
Public Function GetFileName(FileName As String) As String
    Dim FArray() As String
    If lstrlen(FileName) = 0 Then Exit Function
    FArray() = Split(FileName, "\")
    If UBound(FArray()) = -1 Then Exit Function
    GetFileName = FArray(UBound(FArray()))
End Function

' --- Write a text in an output file --- '
Public Sub WriteTerm(StrToWrite As String)
    WriteFile OutModuleHandle, ByVal StrToWrite, Len(StrToWrite), ProjectBytesW, 0
End Sub

' --- Write a text in the header output file --- '
Public Sub WriteInHead(StrToWrite As String)
    WriteFile OutHeaderHandle, ByVal StrToWrite, Len(StrToWrite), ProjectBytesW, 0
End Sub

' --- Write a text in the Visual C project file --- '
Public Sub WriteInCPrj(StrToWrite As String)
    WriteFile OutCPrjHandle, ByVal StrToWrite, Len(StrToWrite), ProjectBytesW, 0
End Sub

' --- Write a text in the Visual C workspace file --- '
Public Sub WriteInCWorkSpc(StrToWrite As String)
    WriteFile OutCPrjWorkSpcHandle, ByVal StrToWrite, Len(StrToWrite), ProjectBytesW, 0
End Sub

' --- Write a text in the user types header output file --- '
Public Sub WriteInHType(StrToWrite As String)
    WriteFile OutHTypeHandle, ByVal StrToWrite, Len(StrToWrite), ProjectBytesW, 0
End Sub

' --- Write a text in the constants header output file --- '
Public Sub WriteInHConst(StrToWrite As String)
    WriteFile OutHConstHandle, ByVal StrToWrite, Len(StrToWrite), ProjectBytesW, 0
End Sub

' --- Write a text in the variables header output file --- '
Public Sub WriteInVar(StrToWrite As String)
    WriteFile OutHVarHandle, ByVal StrToWrite, Len(StrToWrite), ProjectBytesW, 0
End Sub

' --- Write original VB sourcecode line --- '
Public Sub WriteVBLine(hFile As Long)
    Dim LnToWrite As String
    If OutputVBLines = True Then
        LnToWrite = "// >>> " & OutModuleString & vbNewLine
        WriteFile hFile, ByVal LnToWrite, Len(LnToWrite), ProjectBytesW, 0
    End If
End Sub

' --- Quick exit --- '
Public Sub Panic(PanicText As String)
    WriteText PanicText
    CloseInFile
    CloseOutFile
    CloseHeaderFile
End Sub

' --- Close input file --- '
Public Sub CloseInFile()
    FreeMem CurrentModuleMem
    CloseHandle CurrentModuleHandle
End Sub

' --- Close output file --- '
Public Sub CloseOutFile()
    If OutModuleHandle <> 0 Then CloseHandle OutModuleHandle
    OutModuleHandle = 0
End Sub

' --- Close all opened files --- '
Public Sub CloseHeaderFile()
    If OutCPrjWorkSpcHandle <> 0 Then CloseHandle OutCPrjWorkSpcHandle
    OutCPrjWorkSpcHandle = 0
    If OutCPrjHandle <> 0 Then CloseHandle OutCPrjHandle
    OutCPrjHandle = 0
    If OutHeaderHandle <> 0 Then CloseHandle OutHeaderHandle
    OutHeaderHandle = 0
    If OutHVarHandle <> 0 Then CloseHandle OutHVarHandle
    OutHVarHandle = 0
    If OutHConstHandle <> 0 Then CloseHandle OutHConstHandle
    OutHConstHandle = 0
    If OutHTypeHandle <> 0 Then CloseHandle OutHTypeHandle
    OutHTypeHandle = 0
End Sub

' --- Search a given file or directory --- '
Public Function FileExist(FileToSearch As String) As Long
    Dim ReturnValue As Long
    Dim FindDat As WIN32_FIND_DATA
    Dim hFindFile As Long
    Dim RealFileToSearch As String
    RealFileToSearch = FileToSearch
    If lstrcmp(Right(FileToSearch, 1), "\") = 0 Then RealFileToSearch = Mid(FileToSearch, 1, lstrlen(FileToSearch) - 1)
    hFindFile = FindFirstFile(RealFileToSearch, FindDat)
    If hFindFile <> INVALID_HANDLE_VALUE Then
        FindClose hFindFile
        ReturnValue = 1
    Else
        ReturnValue = 0
    End If
    FileExist = ReturnValue
End Function

' --- Allocate memory --- '
' Out: Allocated Memory address
Public Function AllocMem(Size As Long) As Long
    If Size <> 0 Then AllocMem = GlobalAlloc(GMEM_FIXED Or GMEM_ZEROINIT, Size)
End Function

' --- Free allocated memory --- '
Public Function FreeMem(MemBlock As Long) As Long
    If MemBlock <> 0 Then FreeMem = GlobalFree(MemBlock)
End Function

' --- Return an argument from command line --- '
Public Function GetArgument(Arguments As String, ArgNumber As Long) As String
    Dim ArgsToGet As String
    Dim i As Long
    Dim ArgStart As Long
    Dim CurArgChar As String
    Dim ArgCharTocheck As String
    ArgsToGet = Trim(Arguments)
    ArgStart = 1
RetrieveArg:
    CurArgChar = Mid(ArgsToGet, ArgStart, 1)
    ArgCharTocheck = " "
    If lstrcmpi(CurArgChar, Chr(34)) = 0 Then
        ArgCharTocheck = CurArgChar
        ArgStart = ArgStart + 1
    End If
    For i = ArgStart To lstrlen(ArgsToGet) Step 1
        CurArgChar = Mid(ArgsToGet, i, 1)
        If lstrcmpi(CurArgChar, ArgCharTocheck) = 0 Then Exit For
    Next
    ArgNumber = ArgNumber - 1
    If ArgNumber >= 0 Then
        ArgStart = i + 1
        GoTo RetrieveArg
    End If
    GetArgument = Mid(ArgsToGet, ArgStart, i - ArgStart)
End Function

' --- Read config VB2Cpp.ini file --- '
Public Sub ReadPrefs()
    Dim KeyResult As String
    LookForDoubleSmb = False
    DisplayWarns = False
    StopAtError = False
    OutputVBLines = False
    DefReturnType = 0
    KeyResult = IniReadKey("CONFIG", "DoubleSymbols", PrefsIniFile)
    If KeyResult <> "" Then If KeyResult = "1" Then LookForDoubleSmb = True
    KeyResult = IniReadKey("CONFIG", "DisplayWarnings", PrefsIniFile)
    If KeyResult <> "" Then If KeyResult = "1" Then DisplayWarns = True
    KeyResult = IniReadKey("CONFIG", "StopAtError", PrefsIniFile)
    If KeyResult <> "" Then If KeyResult = "1" Then StopAtError = True
    KeyResult = IniReadKey("CONFIG", "OutputVBLines", PrefsIniFile)
    If KeyResult <> "" Then If KeyResult = "1" Then OutputVBLines = True
    KeyResult = IniReadKey("CONFIG", "DefaultFncReturns", PrefsIniFile)
    If KeyResult <> "" Then DefReturnType = KeyResult
    KeyResult = IniReadKey("CONFIG", "VCLibDir", PrefsIniFile)
    If KeyResult <> "" Then
        VCLibDir = KeyResult
    Else
        VCLibDir = "C:\Program Files\Microsoft Visual Studio\VC98\Lib"
    End If
    KeyResult = IniReadKey("CONFIG", "BackGroundColor", PrefsIniFile)
    DumpBackColor = &HFFFFFF
    If KeyResult <> "" Then DumpBackColor = KeyResult
    KeyResult = IniReadKey("CONFIG", "ForeGroundColor", PrefsIniFile)
    DumpForeColor = 0
    If KeyResult <> "" Then DumpForeColor = KeyResult
End Sub