Subversion Repositories Aluchemie.datataker

VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.Form DataTakerInfo 
   Caption         =   "DataTaker communicatie"
   ClientHeight    =   5580
   ClientLeft      =   60
   ClientTop       =   195
   ClientWidth     =   10950
   ControlBox      =   0   'False
   Icon            =   "Data_Comm.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   5580
   ScaleWidth      =   10950
   StartUpPosition =   1  'CenterOwner
   Begin VB.CheckBox CheckCont 
      Caption         =   "cont"
      Height          =   255
      Left            =   6000
      TabIndex        =   76
      Top             =   5280
      Visible         =   0   'False
      Width           =   735
   End
   Begin VB.CommandButton Details 
      Caption         =   "Details"
      Height          =   375
      Left            =   9600
      TabIndex        =   74
      Top             =   5160
      Width           =   1215
   End
   Begin VB.CommandButton DataBase 
      Caption         =   "Database"
      Enabled         =   0   'False
      Height          =   375
      Left            =   6840
      TabIndex        =   72
      Top             =   5160
      Visible         =   0   'False
      Width           =   1095
   End
   Begin VB.Timer Timer1 
      Interval        =   1300
      Left            =   3240
      Top             =   4200
   End
   Begin VB.CommandButton Blok 
      Caption         =   "Blok"
      Height          =   375
      Left            =   4800
      TabIndex        =   69
      Top             =   5160
      Width           =   1095
   End
   Begin VB.TextBox PauzeText 
      Alignment       =   2  'Center
      Height          =   285
      Left            =   7440
      TabIndex        =   68
      Text            =   "Loopt"
      Top             =   1320
      Width           =   975
   End
   Begin VB.CommandButton Pauze 
      Caption         =   "Pauze "
      Height          =   375
      Left            =   7440
      TabIndex        =   67
      Top             =   1800
      Width           =   975
   End
   Begin VB.TextBox HistorieAantal 
      Height          =   285
      Left            =   6840
      TabIndex        =   66
      Top             =   4800
      Width           =   1095
   End
   Begin VB.PictureBox Picture1 
      BorderStyle     =   0  'None
      Height          =   1335
      Left            =   8880
      Picture         =   "Data_Comm.frx":0442
      ScaleHeight     =   1335
      ScaleWidth      =   1815
      TabIndex        =   64
      Top             =   360
      Width           =   1815
   End
   Begin VB.TextBox Outputbox 
      BeginProperty Font 
         Name            =   "Terminal"
         Size            =   6
         Charset         =   255
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   855
      Left            =   1200
      MultiLine       =   -1  'True
      TabIndex        =   60
      Top             =   1320
      Width           =   6015
   End
   Begin VB.TextBox IniString 
      Height          =   285
      Left            =   1200
      TabIndex        =   58
      Text            =   "R1-E"
      Top             =   4800
      Width           =   1095
   End
   Begin VB.TextBox ErrorText 
      Height          =   285
      Left            =   7680
      TabIndex        =   57
      Top             =   4320
      Width           =   3255
   End
   Begin VB.TextBox FaseText 
      Alignment       =   2  'Center
      Appearance      =   0  'Flat
      Height          =   285
      Index           =   1
      Left            =   9240
      TabIndex        =   56
      Text            =   "0"
      Top             =   1800
      Width           =   255
   End
   Begin VB.Timer Seconde 
      Interval        =   1000
      Left            =   2760
      Top             =   4200
   End
   Begin VB.TextBox Hoogte 
      Height          =   285
      Left            =   1200
      TabIndex        =   52
      Top             =   4200
      Width           =   1095
   End
   Begin VB.TextBox Temp 
      Height          =   285
      Left            =   1200
      TabIndex        =   51
      Top             =   3840
      Width           =   1095
   End
   Begin VB.TextBox Gewicht 
      Height          =   285
      Left            =   1200
      TabIndex        =   50
      Top             =   3480
      Width           =   1095
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   17
      Left            =   9360
      TabIndex        =   49
      Top             =   2400
      Width           =   735
   End
   Begin VB.TextBox Tslave 
      Height          =   285
      Left            =   1200
      TabIndex        =   48
      Top             =   2400
      Width           =   1095
   End
   Begin VB.TextBox Ttijd 
      Height          =   285
      Left            =   1200
      TabIndex        =   47
      Top             =   3120
      Width           =   1095
   End
   Begin VB.TextBox Tdatum 
      Height          =   285
      Left            =   1200
      TabIndex        =   46
      Top             =   2760
      Width           =   1095
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   35
      Left            =   5640
      TabIndex        =   42
      Top             =   4320
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   34
      Left            =   4800
      TabIndex        =   41
      Top             =   4320
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   33
      Left            =   3960
      TabIndex        =   40
      Top             =   4320
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   32
      Left            =   6480
      TabIndex        =   39
      Top             =   3960
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   31
      Left            =   5640
      TabIndex        =   38
      Top             =   3960
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   30
      Left            =   4800
      TabIndex        =   37
      Top             =   3960
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   29
      Left            =   3960
      TabIndex        =   36
      Top             =   3960
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   28
      Left            =   6480
      TabIndex        =   35
      Top             =   3600
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   27
      Left            =   5640
      TabIndex        =   34
      Top             =   3600
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   26
      Left            =   4800
      TabIndex        =   33
      Top             =   3600
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   25
      Left            =   3960
      TabIndex        =   32
      Top             =   3600
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   24
      Left            =   8520
      TabIndex        =   31
      Top             =   3120
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   23
      Left            =   7680
      TabIndex        =   30
      Top             =   3120
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   22
      Left            =   10200
      TabIndex        =   29
      Top             =   2760
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   21
      Left            =   9360
      TabIndex        =   28
      Top             =   2760
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   20
      Left            =   8520
      TabIndex        =   27
      Top             =   2760
      Width           =   735
   End
   Begin VB.TextBox FaseText 
      Alignment       =   2  'Center
      Appearance      =   0  'Flat
      Height          =   285
      Index           =   0
      Left            =   8880
      TabIndex        =   26
      Text            =   "0"
      Top             =   1800
      Width           =   255
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   19
      Left            =   7680
      TabIndex        =   25
      Top             =   2760
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   18
      Left            =   10200
      TabIndex        =   24
      Top             =   2400
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   16
      Left            =   8520
      TabIndex        =   23
      Top             =   2400
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   15
      Left            =   7680
      TabIndex        =   22
      Top             =   2400
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   14
      Left            =   6480
      TabIndex        =   21
      Top             =   3120
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   13
      Left            =   5640
      TabIndex        =   20
      Top             =   3120
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   12
      Left            =   4800
      TabIndex        =   19
      Top             =   3120
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   11
      Left            =   3960
      TabIndex        =   18
      Top             =   3120
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   10
      Left            =   6480
      TabIndex        =   17
      Top             =   2760
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   9
      Left            =   5640
      TabIndex        =   16
      Top             =   2760
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   8
      Left            =   4800
      TabIndex        =   15
      Top             =   2760
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   7
      Left            =   3960
      TabIndex        =   14
      Top             =   2760
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   6
      Left            =   6480
      TabIndex        =   13
      Top             =   2400
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   5
      Left            =   5640
      TabIndex        =   12
      Top             =   2400
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   4
      Left            =   4800
      TabIndex        =   11
      Top             =   2400
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   3
      Left            =   3960
      TabIndex        =   10
      Top             =   2400
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   2
      Left            =   2760
      TabIndex        =   9
      Top             =   3120
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   1
      Left            =   2760
      TabIndex        =   8
      Top             =   2760
      Width           =   735
   End
   Begin VB.TextBox DataText 
      Height          =   285
      Index           =   0
      Left            =   2760
      TabIndex        =   7
      Top             =   2400
      Width           =   735
   End
   Begin VB.TextBox CommandoText 
      Height          =   285
      Left            =   3480
      TabIndex        =   6
      Text            =   "RESET"
      Top             =   4800
      Width           =   1095
   End
   Begin VB.CommandButton Commando 
      Caption         =   "Commando"
      Height          =   375
      Left            =   3480
      TabIndex        =   5
      Top             =   5160
      Width           =   1095
   End
   Begin VB.CommandButton Init 
      Caption         =   "Init"
      Height          =   375
      Left            =   1200
      TabIndex        =   4
      Top             =   5160
      Width           =   1095
   End
   Begin VB.CommandButton StopPres 
      Caption         =   "     Stop presentatie"
      Height          =   615
      Left            =   120
      TabIndex        =   3
      Top             =   1440
      Width           =   975
   End
   Begin VB.CommandButton StartPres 
      Caption         =   "     Start Presentatie"
      Height          =   615
      Left            =   120
      TabIndex        =   2
      Top             =   360
      Width           =   975
   End
   Begin VB.CommandButton CommandSluit 
      Caption         =   "     Stop programma"
      Height          =   615
      Left            =   7440
      TabIndex        =   1
      Top             =   360
      Width           =   975
   End
   Begin VB.TextBox DisplayBox 
      BeginProperty Font 
         Name            =   "Terminal"
         Size            =   6
         Charset         =   255
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   855
      Left            =   1200
      MultiLine       =   -1  'True
      TabIndex        =   0
      Top             =   240
      Width           =   6015
   End
   Begin MSCommLib.MSComm MSComm 
      Left            =   2880
      Top             =   3600
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      DTREnable       =   -1  'True
      InBufferSize    =   8000
      InputLen        =   1
      RThreshold      =   1
      RTSEnable       =   -1  'True
      BaudRate        =   1200
   End
   Begin VB.Label Label15 
      Caption         =   "versie 4.0"
      Height          =   255
      Left            =   9120
      TabIndex        =   75
      Top             =   0
      Width           =   1095
   End
   Begin VB.Label Label14 
      Caption         =   "Fase"
      Height          =   255
      Left            =   9600
      TabIndex        =   73
      Top             =   1800
      Width           =   375
   End
   Begin VB.Label Label13 
      Caption         =   "Temp"
      Height          =   255
      Left            =   9480
      TabIndex        =   61
      Top             =   3120
      Width           =   735
   End
   Begin VB.Label Label12 
      Caption         =   "Hoogte"
      Height          =   255
      Left            =   6600
      TabIndex        =   71
      Top             =   4320
      Width           =   855
   End
   Begin VB.Label Label11 
      Caption         =   "Gewicht"
      Height          =   255
      Left            =   5280
      TabIndex        =   70
      Top             =   2160
      Width           =   735
   End
   Begin VB.Label Label10 
      Caption         =   "Aantal records in historie-------"
      Height          =   255
      Left            =   4920
      TabIndex        =   65
      Top             =   4800
      Width           =   2055
   End
   Begin VB.Label Label9 
      Caption         =   "Error"
      Height          =   255
      Left            =   9240
      TabIndex        =   63
      Top             =   4080
      Width           =   495
   End
   Begin VB.Label Label8 
      Caption         =   "Commando---------------------"
      Height          =   255
      Left            =   2400
      TabIndex        =   62
      Top             =   4800
      Width           =   1215
   End
   Begin VB.Label Label7 
      Caption         =   "Initstring---------------------"
      Height          =   255
      Left            =   120
      TabIndex        =   59
      Top             =   4800
      Width           =   1215
   End
   Begin VB.Label Label6 
      Caption         =   "Hoogte---------------------"
      Height          =   255
      Left            =   120
      TabIndex        =   55
      Top             =   4200
      Width           =   1215
   End
   Begin VB.Label Label5 
      Caption         =   "Temperatuur--------------------"
      Height          =   255
      Left            =   120
      TabIndex        =   54
      Top             =   3840
      Width           =   1215
   End
   Begin VB.Label Label4 
      Caption         =   "Gewicht-----------------"
      Height          =   255
      Left            =   120
      TabIndex        =   53
      Top             =   3480
      Width           =   1215
   End
   Begin VB.Label Label3 
      Caption         =   "Dag----------------------"
      Height          =   255
      Left            =   120
      TabIndex        =   45
      Top             =   2760
      Width           =   1215
   End
   Begin VB.Label Label2 
      Caption         =   "Tijd-------------------------"
      Height          =   255
      Left            =   120
      TabIndex        =   44
      Top             =   3120
      Width           =   1215
   End
   Begin VB.Label Label1 
      Caption         =   "Pers--------------------"
      Height          =   255
      Left            =   120
      TabIndex        =   43
      Top             =   2400
      Width           =   1215
   End
   Begin VB.Shape Errorlamp 
      BackStyle       =   1  'Opaque
      FillColor       =   &H00E0E0E0&
      FillStyle       =   0  'Solid
      Height          =   135
      Left            =   7800
      Shape           =   3  'Circle
      Top             =   1080
      Width           =   255
   End
