frmztbackup.frm

一个用VB写的财务软件源码

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Begin VB.Form frmZTBackup 
   Caption         =   "账套备份"
   ClientHeight    =   4890
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6465
   Icon            =   "frmZTBackup.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   4890
   ScaleWidth      =   6465
   StartUpPosition =   2  '屏幕中心
   Begin RichTextLib.RichTextBox RTBfile 
      Height          =   3030
      Left            =   45
      TabIndex        =   12
      Top             =   1395
      Width           =   6375
      _ExtentX        =   11245
      _ExtentY        =   5345
      _Version        =   393217
      ScrollBars      =   3
      TextRTF         =   $"frmZTBackup.frx":0442
   End
   Begin VB.CommandButton cmdSet 
      Caption         =   "设置(&S)"
      Height          =   345
      Left            =   2640
      TabIndex        =   11
      Top             =   4500
      Width           =   1065
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "退出(&Q)"
      Height          =   345
      Left            =   4005
      TabIndex        =   10
      Top             =   4500
      Width           =   1065
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定(&O)"
      Height          =   345
      Left            =   1245
      TabIndex        =   9
      Top             =   4500
      Width           =   1065
   End
   Begin VB.CommandButton cmdCZ 
      Caption         =   "重置"
      Height          =   300
      Left            =   4860
      TabIndex        =   8
      Top             =   585
      Width           =   735
   End
   Begin VB.CommandButton CmdExeBrowse 
      Caption         =   "浏览"
      Height          =   300
      Left            =   4095
      TabIndex        =   7
      Top             =   585
      Width           =   735
   End
   Begin VB.TextBox txtExePath 
      Height          =   270
      Left            =   1440
      TabIndex        =   6
      Top             =   585
      Width           =   2655
   End
   Begin VB.CommandButton CmdBrowse 
      Caption         =   "浏览"
      Height          =   300
      Left            =   4095
      TabIndex        =   5
      Top             =   1035
      Width           =   735
   End
   Begin VB.TextBox TxtFileName 
      Height          =   285
      Left            =   1440
      TabIndex        =   4
      Top             =   1035
      Width           =   2670
   End
   Begin VB.ComboBox cboZTSelect 
      Height          =   300
      Left            =   1440
      TabIndex        =   1
      Text            =   "cboZTSelect"
      Top             =   135
      Width           =   2175
   End
   Begin MSComDlg.CommonDialog CommonOpen 
      Left            =   4500
      Top             =   135
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      DialogTitle     =   "打开"
      Filter          =   "*.dmp"
      InitDir         =   "c:\"
   End
   Begin VB.Label Label3 
      AutoSize        =   -1  'True
      Caption         =   "默认备份目录："
      Height          =   180
      Left            =   135
      TabIndex        =   3
      Top             =   1125
      Width           =   1260
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "执行程序："
      Height          =   180
      Left            =   225
      TabIndex        =   2
      Top             =   630
      Width           =   900
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "账套选择："
      Height          =   180
      Left            =   225
      TabIndex        =   0
      Top             =   225
      Width           =   900
   End
End
Attribute VB_Name = "frmZTBackup"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" _
    (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, _
    lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, _
    lpTotalNumberOfClusters As Long) As Long
    
Dim WithEvents oLaunch As RedirectLib.Application
Attribute oLaunch.VB_VarHelpID = -1

Private Sub CmdBrowse_Click()
    Dim i As Integer
    CommonOpen.FileName = "c:\expdat" & Format(Date, "yyyymmdd") & ".dmp"
    CommonOpen.Filter = ".dmp"
    CommonOpen.InitDir = "c:\"
    CommonOpen.ShowOpen
    If Trim(CommonOpen.FileName) = "" Then
    Else
    i = InStr(1, CommonOpen.FileName, ".", vbTextCompare)
        If g_FLAT = "ORACLE" Then
            If Mid(CommonOpen.FileName, i + 1, 3) <> "dmp" And Mid(CommonOpen.FileName, i + 1, 3) <> "DMP" Then
               TxtFileName = Mid(CommonOpen.FileName, 1, i) & "dmp"
            Else
               TxtFileName = CommonOpen.FileName
            End If
        End If
    End If

