VERSION 5.00
Begin VB.Form DSWupd 
   Caption         =   "Samples Installation Program"
   ClientHeight    =   1590
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   14835
   LinkTopic       =   "Form1"
   ScaleHeight     =   1590
   ScaleWidth      =   14835
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmd_quit 
      Caption         =   "Quit"
      Height          =   375
      Left            =   5760
      TabIndex        =   4
      Top             =   840
      Width           =   1575
   End
   Begin VB.CommandButton run_install 
      Caption         =   "Run Install"
      Height          =   375
      Left            =   4080
      TabIndex        =   3
      Top             =   840
      Width           =   1575
   End
   Begin VB.CommandButton cm_close 
      Caption         =   "Close"
      Height          =   375
      Left            =   7560
      TabIndex        =   1
      Top             =   840
      Visible         =   0   'False
      Width           =   1695
   End
   Begin VB.OLE oledsw 
      Class           =   "Package"
      Height          =   765
      Left            =   1860
      OleObjectBlob   =   "dswupd.frx":0000
      SourceDoc       =   "C:\Arm_Apps\DSW\dswmgr.exe"
      TabIndex        =   2
      Top             =   705
      Visible         =   0   'False
      Width           =   1215
   End
   Begin VB.Label lb_Caption 
      Caption         =   "Please ensure Samples Application is not running"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   11.25
         Charset         =   238
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   14895
   End