End
Attribute VB_Name = "DataTakerInfo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const BLACK = &H0&
Const RED = &HFF&
Const GREEN = &HFF00&
Const YELLOW = &HFFFF&
Const BLUE = &HFF0000
Const MAGENTA = &HFF00FF
Const CYAN = &HFFFF00
Const WHITE = &HFFFFFF
Const LIGHTGRAY = &HC0C0C0
Const DARKGRAY = &H808080
Private g(12)
Private Restart, Presentatie, Reading, PrgPauze As Boolean
Private Lengte, Index As Integer
Private InitString, ReadString, DtString, ClearString As String
Private AbortString, ScanString As String
Private RData(100) As Integer
Private RDataString As String
Private Buffer As String
Private AktSlave As Integer
Private Fase(1) As Integer
Private Tijd(1) As Integer
Private Slave(1) As String
Private Pers(1) As String
Private VorigGewicht(2) As Integer
Private AnodeNr(2) As Long
Private dbsNew As Database
Private tdfNew As TableDef
Private gw, hg, tm As Integer
Private CompactError As Integer
Private ShowDetails As Boolean
Private ErrorOpenDB As Integer
Private ErrorOpenRec As Integer
Private ErrorUpdateRec As Integer
Private ErrorUpdateCrit As Integer
Private ErrorCloseRec As Integer
Private ErrorCloseDB As Integer
Private BlokContinu As Boolean
Private Const MAX_PATH = 260

