Attribute VB_Name = "com"
Option Explicit


'----------------------------------------------------------
'tady se skoci pri startu programu a pri zmene COMu
'nastavi se parametry a zkusi se otevrit port s temito
'parametry. Pokud selze vypise ERROR,
'----------------------------------------------------------

Public Sub InicializaceCOM()

    On Error GoTo chyba
    
    '--------------------
    'pokud by byl port otevren
    'nejdrive ho zavreme
    '--------------------
    If Frm1.MSComm1.PortOpen = True Then
        Frm1.MSComm1.PortOpen = False
    End If
    
    '--------------------
    'nastaveni rychlosti prenosu
    '--------------------
    Frm1.MSComm1.Settings = Frm1.CboRychlost.Text & ",n,8,1"

    '--------------------
    'nastaveni cisla portu
    '--------------------
    Frm1.MSComm1.CommPort = Frm1.CboPort.ListIndex + 1
    
    '--------------------
    'nastaveni rizeni toku 0-bez rizeni (default)
    '--------------------
    Frm1.MSComm1.Handshaking = 0
            
    '--------------------
    'otevreni COMu
    '--------------------
    Frm1.MSComm1.PortOpen = True
      
    ZapisSystemLog "COM report", "Seriovy port " & Frm1.CboPort.Text & " otevren"
    DoEvents
    
    Exit Sub

chyba:
    
    ZapisSystemLog "COM ERROR", "Seriovy port " & Frm1.CboPort.Text & " nelze otevrit!"
    OdesliEmail "RDSManager Error", 1, "Seriovy port " & Frm1.CboPort.Text & " nelze otevrit!!"
            
    MsgBox "Error: " & Err.Description & vbCrLf & vbCrLf & _
    "    Sériový port je využíván jinou aplikací, nebo port neexistuje." + _
    vbCrLf + "Ukončete aplikaci,která tento port využívá, nebo vyberte jiný port.", vbCritical, "Port Initialization Failed!"
    DoEvents


End Sub


'----------------------------------------------------------
'udalost generovana komponentou MScomm je z formu presmerovana zde
'tady se vycucne co se delo a vypise do LOGu a pomocneho textoveho pole
'----------------------------------------------------------

Public Sub DATAzCOMu()

    Dim ERMsg As String
  
    '--------------------
    'CommEvent property - rozklicovani chyb a události z MSComm
    '--------------------

    Select Case Frm1.MSComm1.CommEvent
        
        '--------------------
        ' Event messages.
        '--------------------
    
        Case comEvReceive
        
            Dim aDZC As Integer
            Dim Bafr As String
            Dim Znak As String
        
            Bafr = Frm1.MSComm1.Input
                
            For aDZC = 1 To Len(Bafr)
                Znak = Mid(Bafr, aDZC, 1)
                Frm1.TxtCOM.Text = Frm1.TxtCOM.Text & Znak
            Next aDZC
                          
            StatusCom = "Data Receive" & vbCrLf & StatusCom
    
        Case comEvSend
            StatusCom = "Data Send" & vbCrLf & StatusCom
        Case comEvCTS
            StatusCom = "Change in CTS Detected" & vbCrLf & StatusCom
        Case comEvDSR
            StatusCom = "Change in DSR Detected" & vbCrLf & StatusCom
        Case comEvCD
            StatusCom = "Change in CD Detected" & vbCrLf & StatusCom
        Case comEvRing
            StatusCom = "The Phone is Ringing" & vbCrLf & StatusCom
        Case comEvEOF
            StatusCom = "End of File Detected" & vbCrLf & StatusCom

        
        '--------------------
        ' Error messages.
        '--------------------
        
        Case comBreak
            ERMsg = "Break Received"
            StatusCom = "Break Received" & vbCrLf & StatusCom
        Case comCDTO
            ERMsg = "Carrier Detect Timeout"
            StatusCom = "Carrier Detect Timeout" & vbCrLf & StatusCom
        Case comCTSTO
            ERMsg = "CTS Timeout"
            StatusCom = "CTS Timeout" & vbCrLf & StatusCom
        Case comDCB
            ERMsg = "Error retrieving DCB"
            StatusCom = "Error retrieving DCB" & vbCrLf & StatusCom
        Case comDSRTO
            ERMsg = "DSR Timeout"
            StatusCom = "DSR Timeout" & vbCrLf & StatusCom
        Case comFrame
            ERMsg = "Framing Error"
            StatusCom = "Framing Error" & vbCrLf & StatusCom
        Case comOverrun
            ERMsg = "Overrun Error"
            StatusCom = "Overrun Error" & vbCrLf & StatusCom
        Case comRxOver
            ERMsg = "Receive Buffer Overflow"
            StatusCom = "Receive Buffer Overflow" & vbCrLf & StatusCom
        Case comRxParity
            ERMsg = "Parity Error"
            StatusCom = "Parity Error" & vbCrLf & StatusCom
        Case comTxFull
            ERMsg = "Transmit Buffer Full"
            StatusCom = "Transmit Buffer Full" & vbCrLf & StatusCom
        Case Else
            ERMsg = "Unknown error or event"
            StatusCom = "Unknown error or event" & vbCrLf & StatusCom
        
    End Select
    
    If Len(ERMsg) <> 0 Then
        ZapisSystemLog "COM ERROR", ERMsg
    End If
       
    StatusCom = Left(StatusCom, 600)
    Frm1.TxtComST.Text = StatusCom
    
    DoEvents



