VERSION 5.00
Object = "{0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}#1.0#0"; "MSSCRIPT.OCX"
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.Form MainForm 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Станция"
   ClientHeight    =   1950
   ClientLeft      =   3675
   ClientTop       =   2415
   ClientWidth     =   5670
   BeginProperty Font 
      Name            =   "MS Sans Serif"
      Size            =   9.75
      Charset         =   204
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "station.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   1950
   ScaleWidth      =   5670
   StartUpPosition =   2  'CenterScreen
   Begin MSScriptControlCtl.ScriptControl ctrlScript 
      Left            =   3600
      Top             =   -120
      _ExtentX        =   1005
      _ExtentY        =   1005
      AllowUI         =   -1  'True
   End
   Begin VB.TextBox TextRecvStr 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   204
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   1455
      Left            =   15
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   2
      Top             =   480
      Width           =   5655
   End
   Begin MSCommLib.MSComm CommPort 
      Left            =   4560
      Top             =   -120
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      DTREnable       =   -1  'True
      Handshaking     =   2
      RTSEnable       =   -1  'True
      BaudRate        =   300
      StopBits        =   2
   End
   Begin VB.Label lblNumberCall 
      Caption         =   "0"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   204
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   2040
      TabIndex        =   1
      Top             =   120
      Width           =   495
   End
   Begin VB.Label lblResultCall 
      Caption         =   "Обработано звонков"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   204
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   1815
   End
   Begin VB.Menu mnuQuit 
      Caption         =   "&Выход"
   End
   Begin VB.Menu About 
      Caption         =   "&О программе"
   End
   Begin VB.Menu Help 
      Caption         =   "&?"
   End
End
Attribute VB_Name = "MainForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Compare Binary
Dim strBuffer As String ' строка для приема данных из последовательного порта
Dim strDelimiter As String 'разделитель в строке
Dim ADORecordData As New ADODB.Recordset ' рекордсет для работы с базой данных
Dim ADOConnection As New ADODB.Connection ' соединение для работы с базой данных
Dim bOutErrorToLog As Boolean ' выводить ошибки в лог-файл
Dim bValidInit As Boolean

Private Sub About_Click()
Dim frm As Form
   Set frm = New frmAbout
   frm.Show vbModal, Me
End Sub


' УМОЛЧАНИЯ НАСТРОЙКИ ПОРТА
'    CommPort.CommPort = 2 ' номер порта
'    CommPort.Settings = "300,N,8,2" 'параметры порта
'    CommPort.Handshaking = comRTS

Private Sub CommPort_OnComm()
Dim strTemp As String
Dim iPosChr As Integer
Dim bResult As Boolean
Dim iErrCode As Integer

    Select Case CommPort.CommEvent
    ' Handle each event or error by placing
    ' code below each case statement

    ' Errors
        Case comEventBreak  ' A Break was received.
        Case comEventCDTO   ' CD (RLSD) Timeout.
        Case comEventCTSTO  ' CTS Timeout.
        Case comEventDSRTO  ' DSR Timeout.
        Case comEventFrame  ' Framing Error
        Case comEventOverrun    ' Data Lost.
        Case comEventRxOver ' Receive buffer overflow.
        Case comEventRxParity   ' Parity Error.

        Case comEventTxFull ' Transmit buffer full.
        Case comEventDCB    ' Unexpected error retrieving DCB]
        
        Case comEvReceive ' если принят символ или несколько
        '  добавить то,  что  получили к тому, что осталось
            strBuffer = strBuffer + CommPort.Input ' получить строку символов из порта
            Do
                strTemp = GetFirstParam(strBuffer, vbLf, bResult)
                If Not bResult Then Exit Sub ' если строка обработана - завершить обработку события
                If InStr(strTemp, vbCr) > 0 Then strTemp = Left(strTemp, InStr(strTemp, vbCr) - 1) ' убрать переводы строки в конце
                'вызвать процедуру разбора и сохранения полученной строки на параметры
                AddStrToFile strFileLogName, AnsiToOem(strTemp), iErrCode 'загнать в лог по необходимости
                If bValidInit Then
                    If Not AddRecord(strTemp) And bOutErrorToLog Then
                        strTemp = "Ошибка: неверный формат строки - " & strTemp
                        AddStrToFile strFileLogName, AnsiToOem(strTemp), iErrCode 'загнать в лог по необходимости
                    End If
                End If
                DisplayText (strTemp) ' отобразить на экране
                Loop While bResult ' крутить цикл
          End Select