Public SQLconnectionstring As String
'Public DataTakerString As String

Public Event CommunicatieErr(ErrorNr As Variant)
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'compact is not used for SQL server
Private Sub CompactJetDatabase(Location As String)

On Error GoTo CompactErr
    
Dim strBackupFile As String
Dim strTempFile As String

'Check the database exists
If Len(Dir(Location)) Then

    ' Create temporary filename
    strTempFile = GetTemporaryPath & "temp.mdb"
    If Len(Dir(strTempFile)) Then Kill strTempFile

    ' Do the compacting via DBEngine
    DBEngine.CompactDatabase Location, strTempFile

    ' Remove the original database file
    Kill Location

    ' Copy the temporary now-compressed
    ' database file back to the original
    ' location
    FileCopy strTempFile, Location

    ' Delete the temporary file
    Kill strTempFile

Else

End If
Exit Sub
CompactErr:
    
    ErrorText.Text = "Compact database mislukt; Aantal = " + Str(CompactError)
    CompactError = CompactError + 1
    Exit Sub

End Sub

Public Function GetTemporaryPath()

Dim strFolder As String
Dim lngResult As Long

strFolder = String(MAX_PATH, 0)
lngResult = GetTempPath(MAX_PATH, strFolder)

If lngResult <> 0 Then
  GetTemporaryPath = Left(strFolder, InStr(strFolder, _
    Chr(0)) - 1)
Else
  GetTemporaryPath = ""
End If

End Function

Private Sub PrintText(st)
Dim l As Integer
Const lbuf = 280
If Presentatie Then
      DisplayBox.Text = DisplayBox.Text + st
      l = Len(DisplayBox.Text)
      If l > lbuf Then
         DisplayBox.Text = Mid$(DisplayBox.Text, l - lbuf + 1, lbuf)
      End If
      DisplayBox.SelStart = Len(DisplayBox.Text) - 1
      DisplayBox.SelLength = 1
      End If
End Sub


