Attribute VB_Name = "OLEExport"
Option Explicit

Const temp_file_name = "temporary.temp"

Public mo_FSO As Object

Public Declare Function GetProcessMemoryInfo Lib "PSAPI.DLL" (ByVal hProcess As Long, ppsmemCounters As PROCESS_MEMORY_COUNTERS, ByVal cb As Long) As Long
Public Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Public Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Public Declare Function CloseHandle Lib "Kernel32.dll" (ByVal Handle As Long) As Long
Public Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Public Declare Function EnumProcesses Lib "PSAPI.DLL" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Public Declare Function GetModuleFileNameExA Lib "PSAPI.DLL" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As String, ByVal nSize As Long) As Long
Public Declare Function EnumProcessModules Lib "PSAPI.DLL" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Public Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer
Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Public Declare Function GetProcessTimes Lib "kernel32" (ByVal hProcess As Long, lpCreationTime As FILETIME, lpExitTime As FILETIME, lpKernelTime As FILETIME, lpUserTime As FILETIME) As Long
Public Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Public Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type

Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type



Public Const PROCESS_QUERY_INFORMATION = 1024
Public Const PROCESS_VM_READ = 16
Public Const MAX_PATH = 260
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const SYNCHRONIZE = &H100000
Public Const PROCESS_ALL_ACCESS = &H1F0FFF
Public Const TH32CS_SNAPPROCESS = &H2&
Public Const hNull = 0
Public Const WIN95_System_Found = 1
Public Const WINNT_System_Found = 2
Public Const Default_Log_Size = 10000000
Public Const Default_Log_Days = 0
Public Const SPECIFIC_RIGHTS_ALL = &HFFFF
Public Const STANDARD_RIGHTS_ALL = &H1F0000


Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type


Type PROCESS_MEMORY_COUNTERS
cb As Long
PageFaultCount As Long
PeakWorkingSetSize As Long
WorkingSetSize As Long
QuotaPeakPagedPoolUsage As Long
QuotaPagedPoolUsage As Long
QuotaPeakNonPagedPoolUsage As Long
QuotaNonPagedPoolUsage As Long
PagefileUsage As Long
PeakPagefileUsage As Long
End Type


Public Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long ' This process
th32DefaultHeapID As Long
th32ModuleID As Long ' Associated exe
cntThreads As Long
th32ParentProcessID As Long ' This process's parent process
pcPriClassBase As Long ' Base priority of process threads
dwFlags As Long
szExeFile As String * 260 ' MAX_PATH
End Type


Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long '1 = Windows 95.
'2 = Windows NT
szCSDVersion As String * 128
End Type
Public IsRunning As Boolean



Public Function GetProcesses(ByVal EXEName As String) As Boolean

Dim booResult As Boolean
Dim lngLength As Long
Dim lngProcessID As Long
Dim strProcessName As String
Dim lngSnapHwnd As Long
Dim udtProcEntry As PROCESSENTRY32
Dim lngCBSize As Long 'Specifies the size, In bytes, of the lpidProcess array
Dim lngCBSizeReturned As Long 'Receives the number of bytes returned
Dim lngNumElements As Long
Dim lngProcessIDs() As Long
Dim lngCBSize2 As Long
Dim lngModules(1 To 200) As Long
Dim lngReturn As Long
Dim strModuleName As String
Dim lngSize As Long
Dim lngHwndProcess As Long
Dim lngLoop As Long
Dim b As Long
Dim c As Long
Dim e As Long
Dim d As Long
Dim pmc As PROCESS_MEMORY_COUNTERS
Dim lret As Long
Dim strProcName2 As String
Dim strProcName As String

GetProcesses = False
IsRunning = False
'Turn on Error handler
On Error GoTo Error_handler

booResult = False

EXEName = UCase$(Trim$(EXEName))
lngLength = Len(EXEName)

'ProcessInfo.bolRunning = False

Select Case getVersion()
'I'm not bothered about windows 95/98 becasue this class probably wont be used on it anyway.
Case WIN95_System_Found 'Windows 95/98

Case WINNT_System_Found 'Windows NT

lngCBSize = 8 ' Really needs To be 16, but Loop will increment prior to calling API
lngCBSizeReturned = 96

