frmbackup.frm

报警信息查询系统VB+ACESS 根据某啤酒厂出现故障不同（如系统错误、负亟接地、操作错误等）计算机系统进行报警

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form FrmBackup 
   Caption         =   "数据备分"
   ClientHeight    =   4620
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7365
   Icon            =   "FrmBackup.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   ScaleHeight     =   4620
   ScaleWidth      =   7365
   StartUpPosition =   1  '所有者中心
   Begin VB.CommandButton ExitCmd 
      Caption         =   "退出"
      Height          =   345
      Left            =   5460
      TabIndex        =   7
      Top             =   4080
      Width           =   1095
   End
   Begin VB.CommandButton BeginCmd 
      Caption         =   "开始"
      Height          =   345
      Left            =   5460
      TabIndex        =   6
      Top             =   3720
      Width           =   1095
   End
   Begin VB.Frame Frame1 
      Caption         =   "选择起始与截止日期"
      Height          =   2895
      Left            =   5220
      TabIndex        =   1
      Top             =   660
      Width           =   2025
      Begin MSComCtl2.DTPicker BeginDate 
         Height          =   315
         Left            =   330
         TabIndex        =   2
         Top             =   870
         Width           =   1665
         _ExtentX        =   2937
         _ExtentY        =   556
         _Version        =   393216
         CalendarBackColor=   16777215
         Format          =   24510464
         CurrentDate     =   37155
      End
      Begin MSComCtl2.DTPicker EndDate 
         Height          =   315
         Left            =   330
         TabIndex        =   3
         Top             =   1500
         Width           =   1665
         _ExtentX        =   2937
         _ExtentY        =   556
         _Version        =   393216
         Format          =   24510464
         CurrentDate     =   37155
      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         BackColor       =   &H80000009&
         BorderStyle     =   1  'Fixed Single
         Caption         =   "从"
         Height          =   240
         Left            =   30
         TabIndex        =   5
         Top             =   870
         Width           =   240
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         BackColor       =   &H80000009&
         BorderStyle     =   1  'Fixed Single
         Caption         =   "到"
         Height          =   240
         Left            =   30
         TabIndex        =   4
         Top             =   1530
         Width           =   240
      End
   End
   Begin MSComctlLib.ListView lvwDB 
      Height          =   4275
      Left            =   30
      TabIndex        =   0
      Top             =   90
      Width           =   5145
      _ExtentX        =   9075
      _ExtentY        =   7541
      View            =   3
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      Checkboxes      =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
End
Attribute VB_Name = "FrmBackup"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Sub GetTitles()
Dim TempSql As String, TempRec As New ADODB.Recordset
Dim TempItem As ListItem
On Error GoTo GetErr

Set TempRec = New ADODB.Recordset

TempSql = "select distinct CompanyId,CompanyName from sourcedata  "
TempRec.Open TempSql, GlobalCon, adOpenDynamic, adLockReadOnly

If TempRec.EOF Then
  lvwDB.ListItems.Clear
  TempRec.Close
  Set TempRec = Nothing
  Exit Sub
End If

lvwDB.ListItems.Clear

Do Until TempRec.EOF
    '添加 ListItem。
    Set TempItem = lvwDB.ListItems.Add()  '添加
    
    If Not IsNull(TempRec!CompanyName) Then '判断是否为空
      TempItem.Text = TempRec!CompanyName
    Else
      TempItem.Text = ""
    End If
    
    TempItem.Key = "KEY" & Trim$(TempRec!CompanyId)
    'TempItem.SubItems(1) = Trim$(TempRec!CompanyName)
    
                 
    TempRec.MoveNext
Loop

TempRec.Close
Set TempRec = Nothing

Exit Sub

GetErr:
 MsgBox Err.Description, vbExclamation
 Resume Next
 
End Sub








    


Private Sub MakeColumns()
Dim i As Integer
        
i = CInt(lvwDB.Width / 5) - 15
lvwDB.ColumnHeaders.Clear
'lvwDB.ColumnHeaders.Add , , "代码", i * 1, lvwColumnLeft
lvwDB.ColumnHeaders.Add , , "名称", i * 4, lvwColumnLeft

End Sub





Private Sub BeginCmd_Click()
Dim TempCon As New ADODB.Connection
Dim TempSql As String, i As Integer
On Error GoTo ClickErr

If lvwDB.ListItems.Count < 1 Then
    MsgBox "没有选择企业！", vbExclamation
    Exit Sub
End If

Screen.MousePointer = 11

If Dir(App.Path & "\BackDb\maindata.mdb") <> "" Then
   Kill App.Path & "\BackDb\maindata.mdb"
End If

GlobalCon.Close

FileCopy App.Path & "\mdb\maindata.mdb", App.Path & "\BackDb\maindata.mdb"

'打开数据库，删除不需要的数据
Set TempCon = New ADODB.Connection
With TempCon
    .CommandTimeout = 15
    .CursorLocation = adUseClient
    
    .Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & App.Path & "\BackDb\maindata.mdb;Mode=Read|Write;Jet OLEDB:Database Password="     '使用角色的帐户登录
End With

For i = 1 To lvwDB.ListItems.Count
   If lvwDB.ListItems(i).Selected = True Then
      TempSql = "delete from  sourcedata where "
      TempSql = TempSql & " companyid<>'" & Mid(lvwDB.ListItems(i).Key, 4, Len(lvwDB.ListItems(i).Key) - 3) & "' "
      TempSql = TempSql & " or ( companyid='" & Mid(lvwDB.ListItems(i).Key, 4, Len(lvwDB.ListItems(i).Key) - 3) & "'   "
      TempSql = TempSql & " and ( strdate<# " & Format$(BeginDate, "yyyy-mm-dd 00:01") & " # "
      TempSql = TempSql & " or strdate># " & Format$(EndDate, "yyyy-mm-dd 23:59") & " # ))"
        
      TempCon.Execute TempSql
      
   End If
Next

TempCon.Close
Set TempCon = Nothing

'重新打开数据库
Set GlobalCon = New ADODB.Connection
With GlobalCon
    .CommandTimeout = 15
    .CursorLocation = adUseClient
    
    .Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & App.Path & "\mdb\maindata.mdb;Mode=Read|Write;Jet OLEDB:Database Password="     '使用角色的帐户登录
End With


MsgBox "备份完毕！", vbInformation

Screen.MousePointer = 0

Exit Sub
ClickErr:
    Screen.MousePointer = 0
    MsgBox Err.Description, vbExclamation

End Sub


Private Sub ExitCmd_Click()
Unload Me
End Sub

Private Sub Form_Load()
MakeColumns
GetTitles

End Sub