Private Sub Blok_Click()
Dim anr As Long

  If CheckCont.Value Then
    BlokContinu = True
  End If
  
  'bepaal anode nummer voor simulatie
  anr = BepaalAnodeNr(0)
  Call VoegRecordToe("135", Str(Date), Str(Time), tm, gw, hg, anr)
  tm = tm + 1
  gw = gw + 1
  hg = hg + 1
    
  anr = BepaalAnodeNr(1)
  Call VoegRecordToe("335", Str(Date), Str(Time), tm, gw, hg, anr)
  tm = tm + 1
  gw = gw + 1
  hg = hg + 1
End Sub

Private Sub CheckCont_Click()

  If Not CheckCont.Value Then
    BlokContinu = False
  End If
End Sub

Private Sub Database_Click()
Load HDatabase
HDatabase.Show
End Sub

Private Sub Commando_Click()
MSComm.Output = Slave(0) + CommandoText.Text + Chr(13) + Chr(10)
MSComm.Output = Slave(1) + CommandoText.Text + Chr(13) + Chr(10)
End Sub
Private Sub CommandSluit_Click()
End
End Sub
Private Sub HideSymbols(Flag As Boolean)
Dim I As Integer
   Blok.Visible = Flag
   CheckCont.Visible = Flag
   Commando.Visible = Flag
   CommandoText.Visible = Flag
   For I = 0 To 35
   DataText(I).Visible = Flag
   Next I
'  DisplayBox.Visible = flag
'  Errorlamp.Visible = flag
'  ErrorText.Visible = flag
'  FaseText(0).Visible = flag
'  FaseText(1).Visible = flag
   Gewicht.Visible = Flag
'  HistorieAantal.Visible = flag
   Hoogte.Visible = Flag
   IniString.Visible = Flag
   Init.Visible = Flag
   Label1.Visible = Flag
   Label2.Visible = Flag
   Label3.Visible = Flag
   Label4.Visible = Flag
   Label5.Visible = Flag
   Label6.Visible = Flag
   Label7.Visible = Flag
   Label8.Visible = Flag
'  Label9.Visible = flag
'  Label10.Visible = flag
   Label11.Visible = Flag
   Label12.Visible = Flag
   Label13.Visible = Flag
'  Label14.Visible = flag
'  Outputbox.Visible = flag
   Pauze.Visible = Flag
   PauzeText.Visible = Flag
   Tdatum.Visible = Flag
   Temp.Visible = Flag
   Tslave.Visible = Flag
   Ttijd.Visible = Flag
End Sub

Private Sub Details_Click()

If ShowDetails = False Then
   ShowDetails = True
   Else
   ShowDetails = False
End If
Call HideSymbols(ShowDetails)
End Sub

Private Sub Form_Load()
'Dim ConnString As String
Dim DBS As New ADODB.Connection
Dim RST As New ADODB.Recordset
'Dim DBS As DataBase
'Dim RST As Recordset
Dim idxBlok As Index

'DataTakerString = "3,21,08:11:28, 7.368, 1022.0, 1030.4, 1026.8, 1027.2, 9.896, 10.112, 1031.6, 1028.8, 10.136, 10.532, 1032.4, 318.0, 14.252, 14.344, 14.196, 14.412, 317.2, 14.660, 14.584, 319.6,-50.64, 322.4, 17.712, 16.316, 326.4, 17.136, 14.196, 13.968, 13.208, 17.252, 331.2, 322.8" + Chr(4)

MSComm.PortOpen = True
InitString = "/c/e/k/L/m/n/O/r/t/u P22=44 P24=4 P39=0 "
ReadString = " D T 1+..17+V" + Chr(13) + Chr(10)
ClearString = "CLAST" + Chr(13) + Chr(10)
AbortString = "/Q" + Chr(13) + Chr(10)
ScanString = "U" + Chr(13) + Chr(10)
ShowDetails = False
Call HideSymbols(False)
Presentatie = False
Lengte = 0
Index = 0
gw = 0
hg = 0
tm = 0
g(0) = 1
g(1) = 2
g(2) = 4
g(3) = 8
g(4) = 10
g(5) = 20
g(6) = 40
g(7) = 80
g(8) = 100
g(9) = 200
g(10) = 400
g(11) = 800
Reading = False
PrgPauze = False
Index = 0
Fase(0) = 0
Fase(1) = 0
AktSlave = 0
Restart = False
Slave(0) = "#2"
Slave(1) = "#3"
Pers(0) = "135"
Pers(1) = "335"
VorigGewicht(0) = 0
VorigGewicht(1) = 0

'==================================================================================
'Connection string for SQL server is tied to ODBC refernece, server is defined there
'==================================================================================
SQLconnectionstring = "ODBC;DATABASE=datataker;DSN=datataker;UID=dt2005;PWD="