End Sub


'----------------------------------------------------------
'manager odeslani textu
'
'retezec se prekoduje - cestina se prevede na ASCI
'zkontroluje se na rozsah 32-125
'necha se spocitat kontrolni soucet retezce
'retezec se doplni o kontrolni soucet
'a necha poslat retezec na COM a ceka se jestli
'se podari skutecne odeslat
'pokud se do tri vterin nenastavi promenna 'dockal se'
'text neodesel - chyba - zapis do denniho LOGu ze error
'----------------------------------------------------------

Public Sub Odeslat()
    
    Dim vv As Integer
    Dim DockalSe As Boolean
    
    '---------------------
    'doplneni na 64 znaku
    Doplneni OutString
    
    '---------------------
    'prekoduje cestinu
    Prekodovani OutString
    
     
    '---------------------
    'kontrola na nepovolene znaky
    '(mimo rozsah 32 -125)
    KontrolaBloku OutString
    

    '---------------------
    'prida hlavicku k textu
    Retezec = HlavickaTextu & OutString
    
    '---------------------
    'vypocet kontrolniho souctu
    KontrolSoucet Retezec
    

    '---------------------
    'kompletace radku
    PripravProOdvysilani Retezec
    

    '---------------------
    'vlastni odeslani na COM
    Frm1.TxtCOM.Text = ""
    OdeslatNaCom
    
    DoEvents
    
    '---------------------
    'ceka se 3 vteriny (3*(250ms *4))
    'pokud retezec odejde
    'nastane udalost  MScom.received
    'a koder vrati ???? - potvrdi prijeti
    '(pokud ne, text korektne neodesel)
    
    'DockalSe = False
    
    'Cekam = 0
    'Do While Cekam < 12
        
     '   If InStr(1, Frm1.TxtCOM.Text, ">", 1) > 0 Then
        
     '       DockalSe = True
     '       Exit Do
            
     '   End If
    
     '   DoEvents
    'Loop

    'If DockalSe = False Then
        
    '   Open CestaSoubory & "\RDS-Logy\Odvysilano\" & GenerujNazevSouboru(Date) & ".rds" For Append As #16
    '     Print #16, Format(Time, "hh:mm:ss") & _
    '         " ================Radek nebyl odvysilan===========================  " & OutTyp & "  ERROR"
    '   Close #16
        
    '   Frm1.TxtStStat.ForeColor = &HC0&
    '   Frm1.TxtStStat = "            ERROR - řádek se nepodařilo odeslat !!!"
    '   Frm1.LblStatusKdy.Caption = Format(Time, "hh:mm:ss")
    '   Frm1.LblStIndik.BackColor = &H8080FF
    '   Frm1.LblStIndik.ForeColor = &H80000012
    '   Frm1.LblStIndik.Caption = "ERROR"
        
    '   DoEvents
    '   Exit Sub
        
    '   Else
        
        '--------------------
        'vytvori soubor s aktualne odeslanym textem
        'ktery vyuziva produkni soft pro obrazeni
        
    'End If
    
    