End Sub

Private Sub Form_Load()
Dim iErrCode  As Integer
Dim strTemp As String

    bValidInit = Initialize
    SetTrayIcon NIM_ADD, Me.hwnd, Me.Icon, "Станция"
    
    ' засадить в настройки
On Error GoTo Err_Init
     strErrorMsg = "Ошибка инициализации порта!"
     CommPort.PortOpen = True ' открыть порт

    CommPort.DTREnable = True ' ВЫСТАВИТЬ ГОТОВНОСТЬ ТЕРМИНАЛА
    CommPort.RThreshold = 1 ' отрабатывать при получении 1 байта
    Me.WindowState = vbMinimized
    Me.Hide
    
    strTemp = "Start at " & Format(Now(), "dd\/mm\/yyyy hh:nn:ss")
    AddStrToFile strFileLogName, strTemp, iErrCode 'загнать в лог по необходимости
    Exit Sub

Err_Init:
    MsgBox strErrorMsg, vbOKOnly + vbCritical, "Ошибка !"
    Err.Clear
    bValidInit = False
End Sub



Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim Msg As Variant
Dim strTemp As String
    Msg = X / Screen.TwipsPerPixelX
    If Msg = WM_LBUTTONDBLCLK Then
        Me.Visible = Not Me.Visible
        If Not Me.Visible Then Me.WindowState = vbMinimized
        End If
    End Sub




Private Sub Form_Unload(Cancel As Integer)
Dim iErrCode  As Integer
Dim strTemp As String ' в принципе, можно обойтись и без этой переменной

On Error Resume Next  ' если ошибка - закончить без претензий
  'SetHook Me.hwnd, lpPrevWndProc ' снять обработчик событий
  ADORecordData.Close ' закрыть набор данных
  ADOConnection.Close 'закрыть соединение
  ctrlScript.Reset    ' очистить скрипты
  If CommPort.PortOpen Then
    CommPort.PortOpen = False
    End If
  strTemp = "Stop  at " & Format(Now(), "dd\/mm\/yyyy hh:nn:ss")
  AddStrToFile strFileLogName, strTemp, iErrCode 'загнать в лог по необходимости
  SetTrayIcon NIM_DELETE, Me.hwnd, 0&, "" ' убить иконку в трее
  
  End Sub

Private Sub Help_Click()
    SendKeys "{F1}"
End Sub

Private Sub mnuQuit_Click()
    Unload Me
    End Sub