'==================================================================================
' SQL database will not be created in case it does not exist.
'==================================================================================
'If Dir("Historie.mdb") = "" Then
'   Set dbsNew = CreateDatabase("Historie", dbLangGeneral, dbVersion30)
'   Set tdfNew = dbsNew.CreateTableDef("BlokInfo")
'   With tdfNew
'   ' Create fields and append them to the new TableDef
'   ' object. This must be done before appending the
'   ' TableDef object to the TableDefs collection of the
'   ' database.
'
'   .Fields.Append .CreateField("PERS", dbText)
'   .Fields.Append .CreateField("DATUM_TIJD", dbDate)
'   .Fields.Append .CreateField("HOOGTE", dbInteger)
'   .Fields.Append .CreateField("GEWICHT", dbInteger)
'   .Fields.Append .CreateField("TEMP", dbInteger)
'   .Fields.Append .CreateField("ANODETELLER", dbLong)
'
'   ' Append the new TableDef object to the database.
'   dbsNew.TableDefs.Append tdfNew'
'
'   Set idxBlok = .CreateIndex("BlokInfoIndex")
'   idxBlok.Unique = False 'True
'
'   With idxBlok
'     .Fields.Append .CreateField("DATUM_TIJD")
'     .Fields.Append .CreateField("PERS")
'   End With
'
'
'   .Indexes.Append idxBlok
'   .Indexes.Refresh
'   End With
'
'   Set tdfNew = dbsNew.CreateTableDef("Tellerstand")
'   With tdfNew
'   ' Create fields and append them to the new TableDef
'   ' object. This must be done before appending the
'   ' TableDef object to the TableDefs collection of the
'   ' database.
'
'   .Fields.Append .CreateField("135", dbLong)
'   .Fields.Append .CreateField("335", dbLong)
'
'   ' Append the new TableDef object to the database.
'   dbsNew.TableDefs.Append tdfNew
'   End With
'   dbsNew.Close
'End If

'Set DBS = OpenDatabase("Historie.mdb")
'==================================================================================
'Switch from DAO to ADO, otherwise inserts and edits will always fail!
'Connection string from DAO is used for ADO!!!!
'==================================================================================
'ConnString = "driver={SQL Server};server=localhost;database=datataker;uid=datataker;pwd=datataker"
DBS.CursorLocation = adUseServer
DBS.ConnectionString = SQLconnectionstring
DBS.Mode = adModeShareExclusive
DBS.Open

'Set RST = DBS.OpenRecordset("Blokinfo", dbOpenDynaset, dbSeeChanges, dbPessimistic)
Set RST.ActiveConnection = DBS
RST.Open "select * from Blokinfo", DBS, adOpenKeyset, adLockPessimistic, adCmdText

HistorieAantal.Text = RST.RecordCount
RST.Close
Set RST = Nothing
DBS.Close
Set DBS = Nothing

CompactError = 1
End Sub
Private Sub Form_Unload(Cancel As Integer)
MSComm.PortOpen = False
End Sub
Private Sub Init_Click()
DtString = " D=" + Trim(Str(DatePart("y", Date))) + " T=" + Time$
Call DisplayOutput(Slave(0) + InitString + DtString + " " + IniString.Text + ReadString)
Call DisplayOutput(Slave(1) + InitString + DtString + " " + IniString.Text + ReadString)
End Sub


Private Sub MSComm_OnComm()
Dim Temp As String
Dim Arr() As Byte
Dim x, TempLengte As Integer
Dim xpos As Integer
Select Case MSComm.CommEvent
    ' Handle each event or error by placing
    ' code below each case statement
    ' Errors
        Case comEventBreak
          ErrorText.Text = "A Break was received."
          Errorlamp.FillColor = RED
          MSComm.PortOpen = False
          MSComm.PortOpen = True
        Case comEventCDTO
          ErrorText.Text = "CD (RLSD) Timeout."
          Errorlamp.FillColor = RED
        Case comEventCTSTO
          ErrorText.Text = "CTS Timeout."
          Errorlamp.FillColor = RED
        Case comEventDSRTO
          ErrorText.Text = "DSR Timeout."
          Errorlamp.FillColor = RED
        Case comEventFrame
          ErrorText.Text = "Framing Error"
          Errorlamp.FillColor = RED
          MSComm.PortOpen = False
          MSComm.PortOpen = True
        Case comEventOverrun
          ErrorText.Text = "Data Lost."
          Errorlamp.FillColor = RED
        Case comEventRxOver
          ErrorText.Text = "Receive buffer overflow."
          Errorlamp.FillColor = RED
        Case comEventRxParity
          ErrorText.Text = "Parity Error."
          Errorlamp.FillColor = RED
        Case comEventTxFull
          ErrorText.Text = "Transmit buffer full."
          Errorlamp.FillColor = RED
        Case comEventDCB
          ErrorText.Text = "Unexpected error retrieving DCB]"
          Errorlamp.FillColor = RED
    
    ' Events
        Case comEvCD
          RaiseEvent CommunicatieErr(2)
        Case comEvCTS
        Case comEvDSR
        Case comEvRing
        Case comEvReceive
          TempLengte = MSComm.InBufferCount
          Temp = MSComm.Input
          Call PrintText(Temp)
          Buffer = Buffer + Temp
          Lengte = Lengte + Len(Temp)
          xpos = InStr(1, Buffer, Chr(4))
          Reading = True
          Errorlamp.FillColor = GREEN
          If InStr(1, Buffer, "empty" + Chr(13)) > 0 Then 'De slave is gereset
             Buffer = ""
             Lengte = 0
             Restart = True
          End If
          If Temp = Chr(4) Then
             Call VerwerkRegel(Buffer, Lengte)
             ErrorText.Text = ""
             Errorlamp.FillColor = LIGHTGRAY
             Buffer = ""
             Lengte = 0
          End If
        Case comEvSend
        Case comEvEOF
        Case Else
          Errorlamp.FillColor = RED
          ErrorText.Text = "Onbekend event"
    End Select