End Sub

Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdCZ_Click()
Dim sCommandName As String
Dim reg As New CRegistry
If g_FLAT = "ORACLE" Then
    sCommandName = "exp80.exe"
    reg.OpenKey localmachine, "software/oracle", True
    txtExePath.text = reg.ReadValue("oracle_home") & "\bin\EXP80.EXE"
End If

End Sub

Private Sub CmdExeBrowse_Click()
    Dim i As Integer
    CommonOpen.FileName = txtExePath
    CommonOpen.Filter = ".exe"
    CommonOpen.InitDir = "c:\"
    CommonOpen.ShowOpen
    If Trim(CommonOpen.FileName) = "" Then
    Else
    i = InStr(1, CommonOpen.FileName, ".", vbTextCompare)
        If g_FLAT = "ORACLE" Then
            If Mid(CommonOpen.FileName, i + 1, 3) <> "exe" And Mid(CommonOpen.FileName, i + 1, 3) <> "exe" Then
               txtExePath = Mid(CommonOpen.FileName, 1, i) & "exe"
            Else
               txtExePath = CommonOpen.FileName
            End If

        End If
    End If

End Sub
Public Sub cmdOK_Click()
  Dim pidNotepad As Long
  Dim f As New FileSystemObject

'合法性检查
    If cboZTSelect.text = "" Then
       MsgBox "账套名不能为空!", vbOKOnly, "提示"
       cboZTSelect.SetFocus
       Exit Sub
    End If
    
    If txtExePath = "" Then
       MsgBox "执行程序名不能为空!", vbOKOnly, "提示"
       txtExePath.SetFocus
       Exit Sub
    End If
    
    If TxtFileName = "" Then
       MsgBox "备份文件名不能为空!", vbOKOnly, "提示"
       TxtServerName.SetFocus
       Exit Sub
    End If
    
