frmindata.frm

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

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form FrmInData 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "数据库转换"
   ClientHeight    =   1380
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6150
   Icon            =   "FrmInData.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1380
   ScaleWidth      =   6150
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton ExitCmd 
      Caption         =   "退出"
      Height          =   345
      Left            =   3300
      TabIndex        =   2
      Top             =   840
      Width           =   1305
   End
   Begin VB.CommandButton BeginCmd 
      Caption         =   "开始"
      Height          =   345
      Left            =   1470
      TabIndex        =   1
      Top             =   840
      Width           =   1305
   End
   Begin MSComctlLib.ProgressBar ProgressBar1 
      Height          =   255
      Left            =   180
      TabIndex        =   0
      Top             =   480
      Width           =   5715
      _ExtentX        =   10081
      _ExtentY        =   450
      _Version        =   393216
      BorderStyle     =   1
      Appearance      =   1
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "数据转换"
      BeginProperty Font 
         Name            =   "幼圆"
         Size            =   14.25
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FF0000&
      Height          =   285
      Left            =   2370
      TabIndex        =   3
      Top             =   60
      Width           =   1275
   End
End
Attribute VB_Name = "FrmInData"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim EventDes As String
Dim EventType As String
Dim EventColor As String

Dim GlobalConI As ADODB.Connection
Dim GlobalConR As ADODB.Connection
Dim GlobalConC As ADODB.Connection
Dim GlobalConW As ADODB.Connection

Dim AllowShowKkl As Boolean
Sub RepairDb()
On Error GoTo RepairDbErr
    
GlobalCon.Close
Set GlobalCon = Nothing
    
'整理数据库
If Dir(App.Path & "\mdb\temp.mdb") <> "" Then
   Kill App.Path & "\mdb\temp.mdb"
End If
DBEngine.CompactDatabase App.Path & "\mdb\maindata.mdb", App.Path & "\mdb\temp.mdb"
Kill App.Path & "\mdb\maindata.mdb"
Name App.Path & "\mdb\temp.mdb" As App.Path & "\mdb\maindata.mdb"

'重新打开数据库
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


Exit Sub
RepairDbErr:
    MsgBox "数据库整理时发生错误！请按说明书进行解决！", vbExclamation
    
End Sub



Sub AddNewRec()
Dim StrSql As String
On Error GoTo AddNewRecErr
'增加一条记录到新数据库
StrSql = "insert into sourcedata(strdata1,strdata2,strdate,companyid,companyname,eventtype,eventdes,color,Weather"
StrSql = StrSql & ") values("

With NowSelectRec
    StrSql = StrSql & "'" & .StrData1 & "','" & .StrData2 & "', '" & Format$(.StrDate, "yyyy-mm-dd hh:mm") & "',"
    StrSql = StrSql & "'" & .CompanyId & "', '" & .CompanyName & "',"
    StrSql = StrSql & "'" & .EventType & "', '" & .EventDes & "',"
    StrSql = StrSql & "'" & .Color & "','" & .Weather & "') "
    GlobalCon.Execute StrSql
End With

'晴空下一条记录
With NowSelectRec
    .Color = ""
    .CompanyId = ""
    .CompanyName = ""
    .EventDes = ""
    .EventType = ""
    .StrData1 = ""
    .StrData2 = ""
    .StrDate = ""
    .Weather = ""
End With

Exit Sub
AddNewRecErr:
    MsgBox Err.Description, vbExclamation

End Sub


Sub ChangeData()
Dim StrSql As String, TempRec As New ADODB.Recordset, TempInfoRec As New ADODB.Recordset
On Error GoTo ChangeErr

'清空原有的所有数据
StrSql = "delete from sourcedata "
GlobalCon.Execute StrSql

'选择所有的记录，同时开始一条一条转换并且保存
StrSql = "select * from sourcedata "
TempRec.Open StrSql, GlobalConR, adOpenDynamic, adLockReadOnly
TempRec.MoveLast
TempRec.MoveFirst
ProgressBar1.Max = TempRec.RecordCount + 10

ProgressBar1.Visible = True

