frmbaserepire.frm

金算盘软件代码

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmBaseRepair 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "帐套整理"
   ClientHeight    =   2265
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4800
   HelpContextID   =   20007
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2265
   ScaleWidth      =   4800
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   3504
      Top             =   1440
   End
   Begin ComctlLib.ProgressBar ProgressBar1 
      Align           =   2  'Align Bottom
      Height          =   180
      Left            =   0
      TabIndex        =   3
      Top             =   2085
      Visible         =   0   'False
      Width           =   4800
      _ExtentX        =   8467
      _ExtentY        =   318
      _Version        =   327682
      Appearance      =   1
   End
   Begin VB.CommandButton cmdOK 
      Height          =   350
      Index           =   0
      Left            =   3480
      Style           =   1  'Graphical
      TabIndex        =   1
      Tag             =   "1001"
      Top             =   180
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.CommandButton cmdOK 
      Height          =   350
      Index           =   1
      Left            =   3480
      Style           =   1  'Graphical
      TabIndex        =   0
      Tag             =   "1002"
      Top             =   570
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.Label Label1 
      Caption         =   "                                    帐套整理处理诸如系统掉电等原因引起的数据混乱 ,以及其他数据整理操作． "
      Height          =   1200
      Left            =   336
      TabIndex        =   2
      Top             =   540
      Width           =   2808
   End
End
Attribute VB_Name = "frmBaseRepair"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private mBaseName As String

Public Property Let GBaseName(ByVal strName As String)
    mBaseName = strName
End Property

Private Sub cmdOK_Click(Index As Integer)
    Dim strDBName As String
    Dim strNameTemp As String
    Dim strResult As String
    Dim strTemp As String
    Dim errNo As Long
    If Index = 1 Then
        '取消
        Unload Me
        Exit Sub
    End If
    
    On Error GoTo ErrHandle
    Me.MousePointer = vbHourglass
    ProgressBar1.Visible = True
    ProgressBar1.Value = 5
    'ProgressBar1.Enabled = True
    'Timer1.Enabled = True
    'Debug.Print time
    'Debug.Print Timer1.Interval
    If gclsBase.BaseDB Is Nothing Then
       strDBName = mBaseName
    Else
       strDBName = gclsBase.BaseDB.Name
       gclsBase.BaseDB.Close
    End If
    
    Set gclsBase.BaseDB = Nothing
    strNameTemp = "C:\____.001"
    strResult = Dir(strNameTemp)
    ' 使中间文件不会被使用
    
    ProgressBar1.Value = 10
    Do While strResult <> ""
        strTemp = Right(strNameTemp, 3)
        strNameTemp = Left(strNameTemp, 4)
        strTemp = CInt(strTemp) + 1
        strTemp = Format(strTemp, "000")
        strNameTemp = strNameTemp & "." & strTemp
        strResult = Dir(strNameTemp)
    Loop
    'Debug.Print time
    ProgressBar1.Value = 20
    'DBEngine.RepairDatabase strDBName
    'Debug.Print time
    ProgressBar1.Value = 45
    'DBEngine.CompactDatabase strDBName, strNameTemp, , , ";pwd=" & strBasePassWord
    'Debug.Print time
    ProgressBar1.Value = 75
    Kill strDBName
    ProgressBar1.Value = 80
    'Debug.Print time
    Name strNameTemp As strDBName
    'Unload Me
    If Not gclsBase.OpenDatabase(strDBName, False, False) Then
        frmMain.UpdateStatus
        ProgressBar1.Value = 85
        frmMain.UpdateMenuStatus
    End If
    Me.MousePointer = vbDefault
    ProgressBar1.Value = 100
    ProgressBar1.Visible = False
    MsgBox "整理完成", vbInformation, "帐套整理"
    'Timer1.Enabled = False
    'Debug.Print time
    Unload Me
    Exit Sub
    
ErrHandle:
    errNo = Errors.ErrorsDeal()
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown
        ShowMsg frmMain.hwnd, "程序出现未知错误！", vbOKOnly + vbCritical, Caption
    End Select
    Me.MousePointer = vbDefault
    Unload Me
End Sub



Private Sub CmdOK_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then
  Unload Me
End If

End Sub

Private Sub Form_Activate()
SetHelpID C2lng(Me.HelpContextID)
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then
  Unload Me
End If
End Sub

Private Sub Form_Load()
    On Error GoTo ErrHandle
    Me.HelpContextID = 20007
    Utility.LoadFormResPicture Me
    Exit Sub
    Dim edtErrReturn As ErrDealType
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Sub
Private Sub Form_Paint()
    FrameBox Me.hwnd, 180, 180, 3315, 2000
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim strDBName As String
    
    On Error Resume Next
    Utility.UnLoadFormResPicture Me
    Set frmBaseRepair = Nothing
    
    '帐套被独占打开
    If Not gclsBase.BaseDB Is Nothing Then
        strDBName = gclsBase.BaseDB.Name
        Set grecLog = Nothing
        gclsBase.BaseDB.Close
        Set gclsBase.BaseDB = Nothing
    End If
    If Not gclsBase.OpenDatabase(strDBName, False, False) Then
        frmMain.UpdateStatus
        frmMain.UpdateMenuStatus
    End If
End Sub

Private Sub Timer1_Timer()
    If ProgressBar1.Value = 100 Then ProgressBar1.Value = 0
    ProgressBar1.Value = ProgressBar1.Value + 5
    Debug.Print time
End Sub