End
Attribute VB_Name = "DSWupd"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function CreateProcessWithLogon Lib "Advapi32" Alias "CreateProcessWithLogonW" (ByVal lpUsername As Long, ByVal lpDomain As Long, ByVal lpPassword As Long, ByVal dwLogonFlags As Long, ByVal lpApplicationName As Long, ByVal lpCommandLine As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInfo As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long

Private Const LOGON_WITH_PROFILE = &H1&
Private Const LOGON_NETCREDENTIALS_ONLY = &H2&
Private Const CREATE_DEFAULT_ERROR_MODE = &H4000000
Private Const CREATE_NEW_CONSOLE = &H10&
Private Const CREATE_NEW_PROCESS_GROUP = &H200&
Private Const CREATE_SEPARATE_WOW_VDM = &H800&
Private Const CREATE_SUSPENDED = &H4&
Private Const CREATE_UNICODE_ENVIRONMENT = &H400&
Private Const ABOVE_NORMAL_PRIORITY_CLASS = &H8000&
Private Const BELOW_NORMAL_PRIORITY_CLASS = &H4000&
Private Const HIGH_PRIORITY_CLASS = &H80&
Private Const IDLE_PRIORITY_CLASS = &H40&
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const REALTIME_PRIORITY_CLASS = &H100&

Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type
Private Type STARTUPINFO
    cb As Long
    lpReserved As Long
    lpDesktop As Long
    lpTitle As Long
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Byte
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

Const C_CNF_NAME = "Capture.cnf"
Const C_INI_NAME = "capture.ini"
Const DSW_VER = "2.0.0"

' database connection parameters: login:jnagy, passw:jnagy
' input commanline arguments are passed to logs
' 1.parameter ... userName
' 2.parameter ... siteID
' 3.parameter ... cnf file fullpath to write success

Public Enum ProgressOperation
  prgping = 0
  prgConnecting = 1
  prgCredentials = 2
  prgwait = 3
  prguploadtrf = 4
  prgtrfprocess = 5
  prgBackup = 6
  prgserverdefine = 7
  prgnewdataset = 8
  prgcomparedataset = 9
  prgDownload = 10
  prgUpdatingDBF = 11
  prgresult = 12
  prgnewversion = 13
  prgDisconnecting = 14
  prg_update_on_line = 15
  prg_create_dir = 16
End Enum

Dim ms_AppPath As String
Dim mo_FSO As Object


Private Declare Function Connect Lib "ArmLog.dll" ( _
  ByVal lpServer As String, _
  ByVal lpDatabase As String, _
  ByVal lpUser As String, _
  ByVal lpPassword As String, _
  ByVal lpApplication As String _
  ) As Long

Private Declare Function ExecuteSQL Lib "ArmLog.dll" ( _
  ByVal lpServer As String) As Long

Private Declare Function Disconnect Lib "ArmLog.dll" () As Long

Private Declare Function DecompressFile Lib "ArmLog.dll" ( _
  ByVal lpArchiveName As String, ByVal lpDirectory As String) As Long
Dim cpt_er As Integer
Private Sub cm_close_Click()
    Call Unload(Me)
End Sub


Function CreatePath() As Boolean
   Dim FSO As Object
   Dim MainFolder As Object
   
   
   Set FSO = CreateObject("Scripting.FileSystemObject")
   If Not FSO.FolderExists("C:\Arm_Apps") Then
    Set MainFolder = FSO.CreateFolder("C:\Arm_Apps")
   End If
   
   
  If Not FSO.FolderExists("C:\Arm_Apps\APOLLO_DSW") Then
    Set MainFolder = FSO.CreateFolder("C:\Arm_Apps\APOLLO_DSW")
  End If
   
  
   Set MainFolder = Nothing
   Set FSO = Nothing
CreatePath = True
End Function


Function DeleteFile(ByVal f As String) As Boolean
On Error GoTo deletefile_er:
   Dim FSO As Object
   DeleteFile = False
Set FSO = CreateObject("Scripting.FileSystemObject")
   FSO.DeleteFile f, True
   DeleteFile = True
   Set FSO = Nothing
   Exit Function
deletefile_er:
   Set FSO = Nothing
   Select Case Err.Number:
   Case 53:
   Case Else: MsgBox "Process was unable to delete file f"
   End Select
End Function
Public Function GetSysDir() As String
    
    Dim ls_Buff As String, ll_Count As Long
    ls_Buff = Space(256)
    ll_Count = GetSystemDirectory(ls_Buff, 256)
    
    GetSysDir = Left(ls_Buff, ll_Count)

End Function

Public Function GetwindowsDir() As String
    Dim ls_Buff As String, ll_Count As Long
    ls_Buff = Space(256)
    ll_Count = GetWindowsDirectory(ls_Buff, 256)
    GetwindowsDir = Left(ls_Buff, ll_Count)
End Function

Function fileexist(ByVal f As String) As Boolean
On Error GoTo fileexist_er:
fileexist = False
   Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
   If FSO.fileexists(f) Then
   fileexist = True
   End If
   Set FSO = Nothing
   
   Exit Function
fileexist_er:
   Select Case Err.Number:
   Case 53:
   Case Else: MsgBox "Error in searching for Capoff"
   End Select
End Function


Function folderexist(ByVal f As String) As Boolean
On Error GoTo folderexist_er:
folderexist = False
   Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
   If FSO.FolderExists(f) Then
   folderexist = True
   End If
   Set FSO = Nothing
   
   Exit Function
folderexist_er:
   Select Case Err.Number:
   Case 53:
   Case Else: MsgBox "Error in searching for folder " & f
   End Select
End Function
Private Sub cmd_quit_Click()
End
End Sub

Private Sub Form_Load()
DSWupd.Top = 0
DSWupd.Left = 0
DSWupd.Width = 15000
DSWupd.Height = 2000
End Sub

Private Sub run_install_Click()
On Error GoTo getOff
Dim nb_wait As Integer
Dim lcount As Long

'Dim ls_winpath As String
'Dim ls_syspath As String

'ls_winpath = GetwindowsDir
'ls_syspath = GetSysDir


Screen.MousePointer = vbHourglass
Dim res As Long
Dim capdir As String

Set mo_FSO = CreateObject("Scripting.FileSystemObject")

Call CreatePath

If Not folderexist("C:\Arm_Apps\APOLLO_DSW") Then
  MsgBox "Folder C:\Arm_Apps\APOLLO_DSW where application should be upgraded does not exist"
End If

If Not IsNewerVersion("C:\Arm_Apps\APOLLO_DSW\dswmgr.exe", DSW_VER) Then
  MsgBox "Samples Program version (" & GetFileVersion("C:\Arm_Apps\APOLLO_DSW\dswmgr.exe") & ") is greater than or equal to " & DSW_VER & " This upgrade is not necessary"
  End
End If


run_install.Visible = False
cmd_quit.Visible = False
lb_Caption = "Installation In Progress"
DoEvents
cpt_er = 0
nb_wait = 0
   
If GetProcesses("dswmgr.exe") Then
MsgBox "SAMPLES APPLICATION MUST BE CLOSED BEFORE RUNNING THE UPGRADE. THIS PROGRAM HAS DETECTED THAT THE APPLICATION IS STILL RUNNING. PLEASE CLOSE AND RETRY"
     End
End If
    
    If Not OLEExport.Load_A_Com() Then
    MsgBox "problem to initialize OLE Class"
     GoTo getOff
    End If
    
  
DeleteFile ("C:\Arm_Apps\APOLLO_DSW\dswmgr.exe")


lb_Caption = "Installation In Progress, Extracting new version from package"
DoEvents
If Not SaveOle("C:\Arm_Apps\APOLLO_DSW\dswmgr.exe", oledsw) Then
    MsgBox "problem to install the new version"
        GoTo getOff
    End If
  
        OLEExport.Unload_A_Com

lb_Caption.Visible = True

lb_Caption = "Installation completed with success. Program is now version " & GetFileVersion("C:\Arm_Apps\APOLLO_DSW\dswmgr.exe")
DoEvents
cm_close.Visible = True
Screen.MousePointer = 0
Set mo_FSO = Nothing
Exit Sub
  
getOff:
Screen.MousePointer = 0
Select Case Err.Number
Case 70:
' if directory is open in filemanager, delete failed but windows will normally automatically close afterwards and then retry should work
If nb_wait < 3 Then
nb_wait = nb_wait + 1
Sleep (5000)
Resume
Else
MsgBox "An error occured during the install process." & Err.Description
OLEExport.Unload_A_Com
End If
Case Else
MsgBox "An error occured during the install process." & Err.Description
OLEExport.Unload_A_Com
End Select
Set mo_FSO = Nothing
End Sub

Private Function IsNewerVersion(ByVal ls_filePath As String, ByVal ls_newVersion As String, Optional ByVal lb_logVersion As Boolean = True) As Boolean
' return true if ls_newVersion is newer than ls_filePath or ls_filePath file not exists
On Error GoTo error_exit
Dim ls_fileVer As String
Dim lb_ret As Boolean

    lb_ret = True
    If mo_FSO.fileexists(ls_filePath) Then
        ls_fileVer = GetFileVersion(ls_filePath)
        If CompareFileVersion(ls_fileVer, ls_newVersion) <= 0 Then lb_ret = False
    End If
    
    IsNewerVersion = lb_ret
Exit Function
error_exit:
    IsNewerVersion = False
End Function

Private Function GetFileVersion(ByVal as_FilePath As String) As String

    Dim ls_FileVersion As String
    ls_FileVersion = ""
    
    On Error GoTo onError
    ls_FileVersion = mo_FSO.GetFileVersion(as_FilePath)
onError:
    GetFileVersion = ls_FileVersion
End Function

Private Function CompareFileVersion(ByVal as_V1 As String, ByVal as_V2 As String) As Integer
    
        Dim li_Result
        li_Result = 0
        
        On Error GoTo onError
        
        Dim la_V1 As Variant, la_V2 As Variant, li_Index As Integer, li_Count As Integer
        Dim li_V1 As Integer, li_V2 As Integer
        la_V1 = Split(as_V1, ".")
        la_V2 = Split(as_V2, ".")
        
        li_V1 = UBound(la_V1)
        li_V2 = UBound(la_V2)
        
        li_Count = IIf(li_V1 >= li_V2, li_V1, li_V2)
        For li_Index = 0 To li_Count
            If li_Index > li_V1 Then
                li_Result = 1
                Exit For
            End If
            If li_Index > li_V2 Then
                li_Result = -1
                Exit For
            End If
            
            If CInt(la_V1(li_Index)) > CInt(la_V2(li_Index)) Then
                li_Result = -1
                Exit For
            End If
            If CInt(la_V1(li_Index)) < CInt(la_V2(li_Index)) Then
                li_Result = 1
                Exit For
            End If
        Next
        
        CompareFileVersion = li_Result
        Exit Function
onError:
        Call MsgBox("Error in CompareFileVersion")
    
End Function