Do While lngCBSize <= lngCBSizeReturned
DoEvents
'Increment Size
lngCBSize = lngCBSize * 2
'Allocate Memory for Array
ReDim lngProcessIDs(lngCBSize / 4) As Long
'Get Process ID's
lngReturn = EnumProcesses(lngProcessIDs(1), lngCBSize, lngCBSizeReturned)
Loop

'Count number of processes returned
lngNumElements = lngCBSizeReturned / 4
'Loop thru each process

For lngLoop = 1 To lngNumElements
DoEvents

'Get a handle to the Process and Open
lngHwndProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lngProcessIDs(lngLoop))

If lngHwndProcess <> 0 Then
'Get an array of the module handles for the specified process
lngReturn = EnumProcessModules(lngHwndProcess, lngModules(1), 200, lngCBSize2)

'If the Module Array is retrieved, Get the ModuleFileName
If lngReturn <> 0 Then

'Buffer with spaces first to allocate memory for byte array
strModuleName = Space(MAX_PATH)

'Must be set prior to calling API
lngSize = 500

'Get Process Name
lngReturn = GetModuleFileNameExA(lngHwndProcess, lngModules(1), strModuleName, lngSize)

'Remove trailing spaces
strProcessName = Left(strModuleName, lngReturn)

Dim TxtCmp As String
TxtCmp = GetProcExeName(strProcessName, Len(EXEName))
If StrComp(TxtCmp, EXEName, vbTextCompare) = 0 Then

GetProcesses = True
End If

'Check for Matching Upper case result
strProcessName = UCase$(Trim$(strProcessName))

