frmsystemdatabaseback.frm

企业ERP系统 采用VB+SQL2000实现。 有客户合约

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmSystemDatabaseBackUp 
   Caption         =   "数据备份/恢復"
   ClientHeight    =   2085
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   3510
   LinkTopic       =   "Form1"
   ScaleHeight     =   2085
   ScaleWidth      =   3510
   StartUpPosition =   3  'Windows Default
   Begin MSWinsockLib.Winsock wskListen 
      Left            =   1560
      Top             =   360
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin MSWinsockLib.Winsock wskServer 
      Left            =   540
      Top             =   240
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin MSComctlLib.StatusBar StatusBar1 
      Align           =   2  'Align Bottom
      Height          =   255
      Left            =   0
      TabIndex        =   0
      Top             =   1830
      Width           =   3510
      _ExtentX        =   6191
      _ExtentY        =   450
      Style           =   1
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
      EndProperty
   End
End
Attribute VB_Name = "frmSystemDatabaseBackUp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim serverIp() As String
Dim SrcPath As String
Dim dstpath As String
Dim IsReceived As Boolean
Private Sub SendFile()
    Dim BufFile As String
    Dim LnFile As Long
    Dim nLoop As Long
    Dim nRemain As Long
    Dim Cn As Long
    
    On Error GoTo GLocal:
    LnFile = FileLen(App.Path & "\DatabaseBack\UniLeaderDatabase" & Right(Year(Now), 2) & IIf(Len(Month(Now) < 2), "0" & Month(Now), Month(Now)) & Day(Now))
    If LnFile > 8192 Then
        nLoop = Fix(LnFile / 8192)
        
        nRemain = LnFile Mod 8192
    Else
        nLoop = 0
        nRemain = LnFile
    End If
    
    If LnFile = 0 Then
        MsgBox "錯誤的數據備份", vbCritical, "提示"
        Exit Sub
    End If
    SrcPath = App.Path & "\DatabaseBack\UniLeaderDatabase" & Right(Year(Now), 2) & IIf(Len(Month(Now) < 2), "0" & Month(Now), Month(Now)) & Day(Now)
    Open SrcPath For Binary As #1
    If nLoop > 0 Then
        For Cn = 1 To nLoop
            BufFile = String(8192, " ")
            Get #1, , BufFile
            wskServer.SendData BufFile
            IsReceived = False
            While IsReceived = False
                DoEvents
            Wend
        Next
        If nRemain > 0 Then
            BufFile = String(nRemain, " ")
            Get #1, , BufFile
            wskServer.SendData BufFile
            IsReceived = False
            While IsReceived = False
                DoEvents
            Wend
        End If
    Else
        BufFile = String(nRemain, " ")
        Get #1, , BufFile
        wskServer.SendData BufFile
        IsReceived = False
        While IsReceived = False
            DoEvents
        Wend
    End If
    wskServer.SendData "Msg_Eof_"
    Close #1
    Exit Sub
GLocal:
    MsgBox Err.Description
    
End Sub
Public Function File_Exists(sFileName As String) As Boolean
If sFileName <> "" Then File_Exists = (Dir(sFileName, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbArchive) <> "")
End Function
Private Sub wskListen_Connect()
StatusBar1.SimpleText = "狀態：已聯接"
End Sub
Private Sub Form_Load()
    wskListen.Protocol = sckTCPProtocol
    wskListen.LocalPort = 1001
    wskListen.Listen
    Me.Hide
End Sub
Private Sub wskListen_Close()
     wskListen.Close
     wskListen.Listen
End Sub
Private Sub wskListen_ConnectionRequest(ByVal requestID As Long)
      If wskListen.State <> sckClosed Then wskListen.Close
      wskListen.Accept requestID
      If wskServer.State <> sckClosed Then wskServer.Close
      wskServer.Connect wskListen.RemoteHostIP, 1002
End Sub

Private Sub wskListen_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
wskListen.Close
End Sub
Private Sub wskServer_Connect()
StatusBar1.SimpleText = "狀態：已聯接"
End Sub
Private Sub WskServer_DataArrival(ByVal bytesTotal As Long)
    Dim RecBuffer As String
    On Error GoTo GLocal
    wskServer.GetData RecBuffer
    Select Case Left(RecBuffer, 7)
        Case "Msg_Pas"
             If Right(RecBuffer, Len(RecBuffer) - 7) <> "admin" Then
                 wskServer.SendData "Msg_Ero_"
             Else
                 wskServer.SendData "Msg_Cok_" & "d:\UniLeaderDatabase" & Right(Year(Now), 2) & IIf(Len(Month(Now) < 2), "0" & Month(Now), Month(Now)) & Day(Now)
             End If
        Case "Msg_OkS"
            StatusBar1.SimpleText = "發送數據"
                If File_Exists(App.Path & "\DatabaseBack\UniLeaderDatabase" & Right(Year(Now), 2) & IIf(Len(Month(Now) < 2), "0" & Month(Now), Month(Now)) & Day(Now)) = False Then
                    objDatabase.ExecCmd "BACKUP DATABASE UniLeaderDatabase TO DISK ='" & App.Path & "\DatabaseBack\UniLeaderDatabase" & Right(Year(Now), 2) & IIf(Len(Month(Now) < 2), "0" & Month(Now), Month(Now)) & Day(Now) & "'"
                    SendFile
                Else
                    wskServer.SendData ("Msg_Ebk_")
                End If
        Case "Msg_Con"
                StatusBar1.SimpleText = "請求連接"
                wskServer.SendData ("Msg_Cok_")
        Case "Msg_Rec"  'Block Received
            StatusBar1.SimpleText = "發送完成"
            IsReceived = True
        Case "Msg_Cls"
            wskServer.Close
    End Select
    
    Exit Sub
GLocal:
    MsgBox Err.Description
    Unload Me
End Sub