End Sub
Private Sub DisplayBox_DblClick()
DisplayBox.Text = ""
End Sub
Private Sub OutputBox_DblClick()
Outputbox.Text = ""
End Sub
Private Sub DisplayOutput(st)
Dim l As Integer
Const lbuf = 100
If Presentatie Then
      Outputbox.Text = Outputbox.Text + st
      l = Len(Outputbox.Text)
      Outputbox.SelStart = Len(Outputbox.Text) - 1
      Outputbox.SelLength = 1
      If l > lbuf Then Outputbox.Text = ""
   End If
MSComm.Output = st
End Sub

Private Sub Pauze_Click()
If PrgPauze = True Then
   PrgPauze = False
   PauzeText.Text = "Loopt"
   Else
   PrgPauze = True
   PauzeText.Text = "Pauze"
End If
End Sub


Private Sub Seconde_Timer()
Dim Uur, Minuut, Seconde As Integer
If Restart = True Then 'We hebben een regel met echo van de initstring ontvangen
   Restart = False
   Fase(0) = 0
   Fase(1) = 0
End If
 Select Case Fase(AktSlave)
   Case 0 'Initialiseer slave
      DtString = " D=" + Trim(Str(DatePart("y", Date))) + " T=" + Time$
      Call DisplayOutput(Slave(AktSlave) + InitString + DtString + " " + IniString.Text + ReadString)
      Fase(AktSlave) = 1
      Tijd(AktSlave) = 0
   Case 1 'Wacht 10 seconden en clear dan alle inkomende karakters
      Tijd(AktSlave) = Tijd(AktSlave) + 1
      If Tijd(AktSlave) = 10 Then 'Clear karakters
         Buffer = ""
         Lengte = 0
         Tijd(AktSlave) = 0
         Fase(AktSlave) = 2
      End If
   Case 2 'Vraag data van slave
      Call DisplayOutput(Slave(AktSlave) + ScanString)
      Tijd(AktSlave) = 0
      Fase(AktSlave) = 3
   Case 3 'Wacht 4 seconden en test op data
      If Lengte = 0 Then 'Er is geen data
         Tijd(AktSlave) = Tijd(AktSlave) + 1
         If Tijd(AktSlave) = 4 Then 'Abort commando
            Call DisplayOutput(Slave(AktSlave) + AbortString)
            Tijd(AktSlave) = 0
            Fase(AktSlave) = 5
         End If
    Else
      Tijd(AktSlave) = 0
      Fase(AktSlave) = 4
     End If
   Case 4 'Door de procedure verwerkregel wordt een clear verstuurd
      'Wacht nu 4 seconden, als de regel niet verwerkt is, clear dan het buffer en start opnieuw
      Tijd(AktSlave) = Tijd(AktSlave) + 1
      If Tijd(AktSlave) = 4 Then 'Clear buffer
         Lengte = 0
         Tijd(AktSlave) = 0
         Fase(AktSlave) = 5
      End If
   Case 5 'Wacht 4 seconden tot de volgende poll
      If PrgPauze = True Then Exit Sub
      Tijd(AktSlave) = Tijd(AktSlave) + 1
      If Tijd(AktSlave) > 4 Then Fase(AktSlave) = 2
      If AktSlave = 0 Then AktSlave = 1 Else AktSlave = 0
      Uur = DatePart("h", Time)
      Minuut = DatePart("n", Time)
      Seconde = DatePart("s", Time)
      If (Uur = 0) And (Minuut = 0) And (Seconde = 0) Then
         Call UpdateDatum
'         CompactJetDatabase ("Historie.mdb")
      End If
      
'test voor communicatie
'Call VerwerkRegel(DataTakerString, Len(DataTakerString))
      
End Select
FaseText(AktSlave).Text = Fase(AktSlave)
If AktSlave = 0 Then
   FaseText(0).BackColor = GREEN
   FaseText(1).BackColor = LIGHTGRAY
Else
   FaseText(1).BackColor = GREEN
   FaseText(0).BackColor = LIGHTGRAY
End If

End Sub
Private Sub StartPres_Click()
Presentatie = True
DisplayBox.Text = ""
Outputbox.Text = ""
End Sub
Private Sub StopPres_Click()
Presentatie = False
End Sub
Private Sub UpdateDatum()
DtString = "D=" + Trim(Str(DatePart("y", Date))) + " T=" + Time$
Call DisplayOutput(Slave(0) + DtString + Chr(13) + Chr(10))
Call DisplayOutput(Slave(1) + DtString + Chr(13) + Chr(10))
End Sub
Private Sub VerwerkRegel(Buffer, Lengte)
Dim I, HJaar, HDag, Dag, Slv As Integer
Dim Dat, Char As String
Dim SemiAktiv As Integer
RDataString = ""
Index = 0
SemiAktiv = -1 'invalid index


I = 1
'Haal alle elementen op gescheiden door een komma tot EOT (4)
While I < Lengte + 1
    Char = Mid$(Buffer, I, 1)
    Select Case Char
       Case "0" To "9", " ", ".", "-", ":"
          RDataString = RDataString + Mid$(Buffer, I, 1)
       Case Chr(4)
          RData(Index) = Val(RDataString)
          If Index <= 35 Then DataText(Index).Text = RData(Index)
          If Index = 0 Then Slv = Val(RDataString)
          If Index = 2 Then Ttijd.Text = RDataString
          RDataString = ""
          Index = Index + 1
          Debug.Print Index
       Case ","
          RData(Index) = Val(RDataString)
          If Index <= 35 Then DataText(Index).Text = RData(Index)
          If Index = 0 Then Slv = Val(RDataString)
          If Index = 2 Then Ttijd.Text = RDataString
          RDataString = ""
          Index = Index + 1
          Debug.Print Index
       Case Else
       Exit Sub
    End Select
    I = I + 1
