CD Actual Thematic 25: Programming/pc_actual_25.iso/Basic/GridOne/setup.EXE/MODUPGRADE.BAS

BASIC Source File | 2001-09-09 | 9.8 KB | 336 lines

Attribute VB_Name = "modUpgrade"
'-----------------------------------------------------------------------------
' This is a part of the GridONE ActiveX control.
' Copyright ⌐ 2000 Stinga
' All rights reserved.
'
' You have a right to use and distribute the GridONE sample files in original
' form or modified, provided that you agree that Stinga has no warranty,
' obligations, or liability for any sample application files.
'-----------------------------------------------------------------------------
Option Explicit

Private marFiles() As String

Private Type BEEGRID_KEAYWORDS
   Old As String
   New As String
End Type

Private marKeywords() As BEEGRID_KEAYWORDS

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long

'data buffer for the GetOpenFileName and GetSaveFileName functions
Private Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        iFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        Flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type

Private Function APIFilter(sIn)
    'prepares sIn for use as a filter string in API common dialog functions
    Dim lChrNdx As Long
    Dim sOneChr As String
    Dim sOutStr As String

    'convert any | characters to nulls
    For lChrNdx = 1 To Len(sIn)
        sOneChr = Mid$(sIn, lChrNdx, 1)
        If sOneChr = "|" Then
            sOutStr = sOutStr & Chr$(0)
        Else
            sOutStr = sOutStr & sOneChr
        End If
    Next

    'add a null to the end
    sOutStr = sOutStr & Chr$(0)

    'return sOutStr
    APIFilter = sOutStr

End Function

Private Sub ConvertFile(sFileName As String)
   Dim sData As String
   Dim i As Integer

   sData = ReadFile(sFileName)

   For i = 0 To UBound(marKeywords)
      sData = Replace(sData, marKeywords(i).Old, marKeywords(i).New, , , vbTextCompare)
   Next

   Clipboard.SetText sData
   WriteFile sFileName, sData
End Sub

Private Function CreateFileList(sProjectName As String) As Boolean
   Dim iFreeNum%, sFileData$, i%
   Dim varKeyWords As Variant
   Dim varTmp As Variant
   Dim sVBFile As String, iPos%
   Dim sPath As String

   On Error GoTo ReadFileError

   sPath = GetPath(sProjectName)
   ReDim marFiles(0) As String

   iFreeNum = FreeFile

   varKeyWords = Array("Form=", "Class=", "Module=")

   Open sProjectName For Input As iFreeNum

   If LOF(iFreeNum) = 0 Then GoTo ReadFileError

   Do While Not EOF(iFreeNum)
       Line Input #iFreeNum, sFileData
       Debug.Print sFileData
       For i = 0 To 2
         If InStr(1, sFileData, varKeyWords(i), vbTextCompare) > 0 Then
            varTmp = Split(sFileData, "=")

            iPos = InStr(varTmp(1), ";")

            If iPos > 0 Then
               sVBFile = sPath & Trim(Mid(varTmp(1), iPos + 1))
            Else
               sVBFile = sPath & Trim(varTmp(1))
            End If

            If FileDoesExist(sVBFile) Then
               ReDim Preserve marFiles(UBound(marFiles) + 1) As String
               marFiles(UBound(marFiles)) = sVBFile
               CreateFileList = True
            End If
         End If
       Next
   Loop

   Close #iFreeNum
   Exit Function
ReadFileError:
   MsgBox VBA.Error, vbExclamation
   Close #iFreeNum
End Function