End Sub


'----------------------------------------------------------
'odesle konecne retezec na COM
'----------------------------------------------------------

Public Sub OdeslatNaCom()
   
    '--------------------
    'jestli je port otevreny ...
    '--------------------
    If Frm1.MSComm1.PortOpen = True Then
    
        '--------------------
        'posli retezec
        '--------------------
        Frm1.MSComm1.Output = Retezec
            
        Open CestaSoubory & "\RDS-Logy\Odvysilano\Texty\" & GenerujNazevSouboru(Date) & ".rds" For Append As #16
            Print #16, Format(Time, "hh:mm:ss") & " " & Left(OutString, 64) & "  " & OutTyp
        Close #16
        
        If (OutTyp = "PROMO         ") Then
            Open CestaSoubory & "\RDS-Logy\Odvysilano\Promo\" & GenerujNazevSouboru(Date) & "_Promo.rds" For Append As #16
                Print #16, Format(Time, "hh:mm:ss") & " " & Left(OutString, 64)
            Close #16
        End If
        
        DoPraveVysilame
        
    Else:
        Frm1.LblStStat.ForeColor = &H2248FF
        Frm1.LblStStat.Caption = "Retezec se nepodarilo odeslat!!!"
        
        Open CestaSoubory & "\RDS-Logy\Odvysilano\Texty\" & GenerujNazevSouboru(Date) & ".rds" For Append As #16
            Print #16, Format(Time, "hh:mm:ss") & _
                " ================Radek nebyl odvysilan===========================  " & OutTyp & "  ERROR"
        Close #16
        
        If (OutTyp = "PROMO         ") Then
            Open CestaSoubory & "\RDS-Logy\Odvysilano\Promo\" & GenerujNazevSouboru(Date) & "_Promo.rds" For Append As #16
                Print #16, Format(Time, "hh:mm:ss") & _
                " ================Radek nebyl odvysilan===========================  " & OutTyp & "  ERROR"
            Close #16
        End If
        
        OdesliEmail "RDSManager Error", 1, Date & " " & Time & "Retezec se nepodarilo odeslat!!"
    End If
    
    DoEvents

End Sub


'----------------------------------------------------------
'dopneni na 64 znaku
'----------------------------------------------------------

Public Function Doplneni(ss As String)

    ss = ss & String(64, Chr(32))
    ss = Left(ss, 64)
    
    DoEvents

End Function


'----------------------------------------------------------
'z ceskych pismenek odstrani hacky a carky
'----------------------------------------------------------

Public Function Prekodovani(ss As String) As String

    Dim a As Integer
    Dim b As String

    For a = 1 To Len(ss)
    
        b = Mid(ss, a, 1)

        If b = "á" Then Mid(ss, a, 1) = "a": GoTo bez
        If b = "Á" Then Mid(ss, a, 1) = "A": GoTo bez
        If b = "ä" Then Mid(ss, a, 1) = "a": GoTo bez
        If b = "Ä" Then Mid(ss, a, 1) = "A": GoTo bez
        If b = "č" Then Mid(ss, a, 1) = "c": GoTo bez
        If b = "Č" Then Mid(ss, a, 1) = "C": GoTo bez
        If b = "ď" Then Mid(ss, a, 1) = "d": GoTo bez
        If b = "Ď" Then Mid(ss, a, 1) = "D": GoTo bez
        If b = "é" Then Mid(ss, a, 1) = "e": GoTo bez
        If b = "É" Then Mid(ss, a, 1) = "E": GoTo bez
        If b = "ě" Then Mid(ss, a, 1) = "e": GoTo bez
        If b = "Ě" Then Mid(ss, a, 1) = "E": GoTo bez
        If b = "í" Then Mid(ss, a, 1) = "i": GoTo bez
        If b = "Í" Then Mid(ss, a, 1) = "I": GoTo bez
        If b = "ň" Then Mid(ss, a, 1) = "n": GoTo bez
        If b = "Ň" Then Mid(ss, a, 1) = "N": GoTo bez
        If b = "ó" Then Mid(ss, a, 1) = "o": GoTo bez
        If b = "Ó" Then Mid(ss, a, 1) = "O": GoTo bez
        If b = "ř" Then Mid(ss, a, 1) = "r": GoTo bez
        If b = "Ř" Then Mid(ss, a, 1) = "R": GoTo bez
        If b = "š" Then Mid(ss, a, 1) = "s": GoTo bez
        If b = "Š" Then Mid(ss, a, 1) = "S": GoTo bez
        If b = "ť" Then Mid(ss, a, 1) = "t": GoTo bez
        If b = "Ť" Then Mid(ss, a, 1) = "T": GoTo bez
        If b = "ú" Then Mid(ss, a, 1) = "u": GoTo bez
        If b = "Ú" Then Mid(ss, a, 1) = "U": GoTo bez
        If b = "ů" Then Mid(ss, a, 1) = "u": GoTo bez
        If b = "Ů" Then Mid(ss, a, 1) = "U": GoTo bez
        If b = "ý" Then Mid(ss, a, 1) = "y": GoTo bez
        If b = "Ý" Then Mid(ss, a, 1) = "Y": GoTo bez
        If b = "ž" Then Mid(ss, a, 1) = "z": GoTo bez
        If b = "Ž" Then Mid(ss, a, 1) = "Z": GoTo bez