Do Until TempRec.EOF
    With NowSelectRec
         AllowShowKkl = True
         If Not IsNull(TempRec!strdata) Then
            .StrData1 = TranslateString(Trim$(TempRec!strdata))
         End If
         AllowShowKkl = False
         If Not IsNull(TempRec!strdata) Then
            .StrData2 = TranslateString(Trim$(TempRec!strdata))
         End If
                     
         If Not IsNull(TempRec!CompanyId) Then
            .CompanyId = Trim$(TempRec!CompanyId)
            StrSql = "select CompanyName from mycompany where CompanyId='" & Trim$(TempRec!CompanyId) & "' "
            TempInfoRec.Open StrSql, GlobalConI, adOpenDynamic, adLockReadOnly
            If Not TempInfoRec.EOF Then
                If Not IsNull(TempInfoRec!CompanyName) Then
                   .CompanyName = Trim$(TempInfoRec!CompanyName)
                End If
            End If
            TempInfoRec.Close
         End If
                                 
         '查询天气
         If Not IsNull(TempRec!StrDate) Then
            .StrDate = Trim$(TempRec!StrDate)
            StrSql = "select Weather from weather where  mid(Date,1,10)='" & Mid(Trim$(TempRec!StrDate), 1, 10) & "' "
            TempInfoRec.Open StrSql, GlobalConW, adOpenDynamic, adLockReadOnly
            If Not TempInfoRec.EOF Then
                If Not IsNull(TempInfoRec!Weather) Then
                   .Weather = Trim$(TempInfoRec!Weather)
                End If
            End If
            TempInfoRec.Close
         End If
                                
         '事件代码
        .EventDes = EventDes
        .EventType = EventType
        .Color = EventColor
        
        
    End With
    ProgressBar1.Value = ProgressBar1.Value + 1
    AddNewRec
    TempRec.MoveNext
Loop
TempRec.Close


RepairDb  '呀书数据库

ProgressBar1.Value = ProgressBar1.Max

Exit Sub
ChangeErr:
    MsgBox Err.Description, vbExclamation
    Resume Next
    
End Sub

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

Set GlobalConR = New ADODB.Connection

With GlobalConR
    .CommandTimeout = 15
    .CursorLocation = adUseClient
    
    .Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & App.Path & "\mdb\r.b;Mode=Read|Write;Jet OLEDB:Database Password="     '使用角色的帐户登录
End With

Set GlobalConC = New ADODB.Connection

With GlobalConC
    .CommandTimeout = 15
    .CursorLocation = adUseClient
    
    .Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & App.Path & "\mdb\system12.mdb.;Mode=Read|Write;Jet OLEDB:Database Password="     '使用角色的帐户登录
End With

Set GlobalConW = New ADODB.Connection

With GlobalConW
    .CommandTimeout = 15
    .CursorLocation = adUseClient
    
    .Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & App.Path & "\mdb\weather.mdb.;Mode=Read|Write;Jet OLEDB:Database Password="     '使用角色的帐户登录
End With

With NowSelectRec
    .Color = ""
    .CompanyId = ""
    .CompanyName = ""
    .EventDes = ""
    .EventType = ""
    .StrData1 = ""
    .StrData2 = ""
    .StrDate = ""
    .Weather = ""
End With


End Sub


Function TranslateString(TransStr As String) As String
Dim StrSql As String, TempLineRec As New ADODB.Recordset, TempDes As String, TempStr As String
Dim i As Integer, j As Integer, RowI As Integer, k As Integer
Dim TempNewStr As String
On Error GoTo TransErr

TranslateString = TransStr
EventDes = ""
EventType = ""
EventColor = ""

'第一步：分解？？之前的数据,同时翻译：之前的数据

TempDes = ""

'取6、7两位，并分解
If AllowShowKkl = True Then
   TempStr = Mid(Trim$(TransStr), 6, 1)
   i = Asc(TempStr)
   i = i - 48
   TempNewStr = ""
   Do Until i = 0
      TempNewStr = TempNewStr & (i Mod 2)
      i = i \ 2
   Loop
   
   TempStr = Mid(Trim$(TransStr), 7, 1)
   i = Asc(TempStr)
   i = i - 48
   TempNewStr = TempNewStr & " "
   Do Until i = 0
      TempNewStr = TempNewStr & (i Mod 2)
      i = i \ 2
   Loop
   
   TempDes = TempDes & "  " & Chr(523) & TempNewStr
Else
   TempDes = TempDes & "  " & Chr(523) & Mid(Trim$(TransStr), 6, 2)
End If
       

'首先判断是否有:

i = InStr(8, Trim$(TransStr), ":")  '如果没有：则退出
If i > 0 Then
    TempNewStr = Mid(Trim$(TransStr), 8, i - 7)
    EventType = Mid(Trim$(TransStr), 8, i - 8)
    
    StrSql = "select s_chinese,event_color  from eventkind where event_key='" & TempNewStr & "' "
    TempLineRec.Open StrSql, GlobalConC, adOpenDynamic, adLockReadOnly
    If Not TempLineRec.EOF Then
       If Not IsNull(TempLineRec!s_chinese) Then
          TempNewStr = Trim$(TempLineRec!s_chinese)
       End If
       If Not IsNull(TempLineRec!event_color) Then
          EventColor = Trim$(TempLineRec!event_color)
       End If
    End If
    TempLineRec.Close
    EventDes = TempNewStr