Private Function GetPath(ByVal sOrig As String) As String
   Dim sPath As String

   sPath = StrReverse(sOrig)
   If ((Len(sPath) <> 0) And (InStr(sPath, "\") <> 0)) Then
      sPath = VBA.Left(sOrig, Len(sOrig) - InStr(sPath, "\") + 1)
   ElseIf ((Len(sPath) <> 0) And (InStr(sPath, "/") <> 0)) Then
      sPath = VBA.Left(sOrig, Len(sOrig) - InStr(sPath, "/") + 1)
   ElseIf ((Len(sPath) <> 0) And (InStr(sPath, ":") <> 0)) Then
      sPath = VBA.Left(sOrig, Len(sOrig) - InStr(sPath, ":") + 1)
   Else
      sPath = ""
   End If
   GetPath = sPath
End Function

Private Sub InitKeywords()
   ReDim marKeywords(4) As BEEGRID_KEAYWORDS

   marKeywords(0).Old = "BeeGridOLEDB10"
   marKeywords(0).New = "BeeGridOLEDB10"
   marKeywords(1).Old = "BeeGrid10"
   marKeywords(1).New = "BeeGrid10"
   marKeywords(2).Old = "BackColor"
   marKeywords(2).New = "BackColor"
   marKeywords(3).Old = "BeeGd10.ocx"
   marKeywords(3).New = "BeeGd10.ocx"
   marKeywords(4).Old = "BeeGdo10.ocx"
   marKeywords(4).New = "BeeGdo10.ocx"
'   marKeywords(5).Old = ""
'   marKeywords(5).New = ""
End Sub

Public Function ShowOpen( _
   Optional sFilter As String = "All Files *.*|*.*", _
   Optional sTitle As String = "Open file") As String
   'display the file dialog for ShowOpen or ShowSave
   Const DLG_ACTION = 1
   Const dlg_poPathMustExist = &H800
   Const dlg_poFileMustExist = &H1000
   Const dlg_poExplorer = &H80000
   Const dlg_Flags = dlg_poPathMustExist + dlg_poFileMustExist + dlg_poExplorer
   Const dlg_MaxSize = 255
   Const dlg_MaxFileSize = 1024
   Dim tOpenFile As OPENFILENAME
   Dim sFileNameBuff As String, sFileTitleBuff As String
   Dim sValue As String, lApiReturn As Long
   Dim lExtendedError As Long, n As Long
   Dim buf As String, dirBuf As String, sSep As String

   On Error GoTo ShowFileDialogError

   'init property buffers
   lApiReturn = 0  'APIReturn property
   lExtendedError = 0  'ExtendedError property

   'prepare tOpenFile data
   tOpenFile.lStructSize = Len(tOpenFile)
   tOpenFile.hwndOwner = 0
   tOpenFile.lpstrFilter = APIFilter(sFilter)
   tOpenFile.iFilterIndex = 0

   'tOpenFile.lpstrFile As Long - init from FileName property
   'prepare sFileNameBuff
   sFileNameBuff = ""
   sFileNameBuff = Space(dlg_MaxSize - 1)
   'trim to length of dlg_MaxFileSize - 1
   sFileNameBuff = Mid$(sFileNameBuff, 1, dlg_MaxFileSize - 1)
   'null terminate
   sFileNameBuff = sFileNameBuff & Chr$(0)
   tOpenFile.lpstrFile = sFileNameBuff

   'nMaxFile As Long - init from MaxFileSize property
   tOpenFile.nMaxFile = dlg_MaxFileSize

   'lpstrFileTitle As String - init from FileTitle property
   'prepare sFileTitleBuff
   sFileTitleBuff = sTitle
   'pad with spaces
   sFileTitleBuff = Space(dlg_MaxSize - 1)
   'trim to length of dlg_MaxFileSize - 1
   sFileTitleBuff = Mid$(sFileTitleBuff, 1, dlg_MaxFileSize - 1)
   'null terminate
   sFileTitleBuff = sFileTitleBuff & Chr$(0)
   tOpenFile.lpstrFileTitle = sFileTitleBuff

   'tOpenFile.lpstrInitialDir As String - init from InitDir property
   tOpenFile.lpstrInitialDir = App.Path

   'tOpenFile.lpstrTitle As String - init from DialogTitle property
   tOpenFile.lpstrTitle = "Open File"

   tOpenFile.Flags = dlg_Flags

   'tOpenFile.lpstrDefExt As String - init from DefaultExt property
   tOpenFile.lpstrDefExt = ""
   'call the GetOpenFileName API function
   lApiReturn = GetOpenFileName(tOpenFile)

    'handle return from GetOpenFileName API function
    Select Case lApiReturn
        Case 0  'user canceled
            'generate an error
            Err.Raise (2001)
            Exit Function
        Case 1  'user selected or entered a file
            'sFileName gets part of tOpenFile.lpstrFile to the left of first Chr$(0)
            ShowOpen = Left$(tOpenFile.lpstrFile, InStr(tOpenFile.lpstrFile, Chr$(0)) - 1)
        Case Else   'an error occured
            lExtendedError = CommDlgExtendedError
    End Select

Exit Function

ShowFileDialogError:
    Exit Function
End Function



Public Sub Main()
   Dim sFileName As String
   Dim sMsg As String, i%
   Dim bSilent As Boolean

   sFileName = Replace(Command, Chr(34), "")
   bSilent = True

   If Not FileDoesExist(sFileName) Then
      sFileName = ""
      bSilent = False
      sFileName = ShowOpen _
         ("VB Project Files *.vbp|*.vbp|All Files *.*|*.*")
   End If

   If Len(sFileName) = 0 Then End

   If CreateFileList(sFileName) Then
      InitKeywords
      For i = 1 To UBound(marFiles)
         ConvertFile marFiles(i)
         sMsg = sMsg & "*" & marFiles(i) & vbCrLf
      Next

      ConvertFile sFileName
      sMsg = sMsg & "*" & sFileName & vbCrLf
      If Not bSilent Then
         sMsg = "The following files were converted: " & vbCrLf & sMsg
         MsgBox sMsg, vbInformation
      End If
   End If
End Sub

Public Function ReadFile(sFileName As String) As String
   Dim iFreeNum%

   On Error Resume Next

   iFreeNum = FreeFile

   Open sFileName For Input As iFreeNum

   ReadFile = StrConv(InputB(LOF(1), iFreeNum), vbUnicode)
   Close #iFreeNum

End Function

Private Sub WriteFile _
   (sFileName As String, sFileData As String)
   Dim iFileNr As Integer

   iFileNr = FreeFile

   Open sFileName For Output As iFileNr

   Print #iFileNr, sFileData

   Close #iFileNr
End Sub

Private Function FileDoesExist(sFileName As String) As Boolean

   On Error GoTo FileExistError

   If (Len(VBA.Trim(sFileName)) = 0) Or (Len(Dir(sFileName)) = 0) Then
      FileDoesExist = False
   Else
      FileDoesExist = True
   End If

   Exit Function
FileExistError:
   FileDoesExist = False
   Exit Function
End Function