update.frm

一、 设计构想： 为减轻财政局非税收入管理处票据准购薄管理工作量

VERSION 5.00
Begin VB.Form update 
   BackColor       =   &H00FFFFFF&
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "博易升级器"
   ClientHeight    =   1365
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   2145
   Icon            =   "update.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1365
   ScaleWidth      =   2145
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   5000
      Left            =   1560
      Top             =   840
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "→ 升级完毕"
      Height          =   255
      Index           =   2
      Left            =   120
      TabIndex        =   2
      Top             =   960
      Visible         =   0   'False
      Width           =   4455
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "→ 正在升级系统"
      Height          =   255
      Index           =   1
      Left            =   120
      TabIndex        =   1
      Top             =   600
      Visible         =   0   'False
      Width           =   4455
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "→ 正在校验文件完整性"
      Height          =   255
      Index           =   0
      Left            =   120
      TabIndex        =   0
      Top             =   240
      Visible         =   0   'False
      Width           =   4455
   End
End
Attribute VB_Name = "update"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function GetPrivateProfileString Lib "Kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, lpKeyName As String, ByVal lpDefault As String, ByVal lpRetunedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function SaveINI Lib "Kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lplFileName As String) As Long
Public filename As String
Private Sub Form_Load()
Timer1.Enabled = True
End Sub

Function formnum(va)
If IsNumeric(va) Then
formnum = CCur(va)
Else
formnum = 0
End If
End Function

Public Function GetINI(Appname As String, KeyName As String, filename As String) As String
On Error Resume Next
   Dim RetStr As String
   RetStr = String(10000, Chr(0))
   GetINI = Left(RetStr, GetPrivateProfileString(ByVal Appname, ByVal KeyName, "", RetStr, Len(RetStr), filename))
End Function

Private Sub Timer1_Timer()
On Error Resume Next
Dim filesize As Long
updates = True
filename = App.Path & "\system.ini"
Version = CSng(formnum(Trim(CStr(GetINI("main", "version", filename)))))
Open App.Path & "\update.up" For Input As #1
Line Input #1, updatever
upver = CSng(formnum(updatever))
    If upver > Version Then
        Do While Not EOF(1)
        Line Input #1, updatever
        If updatever = "" Then Exit Do
        upinfos = Split(updatever, "|")
        Open App.Path & "\" & upinfos(0) & ".up" For Binary Access Write As #2
        filesize = LOF(2)
        Close #2
            If filesize <> CLng(formnum(upinfos(1))) Then
            MsgBox upinfos(0) & "文件校验失败..."
            updates = False
            End If
        Loop
    Else
    MsgBox "无需升级"
    updates = False
    End If
Close #1

If updates Then
Set fso = CreateObject("Scripting.FileSystemObject")
Open App.Path & "\update.up" For Input As #1
Line Input #1, updatever
        Do While Not EOF(1)
        Line Input #1, updatever
        If updatever = "" Then Exit Do
        upinfos = Split(updatever, "|")
        Set ff = fso.GetFile(App.Path & "\" & upinfos(0) & ".up")
        ff.Copy (App.Path & "\" & upinfos(0))
        Set ff = Nothing
            Select Case UBound(upinfos)
            Case 2
                If (LCase(Right(upinfos(0), 3)) = "dll" Or LCase(Right(upinfos(0), 3)) = "ocx") And upinfos(2) = "reg" Then
                Shell "regsvr32 " & upinfos(0), 0
                End If
            End Select
        Loop
Close #1
Set fso = Nothing
End If
If Err.Number = 0 Then
SaveINI "main", "version", upver, filename
Shell App.Path & "\fanrun.exe"
End
Else
MsgBox "升级时出现错误，请做好备份工作，以防数据丢失！[" & Err.Description & "]"
End
End If
End Sub