bez:

    Next a
    
    DoEvents

End Function


'----------------------------------------------------------
'dokompletovani retezce
'k retezci prida vypocteny kontrolni soucet
'----------------------------------------------------------

Public Sub PripravProOdvysilani(ss As String)

   ss = ss & ks1 & ks2 & Chr$(255)
   
   DoEvents

End Sub


'----------------------------------------------------------
'spocita se kontrolni soucet retezce "outstring"
'----------------------------------------------------------

Public Sub KontrolSoucet(ss As String)
    
    Dim a As Integer
    Dim b As Integer
    Dim crcL As Integer
    Dim crcR As Integer
    Dim crcRold As Integer
    Dim crcLold As Integer
    Dim crcL1 As Integer
    Dim crcR1 As Integer

    crcL = 255
    crcR = 255

    For a = 2 To Len(ss)
     
    '--------------------
    'prvni radek
    '--------------------
    
        crcRold = crcR
        crcLold = crcL
        crcR = crcLold Xor Asc(Mid(ss, a, 1))
        crcL = crcRold

    '--------------------
    'druhy radek
    '--------------------
    
        crcR = crcR Xor Int(crcR / 16)
    
    '--------------------
    'treti radek
    '--------------------

        crcL1 = 0: crcR1 = crcR
        For b = 1 To 5
                If (crcR1 Xor 128) < crcR1 Then
                        crcR1 = (crcR1 And 127) * 2
                        crcL1 = ((crcL1 And 127) * 2) + 1
                Else
                        crcR1 = (crcR1 And 127) * 2
                        crcL1 = (crcL1 And 127) * 2
                End If
        Next b
     
        crcL = crcL Xor ((crcR And 15) * 16) Xor crcL1
        crcR = crcR Xor crcR1

    Next a

    crcL = crcL Xor 255
    crcR = crcR Xor 255

    Let ks1 = Chr$(crcL)
    Let ks2 = Chr$(crcR)

    DoEvents

End Sub


'----------------------------------------------------------
'zkontroluje jestli v radku k odeslani nejsou nepovolene znaky
'ktrere by delaly bordel pri odeslani a v radiu
'----------------------------------------------------------

Public Sub KontrolaBloku(ss As String)

    Dim a As Integer
    Dim b As Integer
    
    For a = 1 To Len(ss)
        
        Let b = Asc(Mid(ss, a, 1))
            
        If ((b < 32) Or (b > 125)) Then
    
            Mid(ss, a, 1) = Chr(32)
        
        End If
    
    Next a
    
    DoEvents

End Sub


'----------------------------------------------------------
'kontrola jestli posledni odeslany radek na COM neni stejny
's tim ktery se ma odeslat nyni
'pokud ano stejny text se neodesle - v radiu by to zbytecne
'preskakovalo
'----------------------------------------------------------

Public Function KontrolaOutstringu() As Boolean

    If (OutString <> OutStringStary) Then
    
        KontrolaOutstringu = True
        OutStringStary = OutString
        
    Else
    
        KontrolaOutstringu = False
        DoPraveVysilame
        
    End If

End Function