Private Function Initialize() As Boolean  ' инициализация параметров
Dim strTemp As String
Dim strBuff As String
Dim iCount As Integer
Dim iBuff As Byte
Dim bRes As Boolean
On Error Resume Next

     bRes = True
     strFileLogName = ""
    'закладка
   ' If Date > DateSerial(2001, 7, 31) Then
      '  MsgBox "Ошибка доступа к данным! Обратитесь к разработчикам!", vbCritical + vbOKOnly, "Ошибка"
       ' DisplayText ("Ошибка доступа к данным! Обратитесь к разработчикам!")
       ' Initialize = False
      '  Exit Function
   ' End If
    
    GetBaseExeName strTemp, strStartDirPath
    strFileLogName = strTemp + "Log"
    strFileScriptName = strTemp + "Bas"
    strBuffer = "" ' сбросить принятую строку
       
    ' загрузить файл скриптов
    
    Err.Clear
    iCount = FreeFile()
    strTemp = ""
    Open strFileScriptName For Binary Shared As #iCount
    If Err.Number <> 0 Then
        DisplayText ("Ошибка доступа к файлу скриптов: " & strFileScriptName)
        Err.Clear
        bRes = False
        End If
    
    
    While Not EOF(iCount)
        Get #iCount, , iBuff
        If Chr(iBuff) <> vbCr And _
            Chr(iBuff) <> vbLf Then strBuff = strBuff & Chr(iBuff)
        If Chr(iBuff) = vbLf Then
            Trim (strBuff)
            If (strBuff <> "") And _
                (InStr(strBuff, ";") <> 1) And _
                (InStr(1, strBuff, "REM ", vbTextCompare) <> 1) Then strTemp = strTemp & strBuff & vbCrLf
            strBuff = ""
        End If
    Wend
    Close #iCount
    
    ctrlScript.AddCode strTemp
    If Err.Number <> 0 Then
        DisplayText ("Ошибка подключения файла скриптов: " & strFileScriptName)
        Err.Clear
        bRes = False
    End If
    
    strTemp = ""
  
    ' получить файл связи с данными
    strDataLinkName = ctrlScript.Run("GetDataLinkPath")
    If Err.Number <> 0 Then
        DisplayText ("Ошибка выполнения функции GetDataLinkPath")
        Err.Clear
        bRes = False
    End If
    
        
    ' получить название таблицы
    strTableName = ctrlScript.Run("GetTableName")
    If Err.Number <> 0 Then
        DisplayText ("Ошибка выполнения функции GetTableName")
        Err.Clear
        bRes = False
    End If
    ADOConnection.ConnectionString = "File Name=" & strDataLinkName & ";"
    ADOConnection.Open ' открыть соединение с базой данных
    If Err.Number <> 0 Then
        DisplayText ("Ошибка создания соединения с базой данных")
        Err.Clear
        bRes = False
    End If
    ADORecordData.Open strTableName, ADOConnection, adOpenKeyset, adLockOptimistic, adCmdTable
    If Err.Number <> 0 Then
        DisplayText ("Ошибка доступа к таблице: " & strTableName)
        Err.Clear
        bRes = False
    End If
    
    CommPort.CommPort = ctrlScript.Run("GetCommNumber") ' номер порта
    If Err.Number <> 0 Then
        DisplayText ("Ошибка выполнения функции GetCommNumber")
        Err.Clear
        bRes = False
    End If
    
    CommPort.Settings = ctrlScript.Run("GetCommSettings") 'параметры порта
    If Err.Number <> 0 Then
        DisplayText ("Ошибка выполнения функции GetCommSettings")
        Err.Clear
        bRes = False
    End If
    
    CommPort.Handshaking = ctrlScript.Run("GetCommHandshaking") ' параметры управления потоком данных
    If Err.Number <> 0 Then
        DisplayText ("Ошибка выполнения функции GetCommHandshaking")
        Err.Clear
        bRes = False
    End If

    CommPort.InputLen = 0 ' сбросить данные в буфере приема
    
    
    strTemp = ctrlScript.Run("GetLogFileName") 'получить название лог-файла
    If Err.Number <> 0 Then
        Err.Clear
    Else
    strFileLogName = strTemp
    End If
    bOutErrorToLog = ctrlScript.Run("OutErrorToLog") ' необходимость вывода ошибок в лог-файл
    If Err.Number <> 0 Then
        bOutErrorToLog = False
        Err.Clear
    End If
        
    
    Initialize = bRes
    DisplayText ("Параметры инициализации: " & strFileIniName)
    DisplayText ("Файл протокола: " & strFileLogName)
    DisplayText ("Файл связи с данными: " & strDataLinkName)
    DisplayText ("Коммуникационный порт: " & CStr(CommPort.CommPort))
    DisplayText ("Параметры порта: " & CommPort.Settings)
    End Function