strProcName2 = GetElement(Trim(Replace(strProcessName, Chr$(0), "")), "\", 0, 0, GetNumElements(Trim(Replace(strProcessName, Chr$(0), "")), "\") - 1)

If strProcName2 = EXEName Then

'Get the Site of the Memory Structure
pmc.cb = LenB(pmc)

lret = GetProcessMemoryInfo(lngHwndProcess, pmc, pmc.cb)
Dim ProcessCreationTime As FILETIME
Dim ProcessExitTime As FILETIME
Dim ProcessKernelTime As FILETIME
Dim ProcessUserTime As FILETIME
Dim SysTime As SYSTEMTIME
GetProcessTimes lngHwndProcess, ProcessCreationTime, ProcessExitTime, ProcessKernelTime _
, ProcessUserTime

FileTimeToSystemTime ProcessKernelTime, SysTime

'IsRunning = True

Debug.Print EXEName & "::" & CStr(pmc.PagefileUsage / 1024)


End If
End If
End If
'Close the handle to this process
lngReturn = CloseHandle(lngHwndProcess)
DoEvents
Next

End Select

IsProcessRunning_Exit:

'Exit early to avoid error handler
Exit Function
Error_handler:
Err.Raise Err, Err.Source, "ProcessInfo", Error
Resume Next
End Function


Private Function getVersion() As Long

Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer

osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionExA(osinfo)
getVersion = osinfo.dwPlatformId

End Function


Private Function StrZToStr(s As String) As String
StrZToStr = Left$(s, Len(s) - 1)
End Function



Public Function GetElement(ByVal strList As String, ByVal strDelimiter As String, ByVal lngNumColumns As Long, ByVal lngRow As Long, ByVal lngColumn As Long) As String

Dim lngCounter As Long

' Append delimiter text to the end of the list as a terminator.
strList = strList & strDelimiter

' Calculate the offset for the item required based on the number of columns the list
' 'strList' has i.e. 'lngNumColumns' and from which row the element is to be
' selected i.e. 'lngRow'.
lngColumn = IIf(lngRow = 0, lngColumn, (lngRow * lngNumColumns) + lngColumn)

' Search for the 'lngColumn' item from the list 'strList'.
For lngCounter = 0 To lngColumn - 1

' Remove each item from the list.
strList = Mid$(strList, InStr(strList, strDelimiter) + Len(strDelimiter), Len(strList))

' If list becomes empty before 'lngColumn' is found then just
' return an empty string.
If Len(strList) = 0 Then
GetElement = ""
Exit Function
End If

Next lngCounter

' Return the sought list element.
GetElement = Left$(strList, InStr(strList, strDelimiter) - 1)

End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Function GetNumElements (ByVal strList As String,
' ByVal strDelimiter As String)
' As Integer
'
' strList = The element list.
' strDelimiter = The delimiter by which the elements in
' 'strList' are seperated.
'
' The function returns an integer which is the count of the
' number of elements in 'strList'.
'
' Author: Roger Taylor
'
' Date:26/12/1998
'
' Additional Information:
'
' Revision History:
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Function GetNumElements(ByVal strList As String, ByVal strDelimiter As String) As Integer

Dim intElementCount As Integer

' If no elements in the list 'strList' then just return 0.
If Len(strList) = 0 Then
GetNumElements = 0
Exit Function
End If

' Append delimiter text to the end of the list as a terminator.
strList = strList & strDelimiter

' Count the number of elements in 'strlist'
While InStr(strList, strDelimiter) > 0
intElementCount = intElementCount + 1
strList = Mid$(strList, InStr(strList, strDelimiter) + 1, Len(strList))
Wend

' Return the number of elements in 'strList'.
GetNumElements = intElementCount

End Function
Private Function GetProcExeName(tStr As String, nChar As Integer) As String
tStr = Trim(tStr)
GetProcExeName = GetProcExeName & Mid(tStr, Len(tStr) - nChar + 1, nChar)

End Function


Public Function Load_A_Com() As Boolean
    ' NOTHING TO DO
    
On Error GoTo Load_A_Com_Errors
    Load_A_Com = True
    ' ---------------------------------------------------------------------------
    ' Instantsiate Scripting object
    ' ---------------------------------------------------------------------------
    Set mo_FSO = CreateObject("Scripting.FileSystemObject")
    If mo_FSO Is Nothing Then
      Load_A_Com = False
    End If

    Exit Function

Load_A_Com_Errors:
    Set mo_FSO = Nothing
    Load_A_Com = False
    
End Function

Public Sub Unload_A_Com()
    ' NOTHING TO DO
    Set mo_FSO = Nothing
End Sub

Public Function Add_Trailing_Slash(ByVal strPath As String) As String

' ***************************************************************************
' Routine:       Add_Trailing_Slash
'
' Description:   Add the trailing backslash from the path if it does not exist
'
' Parameters:    strPath - Full path to be queried
'
' Returns:       Reformatted path
' ***************************************************************************

On Error GoTo Add_Trailing_Slash_Errors

' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  strPath = Trim$(strPath)
   
' ---------------------------------------------------------------------------
' Test for trailing backslash
' ---------------------------------------------------------------------------
  If Right$(strPath, 1) = "\" Then
      Add_Trailing_Slash = strPath
  Else
      Add_Trailing_Slash = strPath & "\"
  End If
  Exit Function
Add_Trailing_Slash_Errors:
End Function
Public Function DeleteFile(ByVal strPath As String) As Boolean
' ***************************************************************************
' Routine:       DeleteFile
'
' Description:   Delete nested file.
'
' Syntax:        DeleteFile "C:\Program Files\MyDir\Level 1\Level 2\file.xxx"
'
' Parameters:    strPath = file with full path do be deleted
'
' Returns:       True or False
' ***************************************************************************

  On Error GoTo Delete_File_Errors
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim strTmpPath  As String
  Dim file As Object
  
' ---------------------------------------------------------------------------
' See if anything was passed to this routine
' ---------------------------------------------------------------------------
  If Len(Trim$(strPath)) = 0 Then
      ' even if given path is invalid we return false, but not show MsgBox
      DeleteFile = False
      GoTo normal_exit
  End If
  

' ---------------------------------------------------------------------------
' See if any of the folders have to be created
' ---------------------------------------------------------------------------

  If mo_FSO.FileExists(strPath) Then
    Set file = mo_FSO.GetFile(strPath)
    If Not file Is Nothing Then
      file.Delete
    End If
  End If
    
' ---------------------------------------------------------------------------
' We were successful
' ---------------------------------------------------------------------------
  DeleteFile = True
  
normal_exit:
  On Error GoTo 0    ' nullify this error routine
  Exit Function

' ---------------------------------------------------------------------------
' An error occured creating this path
' ---------------------------------------------------------------------------
Delete_File_Errors:
  MsgBox "Error: " & CStr(Err.Number) & "  " & Err.Description & _
         vbCrLf & vbCrLf & "An error occured while trying to delete " & _
         strTmpPath, vbInformation + vbOKOnly, "Error deleting file"
  
  DeleteFile = False
End Function

Public Function CreateDirStruct(ByVal strPath As String) As Boolean
   
' ***************************************************************************
' Routine:       CreateDirStruct
'
' Description:   Create nested directories.  Must end with a backslash.
'
' Syntax:        CreateDirStruct "C:\Program Files\MyDir\Level 1\Level 2\"
'
' Parameters:    strPath = Folder path to be created if it does not exist
'
' Returns:       True or False
' ***************************************************************************

  On Error GoTo Create_Dir_Struct_Errors
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim intIndex    As Integer
  Dim strTmpPath  As String
  
' ---------------------------------------------------------------------------
' See if anything was passed to this routine
' ---------------------------------------------------------------------------
  If Len(Trim$(strPath)) = 0 Then
      ' if we specify wrong path it is error
      CreateDirStruct = False
      GoTo normal_exit
  End If
'  Call mo_error.local_log("Directory " & strPath & " specified OK.")
'  Call mo_error.db_log("Directory " & strPath & " specified OK.")
  
' ---------------------------------------------------------------------------
' Make sure there is a traling backslash
' ---------------------------------------------------------------------------
  strPath = Add_Trailing_Slash(strPath)
  intIndex = 0

' ---------------------------------------------------------------------------
' See if any of the folders have to be created
' ---------------------------------------------------------------------------
  
  Do
      ' get the next path chunk
      intIndex = InStr(intIndex + 1, strPath, "\")
      
      If intIndex > 0 Then
          strTmpPath = Left$(strPath, intIndex - 1)
      Else
          Exit Do
      End If
      
      ' see if this folder exists
      If Not mo_FSO.FolderExists(strTmpPath) Then
          ' Create this folder.
          ' If there is an error, it will be trapped
          ' below and a msgbox displayed.
          mo_FSO.CreateFolder strTmpPath
        intIndex = 1
      End If
  Loop
  
  If intIndex = 0 Then
  End If

    
' ---------------------------------------------------------------------------
' We were successful
' ---------------------------------------------------------------------------
  CreateDirStruct = True
  
normal_exit:
  On Error GoTo 0    ' nullify this error routine
  Exit Function

' ---------------------------------------------------------------------------
' An error occured creating this path
' ---------------------------------------------------------------------------
Create_Dir_Struct_Errors:
  MsgBox "Error: " & CStr(Err.Number) & "  " & Err.Description & _
         vbCrLf & vbCrLf & "An error occured while trying to create " & _
         strTmpPath, vbInformation + vbOKOnly, "Error creating folder"
  CreateDirStruct = False
End Function
Private Function IsFilePath(ByVal s_path As String) As Boolean
' ***************************************************************************
' Routine:       IsFilePath
'
' Description:   Test if givven path is path to file.
'
' Syntax:        IsFilePath "C:\Program Files\MyDir\Level 1\Level 2\"
'
' Parameters:    s_path = Folder path to be tested if it is a filepath
'
' Returns:       True or False
' ***************************************************************************
On Error GoTo IsFilePath_Err
    Dim l_i As Long
    IsFilePath = False
    For l_i = Len(s_path) To 1 Step -1
        If Mid(s_path, l_i, 1) = "." Then
            IsFilePath = True
            Exit For
        End If
    Next l_i
  Exit Function
IsFilePath_Err:
End Function

Private Function ReadStringArray(ByVal l_fileNumber As Long) As String()
' ***************************************************************************
' Routine:       ReadStringArray
'
' Description:   Read a arrary of strings from opened file. First WORD is
'                number of items in array, each item must be separated with 0 (zero value)
'
' Syntax:        strArr = ReadStringArray ( 1 )
'
' Parameters:    l_fileNumber = Filenumber of file opened For Binary Access Read
'
' Returns:       Array of readed strings
'
' review : 20/Oct/2004 by JN
' ***************************************************************************
On Error GoTo ReadStringArray_Err
    Dim i_size As Integer
    Dim l_i As Long
    Dim s_aux As String
    Dim s_ret() As String
    Dim b_aux As Byte
    
    Get #l_fileNumber, , i_size
    ReDim s_ret(i_size - 1)
    For l_i = 0 To i_size - 1
        s_aux = ""
        Do
            Get #l_fileNumber, , b_aux
            If b_aux <> 0 Then s_aux = s_aux & Chr(b_aux)
        Loop Until Not b_aux <> 0
        s_ret(l_i) = s_aux
    Next l_i
    ReadStringArray = s_ret
    
    Exit Function
ReadStringArray_Err:
End Function

Public Function SaveOle(ByVal s_path As String, ByRef o_ole As ole) As Boolean
'------------------------------------------------------------------
' Name : SaveOle
'
' Purpose : Save data from ole container to disk
'
' Parameters : relative path to applicatoin beeing upgraded, ole component to be saved
'
' Return : True if it was OK otherwise False
'
' review : 20/Oct/2004 by JN
'------------------------------------------------------------------

    SaveOle = False
    
    Dim s_strArr() As String
    Dim s_namesArr() As String
    Dim s_File As String
    Dim l_fileNumber As Long
    Dim l_tmpFileNumber As Long
    Dim l_aux As Long
    Dim b_auxArr() As Byte
    Dim l_i As Long
    Dim s_str As String
    Dim l_step As Integer
    
On Error GoTo SaveOle_Err
    l_tmpFileNumber = 0
    l_fileNumber = 0
    l_step = 0
    
    ' function works correctly only with sources included from file
    If o_ole.SourceDoc = "" Then
        Exit Function
    End If
    
    If IsFilePath(s_path) Then
        s_File = s_path
    Else
        ' test for if given directory exists and create one
        CreateDirStruct (s_path)
        
        If Right(s_path, 1) <> "\" Then
            s_path = s_path & "\"
        End If
        
        If o_ole.SourceDoc = "" Then
            ReDim Preserve s_strArr(1)
            s_strArr(1) = "temp.tmp"    ' default filename
        End If
        ' extract filename from SourceDoc property
        s_strArr = Split(o_ole.SourceDoc, "\")
        s_File = s_path & s_strArr(UBound(s_strArr, 1))
    End If
    
    ' save temporary
    l_fileNumber = FreeFile
    Open temp_file_name For Output Access Write Lock Read Write As #l_fileNumber
'    Call mo_error.local_log(temp_file_name & " opened for write.")
    
    o_ole.SaveToOle1File (l_fileNumber)
    l_step = 1
    
    Close #l_fileNumber
    l_step = 2
    
    ' open temporary file for input
    l_tmpFileNumber = FreeFile
    Open temp_file_name For Binary Access Read Lock Read Write As l_tmpFileNumber
    l_step = 3
'    Call mo_error.local_log(temp_file_name & " opened for read.")
    
    ' open exportfile
    l_fileNumber = FreeFile

    Open s_File For Binary Access Write Lock Read As #l_fileNumber
    l_step = 4
'    Call mo_error.local_log(s_File & " opened for write.")
    
    ' input length of class name
    Get #l_tmpFileNumber, , l_aux
    Get #l_tmpFileNumber, , l_aux
    Get #l_tmpFileNumber, , l_aux
    s_str = String(l_aux, " ")
    Get #l_tmpFileNumber, , s_str

    ' two zero long values
    Get #l_tmpFileNumber, , l_aux
    Get #l_tmpFileNumber, , l_aux
    
    ' length of head + raw data
    Get #l_tmpFileNumber, , l_aux
    
    s_namesArr = ReadStringArray(l_tmpFileNumber)
    
    Get #l_tmpFileNumber, , l_aux
    
    ' length of original file path
    Get #l_tmpFileNumber, , l_aux
    s_str = String(l_aux, " ")
    Get #l_tmpFileNumber, , s_str
    
    ' length of data
    Get #l_tmpFileNumber, , l_aux
    ReDim b_auxArr(l_aux - 1)
    Get #l_tmpFileNumber, , b_auxArr
    Put #l_fileNumber, , b_auxArr

    
' close opened files
    Close #l_fileNumber
    Close #l_tmpFileNumber
    
    DeleteFile (temp_file_name)
    
    SaveOle = True
    
    Exit Function

SaveOle_Err:
    If l_step >= 3 Then Close #l_tmpFileNumber
    If l_step >= 4 Then Close #l_fileNumber


MsgBox ("Error occured while upgrading Application ( file:" & o_ole.SourceDoc & ")")
End Function