Wend
If ((Slv = 0) Or (Slv > 3)) Then 'Dan is dit is een regel met onzin
   For I = 0 To 35
      DataText(I) = ""
   Next I
   Gewicht.Text = ""
   Temp.Text = ""
   Hoogte.Text = ""
   Tslave.Text = ""
   Ttijd.Text = ""
   Tdatum = ""
   Exit Sub
End If

'Make sure we are dealing with the correct slave
If (Slv = 3) Then
  SemiAktiv = 1
Else
  SemiAktiv = 0
End If

Gewicht.Text = VorigGewicht(Slv - 1)
VorigGewicht(Slv - 1) = 0
For I = 0 To 11
    If RData(I + 3) < 400 Then VorigGewicht(Slv - 1) = VorigGewicht(Slv - 1) + g(I)
Next I
Temp.Text = 0
For I = 0 To 9
    If RData(I + 15) > 200 Then Temp.Text = Temp.Text + g(I)
Next I
Hoogte.Text = 0
For I = 0 To 10
    If RData(I + 25) > 200 Then Hoogte.Text = Hoogte.Text + g(I)
Next I

'Tslave.Text = Pers(AktSlave)
Tslave.Text = Pers(SemiAktiv)

'Bepaal of het aantal dagen bij dit jaar of bij het vorig jaar behoort
HJaar = DatePart("yyyy", Date)
HDag = DatePart("y", Date)
Dag = RData(1) - 1
If Dag > HDag Then HJaar = HJaar - 1
Tdatum.Text = DateAdd("d", Dag, "1-Jan-" + Trim(Str(HJaar)))
Call DisplayOutput(Slave(AktSlave) + ClearString)

'AnodeNr(AktSlave) = BepaalAnodeNr(AktSlave)
AnodeNr(SemiAktiv) = BepaalAnodeNr(SemiAktiv)

'Call VoegRecordToe(Pers(AktSlave), Tdatum.Text, Ttijd.Text, Temp.Text, Gewicht.Text, Hoogte.Text, AnodeNr(AktSlave))
Call VoegRecordToe(Pers(SemiAktiv), Tdatum.Text, Ttijd.Text, Temp.Text, Gewicht.Text, Hoogte.Text, AnodeNr(SemiAktiv))
End Sub
Function BepaalAnodeNr(Slave As Integer) As Long

'Dim ConnString As String
Dim DBS As New ADODB.Connection
Dim RST As New ADODB.Recordset
'Dim DBS As DataBase
'Dim RST As Recordset
Dim Nr As Long
Dim ErrorCount As Integer

ErrorCount = 0
BepaalAnodeNr = 0

On Error GoTo ErrorOpenDB
'Set DBS = OpenDatabase("Historie.mdb")
'Set DBS = OpenDatabase("TellerStand", dbDriverNoPrompt, False, SQLconnectionstring)
'==================================================================================
'Switch from DAO to ADO, otherwise inserts and edits will always fail!
'Connection string from DAO is used for ADO!!!!
'==================================================================================
'ConnString = "driver={SQL Server};server=localhost;database=datataker;uid=datataker;pwd=datataker"
DBS.CursorLocation = adUseServer
DBS.ConnectionString = SQLconnectionstring
DBS.Mode = adModeShareExclusive
DBS.Open

RetryUpdate:
On Error GoTo ErrorOpenRec
'Set RST = DBS.OpenRecordset("TellerStand", dbOpenTable)
Set RST.ActiveConnection = DBS
RST.Open "select * from Tellerstand", DBS, adOpenKeyset, adLockPessimistic, adCmdText
    
On Error GoTo ErrorUpdateRec
With RST
   If .RecordCount = 0 Then
      
      
      .AddNew
      .Fields("135").Value = 0
      .Fields("335").Value = 0
   Else
      .MoveFirst
     ' .EditMode
   End If
   
   If Slave = 0 Then
      Nr = .Fields("135").Value + 1
      .Fields("135").Value = Nr
   End If
   If Slave = 1 Then
      Nr = .Fields("335").Value + 1
      .Fields("335").Value = Nr
   End If
   .Update
   
On Error GoTo ErrorCloseRec
   .Close

End With

Set RST = Nothing
DBS.Close
Set DBS = Nothing
BepaalAnodeNr = Nr
Exit Function

ErrorOpenDB:
    ErrorOpenDB = ErrorOpenDB + 1
    ErrorText.Text = "#" + Str(ErrorOpenDB) + " errors in open db: " + Str(Err.Number)
    Exit Function
    
ErrorOpenRec:
    ErrorOpenRec = ErrorOpenRec + 1
    ErrorText.Text = "#" + Str(ErrorOpenRec) + " errors in open rec: " + Str(Err.Number)
    On Error Resume Next
    DBS.Close
    Set DBS = Nothing
    Exit Function
    
