''--------------------------------------------------------------------------------------------------------------------- '' Copyright TKB - all rights reserved '' Erstellt am : Unbekannt '' Erstellt durch: Stefan Hutter, TKB '' Fachbereich : TEC '' Beschreibung : '' '' History : ''-------------------------------------------------------------------------------------------------------------------- '' Datum Name, Firma Beschreibung ''-------------------------------------------------------------------------------------------------------------------- '' 22.05.2017 Tobias Verstappen, TKB Programm so ergänzt, dass neue XML Files erkannt werden und in die EDOKA '' Datenbank gespeichert werden. ''-------------------------------------------------------------------------------------------------------------------- Imports System.Timers Imports IBM.WMQ Imports IBM Imports System.ServiceProcess Imports System.Runtime.Remoting Imports System.Runtime.Remoting.Channels Imports System.Xml Imports System.Data.SqlClient Imports System.IO Imports System.Reflection Imports bms Imports System.Text.RegularExpressions Imports IBM.WMQ.Nmqi Public Class EDKB04OP Inherits System.ServiceProcess.ServiceBase Dim WithEvents tmrQueuePolling As Timer = New Timer(2000) Dim myStopper As ErrorStopper Dim fileWatch As New FileSystemWatcher() #Region " Vom Component Designer generierter Code " Public Sub New() MyBase.New() ' Dieser Aufruf wird vom Komponenten-Designer benötigt. InitializeComponent() ' Fügen Sie Initialisierungscode hinter dem InitializeComponent()-Aufruf ein End Sub ''UserService überschreibt den Löschvorgang zum Bereinigen der Komponentenliste. 'Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean) ' If disposing Then ' If Not (components Is Nothing) Then ' components.Dispose() ' End If ' End If ' MyBase.Dispose(disposing) 'End Sub '' Der Haupteinstiegspunkt für den Vorgang ' _ 'Shared Sub Main() ' Dim ServicesToRun() As System.ServiceProcess.ServiceBase ' ServicesToRun = New System.ServiceProcess.ServiceBase() {New EDKB04OP} ' System.ServiceProcess.ServiceBase.Run(ServicesToRun) 'End Sub #End Region #Region "StartStop" Protected Overrides Sub OnStart(ByVal args() As String) Try 'init BMS #If CONFIG = "Release" Then Dim m_log1 As New bms.Logging(6, Common.Common.JobType.WatchJob) m_logOld = m_log1 #Else Dim m_log1 As New Globals.log m_logOld = m_log1 #End If '#If DEBUG Then ' Dim m_log1 As New Globals.log ' m_log = m_log1 '#Else 'Dim m_log1 As New bms.Logging(6, Common.Common.JobType.WatchJob) 'm_log = m_log1 '#End If Dim m_logAdapter As New Globals.LogAdapter m_log = m_logAdapter m_log.start() m_log.log("EDKB04: Start", Common.Common.JournalEntryType.Information) 'Init Params Params.Loadparameters() m_log.log("EDKB04: Params.WaitForBrake= " & Params.WaitForBrake, Common.Common.JournalEntryType.Information) 'Init File Watcher fileWatch.Path = Params.Watchdir fileWatch.IncludeSubdirectories = False fileWatch.Filter = "*.xml" AddHandler fileWatch.Created, New FileSystemEventHandler(AddressOf OnFileEvent) fileWatch.EnableRaisingEvents = True 'init DB-Connection Dim sconnection = New DB_Connection() 'init Timer tmrQueuePolling.AutoReset = False If CInt(Params.TimerInterval) > 0 Then tmrQueuePolling.Start() m_log.log("EDKB04: tmrQueuePolling.Started") Else tmrQueuePolling.Enabled = False End If 'Init Error Stopper Me.myStopper = New ErrorStopper Me.myStopper.init(Params.nb_errors, Params.nb_seconds) Catch ex As Exception WriteLog("BMS-Connection / XML: " + ex.Message, appPath + "Error.txt") m_log.log(ex.Message, Common.Common.JournalEntryType.Error) Exit Sub End Try End Sub Protected Overrides Sub OnStop() ' Hier Code zum Ausführen erforderlicher Löschvorgänge zum Beenden des Dienstes einfügen. m_log.log("EDKB04 Stop", Common.Common.JournalEntryType.Information) m_log.ende() End Sub #End Region #Region "Log" Private Sub WriteLog(ByVal stext As String, ByVal sPfad As String) Try Dim FiStr As FileStream = New FileStream(sPfad, FileMode.Append) Dim StrWr As StreamWriter = New StreamWriter(FiStr) StrWr.WriteLine("Fehler: " + Now() & " Text:" & stext) StrWr.Close() Catch ex As Exception End Try End Sub Private Function writeDebug(ByVal xmlstring As String, Optional ByVal filenameSuffix As String = "", Optional ByVal filenameBase As String = "") As String Dim result As Boolean = True Dim filename As String = "" Try Dim writer As System.IO.StreamWriter Dim filetimestamp As String = GetFormatNow() If filenameBase <> "" Then filetimestamp = filenameBase End If filename = Params.DebugDir & filetimestamp & filenameSuffix & ".xml" writer = IO.File.AppendText(filename) writer.WriteLine(xmlstring) writer.Close() Catch ex As Exception m_log.log("EDKB04: Error beim Abspeichern der Debug .xml Daten") result = False End Try Return filename End Function Private Sub renameFromXmlToErr(ByVal filename As String) Try If filename.EndsWith(".xml") Then filename = filename.Substring(0, filename.Length - 4) File.Move(filename & ".xml", filename & ".err") End If Catch ex As Exception m_log.log("EDKB04: Error in renameFromXmlToErr()") End Try End Sub #End Region #Region "Timer" Public Sub OnTimedEvent(ByVal source As Object, ByVal e As ElapsedEventArgs) Handles tmrQueuePolling.Elapsed Try 'm_log.log("EDKB04: OnTimedEvent called", Common.Common.JournalEntryType.Information) ReadfromMQ() Catch ex As Exception m_log.log("EDKB04: Exception catched in OnTimedEvent()") Finally tmrQueuePolling.Start() m_log.log("EDKB04: tmrQueuePolling.Started") End Try End Sub #End Region Public Function IsKreditantragWizardMessage(Message As String) As Boolean Dim ret As Boolean ret = False Dim regex As Regex = New Regex("DokumentTypNr") Dim match As Match = regex.Match(Message) If match.Success Then ret = True End If Return ret End Function Private Function GetXmlFromDoc(XmlDoc As XmlDocument) As String Dim ret As String Using stringWriter = New StringWriter() Using xmlTextWriter = New System.Xml.XmlTextWriter(stringWriter) xmlTextWriter.Formatting = Formatting.Indented XmlDoc.WriteTo(xmlTextWriter) xmlTextWriter.Flush() ret = stringWriter.GetStringBuilder().ToString() End Using End Using Return ret End Function ''' ''' Fügt die TGNummer des Erstellers und die XML-Datei in die Datenbank (edk_data) ein. ''' ''' ''' Sub InsertMessageIntoTableEdkData(Message As String) Dim sql As String Dim doc As New XmlDocument Dim node As XmlNode doc.LoadXml(Message) node = doc.SelectSingleNode("/action/actionId") 'node.InnerText = "3" Message = Message.Replace("" + node.InnerText + "", "3") + vbCrLf 'Message = doc.OuterXml 'Message = GetXmlFromDoc(doc) 'Holt die TGNummer des Erstellers aus dem XML Dim TGNummer As String = XmlHelper.GetItemValueByTagName(doc, "creatorTg") TGNummer = TGNummer.ToLower Using adapter As SqlDataAdapter = New SqlDataAdapter Using connection As SqlConnection = New SqlConnection(Globals.sConnectionString_edoka) sql = "insert into edk_data (TGNummer, Status, xmldata) values(@tgNummer, 0, @data)" Try connection.Open() Using insertCommand As SqlCommand = New SqlCommand(sql, connection) adapter.InsertCommand = insertCommand Dim dataBytes As Byte() dataBytes = System.Text.Encoding.GetEncoding("iso-8859-1").GetBytes(Message) adapter.InsertCommand.Parameters.AddWithValue("@data", dataBytes) adapter.InsertCommand.Parameters.AddWithValue("@tgNummer", TGNummer) adapter.InsertCommand.ExecuteNonQuery() End Using Catch ex As Exception m_log.log("EDKB04: InsertMessageIntoTableXmlData Error: " & ex.ToString()) End Try End Using End Using End Sub #Region "File Watcher" Private Sub OnFileEvent(ByVal source As Object, ByVal e As FileSystemEventArgs) Globals.archiveFilename = "" Try 'Threading.Thread.Sleep(2000) Dim di As New IO.DirectoryInfo(Params.Watchdir) Dim diar1 As IO.FileInfo() = di.GetFiles("*.xml") Dim dra As IO.FileInfo Dim data As String Dim counter As Integer = 0 For Each dra In diar1 counter = counter + 1 Dim fil As New StreamReader(dra.FullName) data = fil.ReadToEnd() fil.Close() HandleXmlContent(data, dra.Name) File.Delete(dra.FullName) Next Catch ex As Exception m_log.log("EDKB04: FileWatcher Error: " & ex.Message, Common.Common.JournalEntryType.Error) End Try End Sub #End Region #Region "MQ" Private lastFormatNow As String = Format(Now, "yyyyMMddHHmmssffff") Private Function GetFormatNow() As String Dim thisFormatNow = Format(Now, "yyyyMMddHHmmssffff") While thisFormatNow = lastFormatNow Threading.Thread.Sleep(5) thisFormatNow = Format(Now, "yyyyMMddHHmmssffff") End While lastFormatNow = thisFormatNow Return thisFormatNow End Function Private Function GetFilenameIndex(ByVal indexCounter As Integer) End Function Private Sub HandleXmlContent(ByVal strXMLContent As String, Optional ByVal givenFilename As String = "") Dim filename1 As String = "" Dim filename2 As String = "" 'Me.Log("Message Content:" & strMsg) If Params.DebugMode Then If givenFilename <> "" Then If givenFilename.ToLower().EndsWith(".xml") Then givenFilename = givenFilename.Substring(0, givenFilename.Length - 4) End If filename1 = givenFilename & "_" & GetFormatNow() Else filename1 = GetFormatNow() End If End If Globals.archiveFilename = filename1 'm_log.Log("EDKB04: filename1 = " & filename1) 'm_log.Log("EDKB04: Message Length:" & Len(strMsg) & " Chars", Common.Common.JournalEntryType.Information) Dim splitter() As String Dim splitstring = " "" Then numberOfXmls = numberOfXmls + 1 End If Next Dim filenameIndex As Integer = 1 If numberOfXmls > 1 Then If Params.WriteUnsplittedFile > 0 Then Me.writeDebug(strXMLContent, "unsplitted", filename1) End If Else 'kein Filename Index, wenn nur ein Xml da ist filenameIndex = 0 End If For i As Integer = 0 To splitter.Length - 1 Dim xml As String = splitter(i) If xml.Trim() <> "" Then xml = splitstring + splitter(i) If Params.DebugMode Then Dim filenameIndexText As String = "" If filenameIndex > 0 Then filenameIndexText = String.Format("split{0,5:D5}", filenameIndex) End If filename2 = Me.writeDebug(xml, filenameIndexText, filename1) 'm_log.Log("EDKB04: filename2 = " & filename2) filenameIndex = filenameIndex + 1 End If If Not XMLtoObj(xml) Then If Params.DebugMode Then Me.renameFromXmlToErr(filename2) End If End If If Params.WaitForBrake > 0 Then Dim currentDate1 As DateTime = DateTime.Now Threading.Thread.Sleep(Params.WaitForBrake) Dim currentDate2 As DateTime = DateTime.Now Dim elapsedTicks As Long = currentDate2.Ticks - currentDate1.Ticks Dim elapsedSpan As TimeSpan = New TimeSpan(elapsedTicks) m_log.log(String.Format("EDKB04: elapsedTicks = {0}", elapsedTicks)) End If End If Next End Sub Private Function ReadfromMQ() As Boolean Globals.archiveFilename = "" Dim mqQMgr As MQQueueManager '* MQQueueManager instance Dim mqQueue As MQQueue = Nothing '* MQQueue instance Dim queueName As String '* Name of queue to use Dim strMsg As String Dim result As Boolean 'tmrQueuePolling.Stop() 'm_log.Log("EDKB04: Start MQ Verbindungsaufbau", Common.Common.JournalEntryType.Information) queueName = Params.MQQueueName Try MQEnvironment.Hostname = Params.MQHostname 'Bsp: "vb0049d" MQEnvironment.Port = Params.MQPort 'Bsp: 1416 MQEnvironment.Channel = Params.MQChannel 'Bsp: "TGKB.D16.EDOKA.CL" Try mqQMgr = New MQQueueManager() mqQueue = mqQMgr.AccessQueue(queueName, MQC.MQOO_INPUT_AS_Q_DEF + MQC.MQOO_FAIL_IF_QUIESCING) '* open queue for input but not if MQM stopping Catch ex As Exception m_log.log("EDKB04: MQ Error: " & ex.Message, Common.Common.JournalEntryType.Error) End Try Catch mqe As IBM.WMQ.MQException m_log.log("EDKB04: Error: " & mqe.Message, Common.Common.JournalEntryType.Error) m_log.log("EDKB04: Errorcode: " & mqe.CompletionCode, Common.Common.JournalEntryType.Error) m_log.Log("EDKB04: Reasoncode: " & mqe.ReasonCode, Common.Common.JournalEntryType.Error) End Try Try Dim isContinue As Boolean = True Dim strXMLContent As String Do While (isContinue = True) Globals.archiveFilename = "" Dim mqMsg As MQMessage '* MQMessage instance Dim mqGetMsgOpts As MQGetMessageOptions '* MQGetMessageOptions instance mqMsg = New MQMessage() mqGetMsgOpts = New MQGetMessageOptions() Try If CInt(Params.TimerInterval) > 0 Then mqGetMsgOpts.WaitInterval = CInt(Params.TimerInterval) Else mqGetMsgOpts.WaitInterval = 15000 '* 15 second limit for waiting End If Catch ex As Exception mqGetMsgOpts.WaitInterval = 15000 '* 15 second limit for waiting End Try mqGetMsgOpts.Options = MQC.MQGMO_WAIT Try mqQueue.Get(mqMsg, mqGetMsgOpts) 'mqQueue. If (mqMsg.Format.CompareTo(MQC.MQFMT_STRING) = 0) Then strMsg = mqMsg.ReadString(mqMsg.MessageLength) strMsg = strMsg strXMLContent = strMsg HandleXmlContent(strXMLContent) result = True Else If Me.myStopper.insert Then m_log.log("EDKB04: Non-text message", Common.Common.JournalEntryType.Error) result = False End If Catch mqe As IBM.WMQ.MQException '* report reason, if any If (mqe.Reason = MQC.MQRC_NO_MSG_AVAILABLE) Then '* special report for normal end m_log.log("EDKB04: no more messages", Common.Common.JournalEntryType.Information) isContinue = False Else '* general report for other reasons If Me.myStopper.insert Then m_log.log("EDKB04: MQQueue::Get ended with {0}: " & mqe.Message, Common.Common.JournalEntryType.Error) '* treat truncated message as a failure for this sample 'If (mqe.Reason = MQC.MQRC_TRUNCATED_MSG_FAILED) Then isContinue = False 'End If End If result = False End Try If LCase(Params.LoopQueue) = "false" Then isContinue = False End If Loop Catch ex As Exception If Me.myStopper.insert Then m_log.log("EDKB04: Error bei GET: " & ex.Message, Common.Common.JournalEntryType.Error) result = False Finally If CInt(Params.TimerInterval) > 0 Then 'tmrQueuePolling.Start() End If End Try Return result End Function Private Function XMLtoObj(ByVal strXMLContent As String) As Boolean Dim result As Boolean If (IsKreditantragWizardMessage(strXMLContent)) Then InsertMessageIntoTableEdkData(strXMLContent) result = True Else Try 'm_log.Log("EDKB04: Lese XML String in Objekt", Common.Common.JournalEntryType.Information) Dim xmlh As New xmlHandling(strXMLContent) result = xmlh.Result xmlh = Nothing 'm_log.Log("EDKB04: Lese XML String in Objekt ENDE", Common.Common.JournalEntryType.Information) Catch ex As Exception m_log.log("EDKB04: Error bei XML->Obj: " & ex.Message, Common.Common.JournalEntryType.Error) result = False End Try End If Return result End Function #End Region End Class