'磁盘空间检查
''    '磁盘信息
''     Dim lSectorsPerCluster As Long
''     Dim lBytesPerSector As Long
''     Dim lNumberOfFreeClusters As Long
''     Dim lTotalNumberOfClusters As Long
''     Dim lFreeBytes As Long
''     t = Trim(TxtFileName.text)
''     '当前磁盘还有多少剩余空间
''     GetDiskFreeSpace Left(t, 2), lSectorsPerCluster, lBytesPerSector, _
''         lNumberOfFreeClusters, lTotalNumberOfClusters
''
''     '如果剩余空间约300M左右，则提示
''     If lNumberOfFreeClusters <= 75000 Then
''             MsgBox "磁盘空间不足，请删除不需要的备份文件！", vbInformation
''             Exit Sub
''
''     End If
'保存设置
    Dim sAccountID As String
    If g_FLAT = "ORACLE" Then
      If Trim(cboZTSelect.text) = "财务系统表" Then
        sAccountID = "ykcwsysdb"
      Else
        sAccountID = "CWDB" & Mid(Trim(cboZTSelect.text), 1, InStr(1, Trim(cboZTSelect.text), "=") - 1)
      End If
        SaveSetting App.Title, "Backup", "OracleUserId", Trim(cboZTSelect.text)
        SaveSetting App.Title, "Backup", "OracleExeFilePath", Trim(txtExePath.text)
        SaveSetting App.Title, "Backup", "OracleBackupPath", Trim$(Left(TxtFileName.text, InStrRev(TxtFileName.text, "\")))
    End If
'执行备份
     Dim s As String
     Dim m_bFlag As Boolean
     Dim sLog As String
     '生成执行命令字串
On Error GoTo ErrMessageSec

     cmdOK.Enabled = False     '按钮禁用
     cmdSet.Enabled = False
     cmdCancel.Enabled = False
     
     
     sLog = Replace(TxtFileName.text, ".dmp", ".txt")
     If Trim(cboZTSelect.text) = "财务系统表" Then
        s = Trim(txtExePath.text) + " " + "ykcwsysdb/horse" & "@" & gloSys.sServer & " file=" & Trim(TxtFileName.text)
     Else
        s = Trim(txtExePath.text) + " " + Trim(sAccountID) & "/YK" & Trim(sAccountID) & "@" & gloSys.sServer & " file=" & Trim(TxtFileName.text)
     End If
'     s = s + " log=" + sLog

     t = Trim(TxtFileName.text)
     If Dir(t) <> "" Then
        If MsgBox("备份文件" & Trim(TxtFileName.text) & "已存在，要覆盖吗？", vbOKCancel, "提示") = vbOK Then
           m_bFlag = True
           f.DeleteFile (sLog)
        Else
           TxtFileName.SetFocus
           Exit Sub
        End If
    End If
    Dim cmd As ADODB.Command
    Dim val As Double
    Dim times As Integer
    Set cmd = New ADODB.Command
    cmd.ActiveConnection = gloSys.cnnSys
    cmd.CommandType = adCmdText
    If m_bFlag Then
       f.DeleteFile (t)
    End If
    
    oLaunch.Name = s
    Select Case oLaunch.Start
    Case laAlreadyRunning
    Case laWindowsError
        oLaunch.Stop
        MsgBox "Windows error: " & CStr(oLaunch.LastErrorNumber) & "!"
    Case laOk
    End Select
    RTBfile.SaveFile sLog
    Exit Sub
ErrMessageSec:
        cmdOK.Enabled = True    '按钮启用
        cmdSet.Enabled = True
        cmdCancel.Enabled = True
        MsgBox "在备份过程中,应用程序运行出错！", vbInformation, "提示"
End Sub

Public Function LoadFileToRtf(ByVal sLog As String) As Boolean
On Error GoTo Err:
    RTBfile.LoadFile sLog
    RTBfile.Refresh
    RTBfile.SelStart = Len(RTBfile.text)
    LoadFileToRtf = True
    Exit Function
Err:
    LoadFileToRtf = False
End Function

Private Sub cmdSet_Click()
frmAutoBackup.Show 1, Me
End Sub

Private Sub Form_Load()
Dim rSt As New ADODB.Recordset
cboZTSelect.Clear
cboZTSelect.AddItem "财务系统表"
cboZTSelect.Refresh
With rSt
  .CursorLocation = adUseClient
  .Open "SELECT * FROM tSYS_Account A,tSYS_Trade B " & _
                "WHERE A.TradeID=B.ID ORDER BY A.AccountID", _
            gloSys.cnnSys, adOpenStatic, adLockReadOnly
   
    If .RecordCount <> 0 Then
        Do Until .EOF
            cboZTSelect.AddItem .Fields("AccountID").Value & "=" & _
                 .Fields("AccountName").Value
            .MoveNext
        Loop
    End If
   .Close
End With
cboZTSelect.Refresh

Dim i As Integer
If g_FLAT = "ORACLE" Then
    If GetSetting(App.Title, "Backup", "OracleUserId", "") = "ykcwsysdb" Then
       cboZTSelect.text = "财务系统表"
    Else
       cboZTSelect.text = GetSetting(App.Title, "Backup", "OracleUserId", "")
    End If
    txtExePath.text = GetSetting(App.Title, "Backup", "OracleExefilepath", "")
    TxtFileName.text = GetSetting(App.Title, "Backup", "OracleBackupPath", "") & "expdat" & Format(Date, "yyyymmdd") & ".dmp"
End If

Set oLaunch = New RedirectLib.Application
oLaunch.BufferSize = 8192
oLaunch.Wait = 500
End Sub

Private Sub oLaunch_DataReceived(ByVal sData As String)
    RTBfile.text = RTBfile.text + sData
    RTBfile.SelStart = Len(RTBfile.text)
End Sub

Private Sub oLaunch_ProcessEnded()
MsgBox "账套备份完成！", vbInformation, "提示"
cmdOK.Enabled = True    '按钮启用
cmdSet.Enabled = True
cmdCancel.Enabled = True
End Sub

Private Sub RTBfile_Change()
DoEvents
RTBfile.Refresh
End Sub