Public Function AddRecord(strLine As String) As Boolean
' идея следующая:
' перебираются все поля в таблице,  берется имя поля и с этим именем
' вызывается функция из скрипта, кот в качестве  параметра передается
' строка для разбора

Dim fld As ADODB.Field
Dim bUpdate As Boolean ' признак того, что данные добавлялись в таблицу( чтобы не писать пустых строчек)
Dim vTemp As Variant

    AddRecord = False
    ADORecordData.AddNew
    On Error GoTo Err_AddData
    bUpdate = False
    For Each fld In ADORecordData.Fields    ' Для  каждого поля в базе данных
        If Not IsProcedureFound(fld.Name) Then GoTo NextStep ' если для данного поля не прописано ничего
        vTemp = ctrlScript.Run(fld.Name, strLine)
        Select Case fld.Type
            Case adDate, adDBTime, adDBDate, adDBTimeStamp ' проверить на соответствие типа
                If Not IsDate(vTemp) Then
                    DisplayText ("ОШИБКА: Ошибка в поле " & fld.Name & ". Значение " & CStr(vTemp) & " не является датой/временем.")  'отобразить на экране
                    GoTo Label_FastExit ' выйти с отменой изменений
                End If 'If Not IsDate(strBuff)
                    
                'типы указаны не все - лень столо переписывать
                Case adTinyInt, adSmallInt, adInteger, adSingle, adBigInt, _
                    adCurrency, adDecimal, adDouble, adNumeric
                    If Not IsNumeric(vTemp) Then
                        DisplayText ("ОШИБКА: Ошибка в поле " & fld.Name & ". Значение " & CStr(vTemp) & " не является числом.")  'отобразить на экране
                        GoTo Label_FastExit
                        End If 'If Not IsNumeric(strBuff)
                        
                End Select
            fld.Value = vTemp
            bUpdate = True
NextStep:
        Next 'For Each fld
    If bUpdate Then
        ADORecordData.Update
        AddRecord = True
        Else ' если не было изменено ни одно поле - отменить добавление записи
        ADORecordData.CancelUpdate
        End If 'If bUpdate
    
    Me.lblNumberCall.Caption = Str(Val(Me.lblNumberCall.Caption) + 1)
    Exit Function
Err_AddData: 'обработать ошибку (коряво и лениво)
    DisplayText ("ОШИБКА: Ошибка записи в базу данных! Код : " & Err.Number) 'отобразить на экране
    Err.Clear
Label_FastExit:
    ADORecordData.CancelUpdate ' отменить все изменения в таблице
    End Function

'отображает сообщение в textboxе
Public Sub DisplayText(strMsg As String)
Dim strBuff As String
Dim iPos As Integer
    If Len(TextRecvStr.Text) > 10240 Then ' если длина стала больше 10Kb  то укоротить
        strBuff = Right(TextRecvStr.Text, 10240) 'оставить последние 10Kb, а то что было перед ними - убить
        iPos = InStr(strBuff, vbLf) ' найти позицию ближайшего перевода строки
        If iPos > 0 Then strBuff = Right(strBuff, Len(strBuff) - iPos)
        TextRecvStr.Text = strBuff & strMsg & vbCrLf 'отобразить на экране
        Else
        TextRecvStr.Text = TextRecvStr.Text & strMsg & vbCrLf 'отобразить на экране
        End If 'If Len(TextRecvStr.Text) > 10240
        TextRecvStr.SelStart = Len(TextRecvStr.Text)
End Sub


' проверяет наличие процедуры с указаным именем в скрипте

Private Function IsProcedureFound(strNameProc As String) As Boolean
Dim prTemp As Procedure
    IsProcedureFound = False
    For Each prTemp In ctrlScript.Procedures
        If UCase(prTemp.Name) = UCase(strNameProc) Then
            IsProcedureFound = True
            Exit Function
        End If
    Next prTemp
End Function