Else
    TempDes = TempDes & "  " & Chr(523) & Mid(Trim$(TransStr), 8, Len(Trim$(TransStr)) - 7)
    TranslateString = TempDes
    Exit Function
End If

j = InStr(i, Trim$(TransStr), "ALU")  '如果没有ALU则直接翻译

If j > 0 Then
      '翻译ALU字段与：之间的内容
      TempStr = Trim$(Mid(Trim$(TransStr), i + 1, j - i - 1))
      If TempStr <> "" Then
            StrSql = "select s_chinese  from objectkind where object_key='" & UCase(TempStr) & "' "
            TempLineRec.Open StrSql, GlobalConC, adOpenDynamic, adLockReadOnly
            If Not TempLineRec.EOF Then
               If Not IsNull(TempLineRec!s_chinese) Then
                  TempStr = Trim$(TempLineRec!s_chinese)
               End If
            End If
            TempLineRec.Close
      End If
      TempDes = TempDes & "  " & Chr(523) & TempStr
        
      '翻译ALU字段
      k = InStr(j, Trim$(TransStr), "   ")
      TempStr = Trim$(Mid(Trim$(TransStr), j, k - j))
      
      StrSql = "select comment from MyPoint where addr='" & Trim$(TempStr) & "'  "
      StrSql = StrSql & " And  CompanyId='" & Mid(Trim$(TransStr), 1, 5) & "' "
      
      TempLineRec.Open StrSql, GlobalConI, adOpenDynamic, adLockReadOnly
      If Not TempLineRec.EOF Then
         If Not IsNull(TempLineRec!comment) Then
            TempStr = Trim$(TempLineRec!comment)
         Else
            TempStr = ""
         End If
      Else
         TempStr = ""
      End If
      TempLineRec.Close
      TempDes = TempDes & "  " & Chr(523) & TempStr

      '增加后面的所有内容
      TempDes = TempDes & "  " & Chr(523) & TempStr & Mid(Trim$(TransStr), k + 1, Len(Trim$(TransStr)) - k)
      
      TranslateString = TempDes
Else
      TempStr = Trim$(Mid(Trim$(TransStr), i + 1, Len(Trim$(TransStr)) - i))
      k = InStr(1, Trim$(TempStr), "  ")
      If k > 0 Then
            TempStr = Mid(TempStr, 1, k - 1)
            TempNewStr = TempStr
            '翻译中间的内容
            StrSql = "select s_chinese  from objectkind where object_key='" & UCase(TempStr) & "' "
            TempLineRec.Open StrSql, GlobalConC, adOpenDynamic, adLockReadOnly
            If Not TempLineRec.EOF Then
               If Not IsNull(TempLineRec!s_chinese) Then
                  TempStr = Trim$(TempLineRec!s_chinese)
               Else
                  TempStr = ""
               End If
            Else
               TempStr = ""
            End If
            TempLineRec.Close
            If TempDes = "" Then
                TempDes = TempDes & "  " & Chr(523) & Mid(Trim$(TransStr), i + 1, Len(Trim$(TransStr)) - i)
            Else
                TempDes = TempDes & "  " & Chr(523) & TempStr
                j = InStr(1, Trim$(TransStr), TempNewStr)
                If j > 0 Then
                    TempDes = TempDes & " " & Chr(523) & Mid(Trim$(TransStr), j + Len(TempNewStr) + 1, Len(Trim$(TransStr)) - j - Len(TempNewStr))
                End If
            End If
            TranslateString = TempDes
            
      Else
            TempDes = TempDes & "   " & Chr(523) & Mid(Trim$(TransStr), i + 1, Len(Trim$(TransStr)) - i)
            TranslateString = TempDes
            Exit Function
      End If
  
End If

i = InStr(1, TranslateString, "   ")
Do Until i = 0
   TranslateString = Mid(TranslateString, 1, i - 1) + Mid(TranslateString, i + 3, Len(TranslateString) - i - 2)
   i = InStr(1, TranslateString, "   ")
Loop

Exit Function
TransErr:
    MsgBox Err.Description, vbExclamation

End Function


Private Sub BeginCmd_Click()

Screen.MousePointer = 11

ExitCmd.Enabled = False
ChangeData
ExitCmd.Enabled = True
MsgBox "编译完毕！", vbExclamation

Screen.MousePointer = 0
Unload Me

End Sub

Private Sub ExitCmd_Click()
Unload Me
End Sub


Private Sub Form_Load()
Init
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

GlobalConI.Close
GlobalConR.Close
GlobalConC.Close

End Sub