ErrorUpdateRec:
    ErrorUpdateRec = ErrorUpdateRec + 1
    ErrorCount = ErrorCount + 1
    ErrorText.Text = "#" + Str(ErrorUpdateRec) + "(" + Str(ErrorUpdateCrit) + ") errors in update rec: " + Str(Err.Number)
    
    If (Err.Number <> 3051) And (Err.Number <> 3260) Then
      ErrorCount = ErrorCount + 5
    End If
    
    'sta een herhaling van 5 maal toe!
    If ErrorCount <= 5 Then
      
      On Error Resume Next
      Set RST = Nothing
      
      Sleep 500 'wacht een halve seconde en probeer opnieuw
      GoTo RetryUpdate
    End If
    
    ErrorUpdateCrit = ErrorUpdateCrit + 1
    ErrorText.Text = "#" + Trim(Str(ErrorUpdateRec)) + "(" + Trim(Str(ErrorUpdateCrit)) + ") errors in update rec: " + Str(Err.Number)
    On Error Resume Next
    Set RST = Nothing
    DBS.Close
    Set DBS = Nothing
    Exit Function

ErrorCloseRec:
    ErrorCloseRec = ErrorCloseRec + 1
    ErrorText.Text = "#" + Str(ErrorCloseRec) + " errors in close rec: " + Str(Err.Number)
    On Error Resume Next
    Set RST = Nothing
    DBS.Close
    Set DBS = Nothing
    Exit Function
End Function

Private Sub VoegRecordToe(Slave, Datum, Tijd, Temp, Gewicht, Hoogte, Nummer)
'Dim ConnString As String
Dim DBS As New ADODB.Connection
Dim RST As New ADODB.Recordset
'Dim DBS As DataBase
'Dim RST As Recordset
Dim ErrorCount As Integer

ErrorCount = 0

On Error GoTo ErrorOpenDB
'Set DBS = OpenDatabase("Historie.mdb")
'==================================================================================
'Switch from DAO to ADO, otherwise inserts and edits will always fail!
'Connection string from DAO is used for ADO!!!!
'==================================================================================
'ConnString = "driver={SQL Server};server=localhost;database=datataker;uid=datataker;pwd=datataker"
DBS.CursorLocation = adUseServer
DBS.ConnectionString = SQLconnectionstring
DBS.Mode = adModeShareExclusive
DBS.Open

RetryUpdate:
On Error GoTo ErrorOpenRec
'Set RST = DBS.OpenRecordset("Blokinfo", dbOpenTable)
Set RST.ActiveConnection = DBS
RST.Open "select * from Blokinfo", DBS, adOpenKeyset, adLockPessimistic, adCmdText

With RST
.AddNew
.Fields("PERS").Value = Slave
.Fields("DATUM_TIJD").Value = Datum + " " + Tijd
.Fields("HOOGTE").Value = Hoogte
.Fields("GEWICHT").Value = Gewicht
.Fields("TEMP").Value = Temp
.Fields("ANODETELLER").Value = Nummer

On Error GoTo ErrorUpdateRec
.Update

On Error GoTo ErrorCloseRec
'.Close
End With

'update record count
On Error GoTo ErrorOpenRec
'Set RST = DBS.OpenRecordset("SELECT * FROM Blokinfo", dbOpenDynaset, dbReadOnly)
With RST
  .MoveFirst
  .MoveLast
  HistorieAantal.Text = .RecordCount
On Error GoTo ErrorCloseRec
  .Close
End With

Set RST = Nothing

On Error GoTo ErrorCloseDB
DBS.Close
Set DBS = Nothing
Exit Sub

ErrorOpenDB:
    ErrorOpenDB = ErrorOpenDB + 1
    ErrorText.Text = "#" + Str(ErrorOpenDB) + " errors in open db: " + Str(Err.Number)
    Exit Sub
    
ErrorOpenRec:
    ErrorOpenRec = ErrorOpenRec + 1
    ErrorText.Text = "#" + Str(ErrorOpenRec) + " errors in open rec: " + Str(Err.Number)
    On Error Resume Next
    DBS.Close
    Set DBS = Nothing
    Exit Sub

ErrorUpdateRec:
    ErrorUpdateRec = ErrorUpdateRec + 1
    ErrorCount = ErrorCount + 1
    ErrorText.Text = "#" + Str(ErrorUpdateRec) + "(" + Str(ErrorUpdateCrit) + ") errors in update rec: " + Str(Err.Number)
    
    If (Err.Number <> 3051) And (Err.Number <> 3260) Then
      ErrorCount = ErrorCount + 5
    End If
    
    'sta een herhaling van 5 maal toe!
    If ErrorCount <= 5 Then
      
      On Error Resume Next
      Set RST = Nothing
      
      Sleep 500 'wacht een halve seconde en probeer opnieuw
      GoTo RetryUpdate
    End If
    
    ErrorUpdateCrit = ErrorUpdateCrit + 1
    ErrorText.Text = "#" + Trim(Str(ErrorUpdateRec)) + "(" + Trim(Str(ErrorUpdateCrit)) + ") errors in update rec: " + Str(Err.Number)
    On Error Resume Next
    Set RST = Nothing
    DBS.Close
    Set DBS = Nothing
    Exit Sub

ErrorCloseRec:
    ErrorCloseRec = ErrorCloseRec + 1
    ErrorText.Text = "#" + Str(ErrorCloseRec) + " errors in close rec: " + Str(Err.Number)
    On Error Resume Next
    Set RST = Nothing
    DBS.Close
    Set DBS = Nothing
    Exit Sub

ErrorCloseDB:
    ErrorCloseDB = ErrorCloseDB + 1
    ErrorText.Text = "#" + Str(ErrorCloseDB) + " errors in close db: " + Str(Err.Number)
    Set RST = Nothing
    Set DBS = Nothing
    Exit Sub
End Sub

Private Sub Timer1_Timer()

  If BlokContinu Then
  
    Call Blok_Click
  End If
End Sub