mdlftp.bas

本系统可用于医院和专业体检中心的健康体检管理

Attribute VB_Name = "mdlFTP"
Option Explicit
Public gstrCurrPath As String
Public Const ExeName = "BTTJWLB.exe"    '应用程序名
Public Const DSNINIDir = "Config\DSN\" '数据库INI文件夹
Public Const DSNININame = "UpGrade.INI" '数据库INI文件夹

Public Const TempINIFile = "Temp.INI"       '临时配置文件
'Public Const TempINIFile = "ODBC.INI"       '临时配置文件
Public FTPGET As clsFTP

'**************************************
'未用变量(编译用)
Public Const PasswordDepth = -15
Public Const NoRecord = 3021
Public Const CustomError = 555555
'**************************************

Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_SHOW = 5

'**************************************************************
'☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
'★★★★★★★★★★★★★★            ★★★★★★★★★★★★★★
'★★★★★★★★★★★★★★   主函数   ★★★★★★★★★★★★★★
'★★★★★★★★★★★★★★            ★★★★★★★★★★★★★★
'☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
'**************************************************************
Public Sub Main()
On Error Resume Next
    Dim blnOK As Boolean
    Dim strValue As String
    Dim strUserName As String
    Dim strPassword As String
    Dim strFTPServer As String
    Dim strNewDate As String
    Dim strOldDate As String
    
    Screen.MousePointer = 13 'Arrow and Hourglass
    '设置当前路径
    SetCurrPath
    
    Set FTPGET = New clsFTP
    
    '首先检查是否要升级
    strValue = GetINI(gstrCurrPath & DSNINIFile, "Upgrade", "Upgrade", "?")
    If UCase(strValue) = "NO" Then
        '不需要升级
        GoTo ExitLab
    ElseIf strValue = "?" Then
        '进行升级设置
        GoSub Set_Parameter
    Else
        GoSub Get_Config
    End If
    
    GoTo ExitLab
    
Set_Parameter:
    Screen.MousePointer = 0
    blnOK = frmUpgrade.ShowFtpPara
    Set frmUpgrade = Nothing
    Screen.MousePointer = 13
    
    Return
    
Get_Config:
    '开始检查服务器上的情况
    strUserName = GetINI(gstrCurrPath & DSNINIFile, "Upgrade", "FTPUser", "?")
    strPassword = GetINI(gstrCurrPath & DSNINIFile, "Upgrade", "FTPPassword", "?")
    strFTPServer = GetINI(gstrCurrPath & DSNINIFile, "Upgrade", "FTPServer", "?")
    If strUserName = "?" Then strUserName = ""
    If strPassword = "?" Then
        strPassword = ""
    Else
        strPassword = FTPGET.Decrypt(strPassword)
    End If
    
'    If FTPGET.FTPGET(strFTPServer, strUserName, strPassword, strFTPServer & "\" & DSNINIDir, DSNININame, gstrCurrPath & DSNINIDir, TempINIFile) = False Then
    If FTPGET.FTPGET(strFTPServer, strUserName, strPassword, strFTPServer & "\", DSNININame, gstrCurrPath & DSNINIDir, TempINIFile) = False Then
        If MsgBox("无法从服务器上下载配置文件！要重新设置连接参数吗？", _
                vbExclamation + vbYesNo + vbDefaultButton1, "提示") = vbNo Then
            GoTo ExitLab
        Else
            GoSub Set_Parameter
            If blnOK Then GoSub Get_Config
        End If
    Else
        '检查配置文件中的日期
        strNewDate = GetINI(gstrCurrPath & DSNINIDir & TempINIFile, "Upgrade", "UpgradeDate", "?")
        strOldDate = GetINI(gstrCurrPath & DSNINIFile, "Upgrade", "UpgradeDate", "?")
        
        If strNewDate <> "?" Then '首先检查服务器上是否为空
            If IsDate(strNewDate) Then '其次检查服务器上的是否正确日期
                If Not IsDate(strOldDate) Then '最后检查本地是否日期
                    GoSub Get_Exe
                Else
                    '判断时间先后
                    If CDate(strNewDate) > CDate(strOldDate) Then
                        GoSub Get_Exe
                    End If
                End If
            End If
        End If
    End If
    
    Return
    
Get_Exe:
    blnOK = False
    If MsgBox("检测到服务器上有更新版本的应用程序，如果下载该程序，将花费您几分钟的时间，具体时间视网络传输速度而定。" _
            & vbCrLf & vbCrLf & "如果要下载新程序，请单击“是”，否则请单击“否”。强烈建议您即刻下载该程序。", _
            vbQuestion + vbYesNo + vbDefaultButton1, "提示") = vbYes Then
        If FTPGET.FTPGET(strFTPServer, strUserName, strPassword, strFTPServer, ExeName, gstrCurrPath) = False Then
            MsgBox "无法下载应用程序，请联系管理员！", vbExclamation, "Exe文件下载错误"
        Else
            blnOK = True
            If blnOK Then
                '更新本地时间
                Call WriteINI(gstrCurrPath & DSNINIFile, "Upgrade", "UpgradeDate", strNewDate)
            End If
        End If
    End If
    Return
    
ExitLab:
    Set FTPGET = Nothing
    '删除临时配置文件
    If Dir(gstrCurrPath & DSNINIDir & TempINIFile) <> "" Then
        Kill gstrCurrPath & DSNINIDir & TempINIFile
    End If
    
    '调用主程序
    Call ShellExecute(App.hInstance, "open", gstrCurrPath & ExeName, vbNullString, vbNullString, SW_SHOW)
    Screen.MousePointer = 0
    
    '结束升级程序
    TerminateProcess GetCurrentProcess, 0
End Sub

'设置应用程序的当前路径：含斜杠“\”
Public Sub SetCurrPath()
On Error Resume Next
    If Right(App.Path, 1) <> "\" Then
        gstrCurrPath = App.Path & "\"
    Else
        gstrCurrPath = App.Path
    End If
End Sub

'创建一个标准执行模块，命名modErrorMsg，用于显示出错信息：
Public Sub ErrMsg(Status)
'The Status parameter should be passed as a variant array
'of 3 elements as listed"
' 0-Error Number
' 1-Error Description
' 2-Error Source

    'define local variables
    Dim strErr As String
    
    'Build the error information
    strErr = "Error " & Trim(Str(Status(0))) & " In " & Status(2) & ":" & vbCrLf & Status(1)
    
    'display the error information
'    AddLog Status(0), Status(1), ErrorLog, Status(2)
'    If gblnAuto = False Then
        MsgBox strErr, vbInformation, "提示"
'    Else
'        ShowDialog strErr
'    End If
End Sub

Public Function SetError(ErrNumber As Long, ErrDescription As String, ErrSource As String)
'This function will return a variant array of three elements
'set to the passed parameters
    'Define local ErrorType
    Dim pError(2)
 
    'Assign error
    pError(0) = ErrNumber
    pError(1) = ErrDescription
    pError(2) = ErrSource
   
    'Return the ErrorType
    SetError = pError
End Function