Foltyn Presentation - Convert BASIC-Code to HTML by Publisher + VB15



	Ein Programm in der Programmiersprache		A program in the programming language
	Visual BASIC 2015
	zur Konversion von jedem BASIC-code in HTML-Text durch Verwendung des Publishers von MS-Office		for conversion of any BASIC-Code in HTML-text by use of the Publisher from MS-Office
	Das Programm hat dieselben Funktionen wie jenes auf dieser Seite , ist aber in Visual BASIC 2015 geschrieben. Hier kann man die Unterschiede in der Schreibweise und den Daten- Strukturen sehen und vergleichen. Das Programm ist fertig, wobei es für die Konversion des eigenen Codes zur Anzeige vom Publisher 452 kByte bekommt, reduziert sie auf 189 kByte und durch die Reduktion von aufeinanderfolgenden TAGs mit gleicher Farbe wird der Code weiter reduziert auf 162 kByte. Und dieser ist dann geeignet zur Implementierung in anderen Webseiten-Code. Hier wird die Technik der ArrayList ausprobiert. Der Code muss zeilenweise abgearbeitet werden, damit nicht <BR>-s in the TAGs hinein geraten. So muss eine ArrayListe pro Zeile eine verschiedene Anzahl von Elementen halten, wobei die Verarbeitung der Text-Elemente im Format List(of String) erfolgt, welches eine ausreichende Anzahl von Methoden zur Verfügung stellt und man braucht dann keine Separatoren. Aber für die Ein- und Ausgabe der Daten in und aus der ArrayList muss eine Conversion gemacht werden. Aber Konversionen haben ihre Eigenheiten.		The program has the same functions as those on this page , but is written in Visual BASIC 2015. Here one can see the differencies in writing style and in the data- structures and compare. The program is finished and for conversion of its own code for display it gets 452 kByte from Publisher and reduces it to the size of 189 kByte and reduction of consecutive same color TAGs reduces more to 162 kByte. And this is appropriate to be implemented into other Website-Code. Here is tested a technique of the ArrayList. The code must be processed linewise , that no <BR>-s can get into the TAGs. So the ArrayList must hold a different number of elements per line, whereby the processing of the text-elements is done in the format List(of String), which has a sufficient number of methods and one needs no separators. But for the in- and output of data in and out from the ArrayList ist must be made a conversion. But the conversions have their mannerisms.
	Das Programm ist getestet vor der Publikation, aber es kann keine Garantie gegeben werden, dass es fehlerfrei ist		The program ist tested before publication, but there can be given no guarantee, that it is free of errors

	25. Sept. 2016		Sept 25^th 2016

Picture of the New Form (User-Surface)
the picture is downsized to 70% versus the real size
the program is much tested and finished

Form

Msg in TextBox after Program-running

Program
for conversion from HTML-format, exported from publisher, to own HTML-format
Program in the finishing-phase

' Program in VB 2015, Start on July 21st 2016, Finished on Sept 18th 2016
' ====================================================================================================
Public Class Form1
 Public PGM As New Program
 Private SCM As New SourceCodeMarkers
 Private TGP As New TAGprocs
 Private CHC As New ConvertHTMLcode

 Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
 Me.CenterToScreen()
 End Sub
 Private Sub TextBox1_TextChanged(sender As Object, e As EventArgs) Handles TextBox1.TextChanged
 End Sub
 Private Sub Label4_Click(sender As Object, e As EventArgs) Handles Label4.Click
 End Sub

 Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
 Lb(False) : But(False) : PGM.Main(1) : But(True) : Lb(True)
 End Sub
 Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
 TBox.Text = "" : BrkErrMsg.Clear() : Report.Clear()
 Lb(False) : But(False) : PGM.Main(2) : Lb(True)
 End Sub

 Private Sub ListBox1_SelectedIndexChanged(sender As Object,
 e As EventArgs) Handles ListBox1.SelectedIndexChanged
 ItemSelected = ListBox1.SelectedItem
 TBox.Text = "Wait until Browser-Window opens"
 But(False) : Lb(False) : PGM.Main(3) : But(True)
 End Sub

 Private Sub But(enabl As Boolean)
 Button1.Enabled = enabl : Button2.Enabled = enabl : Button3.Enabled = enabl
 End Sub
 Private Sub Lb(visible As Boolean)
 If visible Then ListBox1.Show() : Label4.Show() Else Label4.Hide() : ListBox1.Hide()
 End Sub
End Class
' ====================================================================================================
Module BasicConstituents
 Public LoS0 As New List(Of String)
 Public fSys As Object = My.Computer.FileSystem
 Public TBox As System.Windows.Forms.TextBox = Form1.TextBox1
 Public Diag As New Diags
 Private CHC As New ConvertHTMLcode
 ' needed here for DisplayResult if BrkErrMsg
 Public Const RD = 1, WR = 2, CR0 = vbNullChar, PgmInTest = False
 Public BrkErrMsg, Report, aMarkers, aTAGs, mLines As New List(Of String)
 Public aTAGsCmt, aMarkersCode, aMarkersDate, aTitles, aErrTxt As String()
 Public ItemSelected, mmDeEn(1, 11) As String
 Public MainFinished As Boolean

 Public Txt = New With
 {.SingleLine = "", .List = Nothing, .Cmp = CompareMethod.Text,
 .HTML = New With
 {.WebSite = LoS0, .In = LoS0, .Out = LoS0, .Neu = LoS0}}
 Public fSuffix = New With
 {.TABsReplaced = ".TABsReplaced",
 .Output = ".Output"}
 Public Path = New With
 {.Current = fSys.CurrentDirectory,
 .MyDocs = fSys.SpecialDirectories.MyDocuments,
 .Publisher = BPth(.WORKS, "YourSubPath1\"),
 .Script = BPth(.Publisher, "YourSubPath2\"),
 .HTMLpub = BPth(.Publisher, "YourSubPath3\"),
 .Websites = BPth(.WORKS, "YourSubPath4\"),
 .Dest = Nothing}
 Public fSpec = New With
 {.HTMLIn = "", .HTMLOut = "",
 .Website = "", .DestTmp = "",
 .In = "", .Out = "", .Tmp = BPth(Path.Current, "Tmp.txt")}
 Public Months = New With
 {.De = "Jänner,Feber,März,Apr.,Mai,Juni,Juli,Aug.,Sept.,Okt.,Nov.,Dez.",
 .En = "Jan,Feb,Mar,Apr,May,June,July,Aug,Sept,Oct,Nov,Dec"}

 ' Constants and Variables Definitions after Classes
 Public Const numerics = "0123456789"
 Public Const HTMLSpecChrs = "<>&""§äöüÄÖÜß;lt;gt;amp;quot;sect;auml;ouml;uuml;Auml;Ouml;Uuml;szlig"

 Public Const Titles = "ScriptFile,SourceFile,DestFile" ' On FileSelectWindows
 Public Const ErrTxt = "BreakOff by the user"

 Public Const sTAG01 = ""
 Public Const sTAG02 = "" : Public sTAG0 = sTAG01
 Public Const sTAG1 = "", sTAG2 = "", sTAGc1 = ""

 Public Const TAGsCmt = ""
 Public Const Markers = "Start,End, of Source-Code# ;ge,en,Date "
 ' aMarkersCode = ""
 ' aMarkersDate = ""

 Public Const TAGs = "!--,span,table"

 Sub New()
 SetupArrayStyleOfVariables()
 End Sub

 ' Setup Procedures
 Private Sub SetupArrayStyleOfVariables()
 Dim CD, A, mmDe, mmEn As String()
 SetupMarkers()
 SetupTAGs()
 mmDe = Months.De.Split(",") : mmEn = Months.En.Split(",")
 For i = 0 To 11 : mmDeEn(0, i) = mmDe(i) : mmDeEn(1, i) = mmEn(i) : Next
 aTAGsCmt = TAGsCmt.Split(",") : CD = Markers.Split(";")
 With CHC
 A = CD(0).Split(",") : aMarkersCode = { .enTAG(A(0) & A(2)), .enTAG(A(1) & A(2))}
 A = CD(1).Split(",") : aMarkersDate = { .enTAG(A(2) & A(0)), .enTAG(A(2) & A(1))}
 End With
 aTitles = Titles.Split(",")
 aErrTxt = ErrTxt.Split(",")
 End Sub
 Private Sub SetupMarkers()
 Dim mTmp As String() = Markers.Split(";"), m3 As String()
 For i = 0 To 1 : m3 = mTmp(i).Split(",")
 For j = 0 To 1 : aMarkers.Add(Replace(m3(2), "*", m3(j)))
 Next
 Next
 End Sub
 Private Sub SetupTAGs()
 Dim m3 As String() = TAGs.Split(","), tmp As String
 For i = 0 To 2 : tmp = "<" & m3(i)
 If i = 0 Then aTAGs.Add(tmp & " ") : tmp = " " & Mid(tmp, 3)
 If i > 0 Then aTAGs.Add(tmp) : tmp = "</" & Mid(tmp, 2)
 aTAGs.Add(tmp & ">")
 Next
 End Sub

 ' String Procedures
 Public Function IsNumber(xStrg As String) As Boolean
 For Each Cr As String In xStrg.ToCharArray
 If InStr(numerics, Cr) = 0 Then Return False
 Next : Return True
 End Function
 Public Function SubStrg(xStr As String, x1 As Integer, x2 As Integer) As String
 If x1 < 1 Then x1 = 1
 If x2 > Len(xStr) Then x2 = Len(xStr)
 If x2 < x1 Then Return ""
 Return xStr.Substring(x1, x2 - x1 + 1) 'Return Mid(xStr, x1, x2 - x1 + 1)
 End Function
 Public Function Substitute(xStr As String, x1 As Integer, x2 As Integer, iStr As String) As String
 Return Insert(Remove(xStr, x1, x2 - x1 + 1), x1, iStr)
 End Function
 Public Function Remove(xStr As String, x1 As Integer, xd As Integer) As String
 If x1 < 1 Or x1 > Len(xStr) Or xd < 1 Or (x1 + xd - 1) > Len(xStr) Then Return xStr
 Return Left(xStr, x1 - 1) & Mid(xStr, x1 + xd)
 End Function
 Public Function Insert(xStr As String, x1 As Integer, iStr As String) As String
 If x1 < 1 Or x1 > (Len(xStr) + 1) Then Return xStr
 Return Left(xStr, x1 - 1) & iStr & Mid(xStr, x1)
 End Function
 Public Function enBl(xStrg As String) As String
 Return " " & xStrg & " "
 End Function
 Public Function Accent(xStrg As String) As String
 Dim s As String = StrDup(5, "-") : Return Constants.vbCrLf & s & enBl(xStrg) & s
 End Function
 Public Function qo(xLine As String) As String
 Return """" & xLine & """"
 End Function

 ' List Procedures
 Public Function Ubd(xA As Object) As Integer
 If TypeOf xA Is String() Then Return UBound(xA)
 If TypeOf xA Is Integer() Then Return UBound(xA)
 If TypeOf xA Is Single() Then Return UBound(xA)
 If TypeOf xA Is Double() Then Return UBound(xA)
 If TypeOf xA Is List(Of String) Then Return xA.count - 1
 If TypeOf xA Is List(Of Integer) Then Return xA.count - 1
 If TypeOf xA Is Object Then Return xA.count - 1
 Return -1
 End Function
 Public Sub NL(ByRef xLofS As List(Of String))
 xLofS.Add("")
 End Sub
 Public Function aON(xLofS As List(Of String)) As Boolean
 Return xLofS.Count > 0
 End Function
 Public Function aOFF(xLofS As List(Of String)) As Boolean
 Return Not aON(xLofS)
 End Function
 Public Function CLofS(xVar As Object) As List(Of String)
 Dim A As New List(Of String) ' Converts Strings and LofS in LofS like my earlier PUSH did
 If TypeOf xVar Is List(Of String) Then A.AddRange(xVar)
 If TypeOf xVar Is String() Then A.AddRange(xVar)
 If TypeOf xVar Is String Then A.Add(xVar)
 If TypeOf xVar Is Integer Then A.Add(CStr(xVar))
 Return A
 End Function
 Public Function ConvArrToLofS(xArr As ArrayList) As List(Of String)
 Dim A As New List(Of String)
 For Each Line In xArr : A.AddRange(Line)
 Next : Return A
 End Function
 Public Function GetListSize(xList As Object) As Integer
 Dim LofS As New List(Of String) : LofS.AddRange(CLofS(xList))
 Dim size As Integer = 0 : For Each Line In LofS : size += Len(Line) : Next
 Return size
 End Function
 Public Function CVals(ByVal xArr As String()) As List(Of Integer)
 Dim A As New List(Of Integer)
 For i = 0 To Ubd(xArr) : A.Add(Val(xArr(i))) : Next : Return A
 End Function

 ' Path Procedures
 Public Function BPth(xPath As String, xFile As String) As String
 Return IO.Path.Combine(xPath, xFile)
 End Function

 ' Folder Procedures
 Public Function FoP(xfSpec As String) As String ' Parentfolder
 Return IO.Directory.GetParent(xfSpec).ToString
 End Function ' Parentfolder

 ' File Procedures
 Public Function FiN(xfSpec) As String
 Return IO.Path.GetFileName(xfSpec)
 End Function ' returns Filename
 Public Function FiE(xfSpec As String) As Boolean
 If xfSpec <> "" Then Return fSys.FileExists(xfSpec) Else Return False
 End Function ' File Exists
 Public Function FiB(xfSpec As String) As String
 Return IO.Path.GetFileNameWithoutExtension(xfSpec)
 End Function ' returns Basename
 Public Function FiExt(xfSpec As String) As String
 Return IO.Path.GetExtension(xfSpec)
 End Function ' returns FileExtension with dot, for example: ".txt"
 Public Sub FiD(xfSpec As String)
 If FiE(xfSpec) Then fSys.DeleteFile(xfSpec)
 End Sub ' Delete File
 Public Function GetfSpecOut(xfSuffix As String, xfSpec As String) As String
 Return BPth(FoP(xfSpec), FiB(xfSpec) & xfSuffix & FiExt(xfSpec))
 End Function

 ' Display Procedures
 ' in TextBox
 Public Sub SendReport(xVar As Object, xTitle As String)
 If xTitle <> "" Then Report.Add(Accent(xTitle))
 Report.Add(String.Join(Constants.vbCrLf, CLofS(xVar)))
 End Sub
 Public Sub SendReportFromTAGreduction(Pgm As String, xCtr As Integer,
 ReducedNr As Integer, xTxt As List(Of String))
 Dim Msg As New List(Of String), Bytes, dBytes, p As Integer, R As String = ""
 Dim MsgTxt As String() = {
 "SameColTAGs", "Nr Of ConsecutiveSameColorTAGs Removed: ",
 "BlanksInSpan", "Bytes Saved for blanks in Span-TAGs: ",
 "ReduceSameColorTAGs", "Bytes Saved for TAGreduction: "}
 Bytes = GetListSize(xTxt)
 Select Case Pgm
 Case MsgTxt(0) : Msg.Add(MsgTxt(1)) : dBytes = Bytes - ReducedNr
 Case MsgTxt(2) : Msg.Add(MsgTxt(3)) : dBytes = ReducedNr
 Case MsgTxt(4) : Msg.Add(MsgTxt(5)) : dBytes = ReducedNr
 End Select : Msg.AddRange({" items = ", ", Nr of Bytes = ", " of Total = ", " ( ", " %)"})
 p = 100 * dBytes \ Bytes
 For i = 0 To Msg.Count - 1
 R &= Msg(i) & {"", CStr(xCtr), CStr(dBytes), CStr(Bytes), CStr(p), ""}(i)
 Next : Report.Add(R)
 End Sub
 Public Sub SendInterim(ByVal xVar As Object, ByVal xTitle As String)
 Select Case xTitle
 Case "Txt.HTML.In", "Txt.HTML.Out"
 Case Else : If Not PgmInTest Then Exit Sub
 End Select : Dim Mode As String = "Notepad" ' TBox, Notepad
 Dim Lines As New List(Of String)
 Dim s, Line, item, OmittedLinesMsg As String
 Dim xMax, yMax, c As Integer : xMax = 110 : yMax = 48 : c = 0
 OmittedLinesMsg = StrDup(20, ":") & " lines omitted"
 If TypeOf xVar Is ArrayList Then
 For i = 0 To xVar.Count - 1 : Line = ""
 For Each item In xVar(i) : If c Mod 3 = 2 Then s = "|" Else s = Chr(166)
 Line &= item & s : c += 1
 Next : Lines.Add(Line)
 Next
 Else : Lines.AddRange(CLofS(xVar))
 End If : If Mode = "TBox" Then Lines = LimitTxt(xMax, yMax, Lines, OmittedLinesMsg)
 Lines = ShowInvisible(Lines, OmittedLinesMsg) ' OmittedLinesMsg excluded
 If Mode = "TBox" Then
 TBox.Text = String.Join(Constants.vbCrLf, Lines) : MsgBox("continue")
 ElseIf Mode = "Notepad" Then
 DisplayMsg(Lines, fSpec.Tmp, xTitle)
 End If
 End Sub
 Private Function LimitTxt(ByVal xMax As Integer, ByVal yMax As Integer, ByVal xTxt As List(Of String),
 OmittedLinesMsg As String) As List(Of String)
 Dim Txt As New List(Of String), Cx, Cy As Integer
 Dim s As String = Replace(" .... ", " ", Chr(160))
 Cx = (xMax - Len(s)) \ 2 : Cy = xTxt.Count
 If Cy > yMax Then xTxt.RemoveRange(yMax \ 2 + 1, Cy - yMax)
 For Each Line In xTxt
 If Len(Line) > xMax Then Line = Left(Line, Cx) & s & Right(Line, Cx)
 Txt.Add(Line)
 Next : If Cy > yMax Then Txt.Item(yMax \ 2) = OmittedLinesMsg
 Return Txt
 End Function
 Private Function ShowInvisible(ByVal xTxt As List(Of String),
 OmittedLinesMsg As String) As List(Of String)
 Dim Txt As New List(Of String), c As Byte
 For Each Line In xTxt
 If Line <> OmittedLinesMsg Then
 Line = Line.Replace(" ", Chr(176)).Replace(Chr(160), " ") ' replace blanks
 For i = 0 To 31
 Select Case i
 Case 10 : c = 172
 Case 13 : c = 169
 Case Else : c = 154
 End Select : Line = Line.Replace(Chr(i), Chr(c))
 Next : Line &= Chr(182) ' mark end of line
 End If : Txt.Add(Line)
 Next : Return Txt
 End Function
 Public Sub DisplayDate(OldDate, NewDate, lg)
 Dim r As String = " Date" & aMarkersDate(lg) & ": "
 Report.Add("old" & r & OldDate) : Report.Add("new" & r & NewDate)
 End Sub
 Public Sub DisplayPgmResult()
 Dim A As New List(Of String), Txt As String()
 Dim Msg As String() = {
 "Break Error", "Job done", "To Select from Menu",
 "fSpec.HTMLIn: ", "fSpec.Website: ", " HTML-Text chosen"}
 For i As Byte = 0 To 1 : Msg(i) = Accent(Msg(i)) : Next
 Do : If BrkErrMsg.Count > 0 Then A = BrkErrMsg : A.Insert(0, Msg(0)) : Exit Do
 If MainFinished Then
 Txt = {Msg(3) & qo(FiN(fSpec.HTMLIn)), Msg(4) & qo(FiN(fSpec.Website))}
 SendReport(String.Join(Constants.vbCrLf, Txt), Msg(5))
 A = Report : A.Add(Msg(1))
 Else : A = Report : A.Add(Msg(2))
 End If
 Loop Until True : TBox.Text = String.Join(Constants.vbCrLf, A)
 End Sub
 ' in Browser
 Public Sub DisplayNewDestPage(xTxt As List(Of String), xOrder As String)
 Select Case LCase(xOrder)
 Case "before"
 TBox.Text = "Wait until Browser Window appears"
 Path.Dest = FoP(fSpec.WebSite)
 fSpec.DestTmp = BPth(Path.Dest, "Tmp.htm")
 RDWRfile(WR, xTxt, fSpec.DestTmp)
 DisplayHTMLfile(fSpec.DestTmp)
 TBox.Text = "Wait until Msgbox appears"
 FiD(fSpec.DestTmp)
 Case "after" : DisplayHTMLfile(fSpec.WebSite)
 End Select
 End Sub
 Public Sub DisplayHTMLfile(xfSpec As String)
 Process.Start(xfSpec).WaitForExit()
 End Sub
 ' in Notepad
 Public Sub DisplayMsg(xArr, xfSpec, Title)
 If Not aON(xArr) Then Exit Sub
 RDWRfile(WR, enTitleMsg(xArr, Title), xfSpec)
 Process.Start("notepad.exe", xfSpec).WaitForExit()
 End Sub
 Public Function enTitleMsg(ByVal xLofS, ByVal Title) As List(Of String)
 If Title = "" Then Return xLofS
 Dim sd = StrDup(10, "="), T = enBl(Title) & sd
 Dim LofS As List(Of String) = CLofS({"", sd & T, sd & " End Of" & T})
 LofS.InsertRange(2, xLofS) : Return LofS
 End Function

 ' Harddisk Procedures
 Public Sub RDWRfile(ByVal Dir As Byte, ByRef xLofS As List(Of String), ByVal xfSpec As String)
 If xfSpec = "" Then Exit Sub
 Dim fSpec As New IO.FileInfo(xfSpec)
 Dim fe = fSpec.Exists, de = IO.Directory.Exists(fSpec.DirectoryName)
 If Dir = RD Then
 If Not fe Then Exit Sub
 Dim LofS As New List(Of String)
 Using fs As IO.FileStream = fSpec.Open(IO.FileMode.Open, IO.FileAccess.Read)
 Using sr As New IO.StreamReader(fs, System.Text.Encoding.Default)
 ' System.Text.Encoding.Default is needed for modified vowels
 Do While Not sr.EndOfStream : LofS.Add(sr.ReadLine) : Loop
 End Using
 End Using : xLofS = LofS
 ElseIf Dir = WR Then
 ' WriteLine makes after each Line a Linefeed, so that after the last line
 ' there is an empty line added, that cannot bei tolerated
 ' therefor the last line is made by Write
 ' if the List is empty, it must be avoided an error break
 ' xLofS needed to stay unchanged for further use
 If xLofS.Count < 1 Then Exit Sub
 If Not de Then fSpec.Directory.Create() Else If fe Then fSpec.Delete()
 Using fs As IO.FileStream = fSpec.Open(IO.FileMode.OpenOrCreate, IO.FileAccess.Write)
 Using sw As New IO.StreamWriter(fs, System.Text.Encoding.Default)
 ' System.Text.Encoding.Default is needed for modified vowels
 For Each s In xLofS.GetRange(0, xLofS.Count - 1) : sw.WriteLine(s) : Next
 sw.Write(xLofS.Last) : sw.Flush() ' Flush moves the stream buffer into the file
 End Using
 End Using
 End If
 End Sub
End Module
' ====================================================================================================
Public Class Program
 Private CHC As New ConvertHTMLcode
 Private RTB As New ReplaceTABsByBlanks

 Public Sub Main(PgmNr As Byte)
 Select Case PgmNr
 Case 1 : RTB.Main() ' Replace Tabs by blank
 Case 2 : CHC.Main("GetCode") ' Convert HTML code
 Case 3 : CHC.Main("PutCode") ' Insert Code into Page
 End Select : DisplayPgmResult()
 End Sub
End Class
' ====================================================================================================
Public Class ReplaceTABsByBlanks
 Public Sub Main()
 Dim A = LoS0, fSpec As String = ""
 ' Get Code from Source
 If Not Diag.GetFileSelected(fSpec, 1) Then Exit Sub
 RDWRfile(RD, Txt.HTML, fSpec)
 A.AddRange(Txt.HTML)
 SendInterim(A, "vbScript")
 ReplaceTabs(A)
 SendInterim(A, "TABreplaced")
 RDWRfile(WR, A, GetfSpecOut(fSpec))
 End Sub

 Private Sub ReplaceTabs(ByRef aTxt As List(Of String))
 Dim i, s : If Not aON(aTxt) Then Exit Sub
 ' 5,9,13, .... 1-4 -> 5 5-8 -> 9
 ' space(4-((i-1) Mod 4))
 For LineNr = 0 To aTxt.Count - 1 : i = 1
 Do : i = InStr(i, aTxt(LineNr), vbTab) : If i = 0 Then Exit Do
 s = Space(4 - ((i - 1) Mod 4))
 aTxt(LineNr) = Substitute(aTxt(LineNr), i, i, s)
 i += Len(s) - 1
 Loop
 Next
 End Sub
 Private Function GetfSpecOut(xfSpec)
 Dim fBase = FiB(xfSpec), fExt = FiExt(xfSpec)
 Return BPth(FoP(xfSpec), fBase & fSuffix.TABsReplaced & fExt)
 End Function
End Class
' ====================================================================================================
Public Class ConvertHTMLcode
 Private DTN As New DateToNow
 Private SCM As New SourceCodeMarkers
 Private TGP As New TAGprocs
 Private TGon() As Boolean = {False, False, False, False}

 Public Sub Main(Mode As String)
 If Mode = "GetCode" Then ' Get Code from Source
 With Txt.HTML
 If Not Diag.GetFileSelected(fSpec.HTMLIn, 2) Then Exit Sub
 RDWRfile(RD, .In, fSpec.HTMLIn) : SendInterim(.In, "Txt.HTML.In")
 If Not GetTextInTable(.In) Then Exit Sub
 ' ===================================
 ' Lineup Text to single line
 Txt.SingleLine = GetSingleLineFromHTMLtxt(.In) ' Removes vbCrLfs correctly, UCase(" ")
 RemoveUnwantedCode(Txt.SingleLine) ' f.i. 
 TGP.ReplaceBlanks(Txt.SingleLine)
 ' ===================================
 ' ConvertTxt(Txt.SingleLine) To List
 With TGP
 Txt.List = .ExtractPTAGs(Txt.SingleLine)
 Txt.List = .GetAllSpanTAGs(Txt.List)
 .ReduceSameColorTAGs(Txt.List)
 End With
 .Out = TGP.ReplaceBlanksToNbsps(Txt.List)
 .Out = FontFormatText("Add", .Out) ' Reports Nr of Lines
 RDWRfile(WR, .Out, GetfSpecOut(fSuffix.Output, fSpec.HTMLIn))
 SendInterim(.Out, "Txt.HTML.Out")
 ' Get Code from Destination
 If Not Diag.GetFileSelected(fSpec.Website, 3) Then Exit Sub
 RDWRfile(RD, .WebSite, fSpec.Website)
 If Not SCM.GetAllMarkers(.WebSite) Then Exit Sub ' Gets MenuItems
 If Not SCM.CallMenu Then Exit Sub ' Call Menu end exit if BrkErr
 ' Sub Main End and thereafter Control is in Listbox
 End With
 ElseIf Mode = "PutCode" Then ' Put Code into Destination
 With Txt.HTML
 Report.Add("Menu Selected: " & ItemSelected)
 MainFinished = True : If ItemSelected = "" Then Exit Sub
 If Not InsertCodeBetweenMarkers(.Neu, .WebSite,
 GetCodeLines(ItemSelected), .Out) Then Exit Sub
 DTN.InsertDate(.Neu)
 DisplayNewDestPage(.Neu, "before") ' BeforeOverwrite
 If Not GetOKforOverwritePage() Then Exit Sub
 OverwriteOldDestPage(.Neu, fSpec.WebSite)
 DisplayNewDestPage(.Neu, "after") ' AfterOverwrite
 End With
 End If
 End Sub

 ' Subs for Main
 Private Function GetTextInTable(ByRef xTxt As List(Of String)) As Boolean
 ' <table ...><tr...><td ...><div...> this is always produced by the publisher
 Dim TGson, ToAdd As Boolean, A As New List(Of String)
 Dim TG As New List(Of Array), TGname As String() = {"table", "tr", "td", "div"}
 For Each T In TGname : TG.Add({"<" & T & " ", "<" & T & ">", "</" & T & ">"})
 Next : ToAdd = False ' TG(name)(part)
 For Each Line As String In xTxt : Line = Trim(Line)
 TGson = OnFlags(TG, Line)
 If Not TGson Then ToAdd = False
 If ToAdd Then A.Add(Line)
 If TGson Then ToAdd = True
 Next : xTxt = A : If A.Count > 0 Then Return True
 BrkErrMsg.Add("no table in text or no text in table") : Return False
 End Function
 Private Function OnFlags(aTG As List(Of Array), xLine As String) As Boolean
 Dim i As Integer ' div can come before table as part of body
 For n = 0 To 3 And TGon(0) : i = InStr(xLine, aTG(n)(0))
 If i = 0 Then i = InStr(xLine, aTG(n)(1))
 If i > 0 Then TGon(n) = True : Exit For
 If InStr(xLine, aTG(n)(2)) = 0 Then Continue For
 TGon(n) = False : Exit For
 Next : For i = 0 To 3 : If Not TGon(i) Then Return False
 Next : Return True
 End Function

 Private Function GetSingleLineFromHTMLtxt(ByVal xTxt As List(Of String)) As String
 Dim OneLine As String = String.Join(Constants.vbCrLf, xTxt), A As New List(Of Array)
 A.Add({">" & Constants.vbCrLf & "<", Constants.vbCrLf, " "})
 A.Add({"><", " ", " "})
 For c = 0 To 2 : OneLine = Replace(OneLine, A(0)(c), A(1)(c),,, Txt.Cmp)
 Next : Return OneLine
 End Function
 Private Sub RemoveUnwantedCode(ByRef xOneLine As String)
 ' = Schreibrichtung vom Text
 xOneLine = Replace(xOneLine, "", "",,, Txt.Cmp)
 End Sub
 Private Function FontFormatText(Mode As String,
 ByVal xTxt As List(Of String)) As List(Of String)
 If Not (Mode = "Add" Or Mode = "Replace") Then Return xTxt
 Dim A As List(Of String) = xTxt ' RemoveAt is zero-based
 If Mode = "Replace" Then A.RemoveAt(0) : A.RemoveAt(A.Count - 1)
 A.Item(0) = sTAG0 & A.First ' item is zero-based
 A.Item(xTxt.Count - 1) = A.Last & sTAG2
 Report.Add("Nr of Lines of HTML-Text: " & CStr(A.Count)) : Return A
 End Function

 Private Function GetCodeLines(ItemSelected) As List(Of Integer)
 Dim p As New List(Of Integer) : p.AddRange({-1, -1})
 Dim index As Integer = SCM.MenuItems.IndexOf(ItemSelected)
 Dim MI As New List(Of String) : MI.AddRange(SCM.MarkersInfo(index).Split(", "))
 If MI.Count = 3 Then p.Clear() Else Return p
 For i = 1 To 2 : p.Add(CInt(Val(MI(i)))) : Next
 ItemSelected = "" ' for Display after end of sub
 Return p
 End Function
 Public Function InsertCodeBetweenMarkers(ByRef aTextOut As List(Of String),
 ByVal aTextIn As List(Of String),
 ByVal aCodeLines As List(Of Integer),
 ByVal Code As List(Of String)) As Boolean
 Dim A As New List(Of String), p As List(Of Integer) = aCodeLines, LineNr As Integer = -1
 Do : aTextOut.Clear() : If aTextIn.Count < 1 Then Exit Do
 If p.Count <> 2 Then Exit Do
 If p(0) = -1 Or p(1) = -1 Then Exit Do
 Do : LineNr += 1 ' Insert Code between Markers
 If LineNr = p(0) Then
 A.Add(aTextIn(LineNr))
 NL(A) : A.AddRange(Code) : NL(A) : LineNr = p(1) ' String.Join("", Code)
 End If : A.Add(aTextIn(LineNr))
 Loop Until LineNr = aTextIn.Count - 1 : If aON(A) Then aTextOut = A : Return True
 Loop Until True : BrkErrMsg.Add("no code converted") : Return False
 End Function
 Private Function GetOKforOverwritePage() As Boolean
 Return MsgBox("Is Conversion OK ? on " & qo(FiN(fSpec.Website)),
 vbYesNo, "Insert Code And Save") = vbYes
 ' qo(FiN(fSpec.Website))
 ' MsgBox(msg, style, title)
 End Function
 Private Sub OverwriteOldDestPage(xTxt As List(Of String), xfSpec As String)
 RDWRfile(WR, xTxt, xfSpec) : Report.Add("New File saved")
 End Sub

 Public Function enTAG(xTxt As String) As String
 Return aTAGsCmt(0) & xTxt & aTAGsCmt(1) : End Function
End Class
' ====================================================================================================
Public Class TAGprocs
 Public AofElmts As New ArrayList
 Private AofElmtsNew As New ArrayList ' is needed for Function JoinLofElmts
 Private LofElmts As New List(Of String)
 Private sp As String() = {"span", "", "<span*>",
 " style='color:", "", ""}

 Public Function ExtractPTAGs(ByVal xLine As String) As List(Of String)
 Dim LofS As New List(Of String), Rest As String = Trim(xLine)
 Do : If Get1stTAGparams("p", xLine, Rest) Then LofS.Add(xLine) Else Exit Do
 Loop Until Rest = "" : SendInterim(LofS, "ExtractPTAGs") : Return LofS
 End Function

 Public Function GetAllSpanTAGs(xTxt As List(Of String)) As List(Of String)
 Dim TAGlist, LineTAGs, LineElmts As New List(Of String)
 Dim aTG(2), Te, Rest, buf, Line As String
 Dim SavedBytes, sBytes, NrOfEvents As Integer
 Rest = "" : SavedBytes = 0 : NrOfEvents = 0
 For Each Line In xTxt : Rest = Line : buf = ""
 LineTAGs.Clear() : LineElmts.Clear()
 Do : If Not Get1stTAGparams("span", aTG, Rest) Then Exit Do
 Te = JoinTAGelmts(sBytes, aTG)
 If Te = " " Then
 buf += Te : LineElmts.AddRange({aTG(2), "", ""})
 ElseIf Te.Replace(" ", "").Replace(" ", "") = "" Then
 LineTAGs.Add(Te) : LineElmts.AddRange({aTG(2), "", ""})
 Else : LineTAGs.Add(buf & Te) : buf = "" : LineElmts.AddRange(aTG)
 End If : SavedBytes += sBytes : If sBytes > 0 Then NrOfEvents += 1
 Loop : Line = String.Join("", LineTAGs) & buf
 Line = Line.Replace(" ", CR0 & " ")
 TAGlist.AddRange(Split(Line, CR0)) : AofElmts.Add(LineElmts.ToArray)
 Next : RemoveEmptyLines(TAGlist)
 PutSingleBRsToNextLine(TAGlist)
 SendReportFromTAGreduction("BlanksInSpan", NrOfEvents, SavedBytes, xTxt)
 SendInterim(TAGlist, "GetAllSpanTAGs") : Return TAGlist
 End Function
 Private Function Get1stTAGparams(ByVal xT As String, ByRef xLineOrTG As Object,
 ByRef Rest As String) As Boolean
 ' to feed in Line the first time into Rest if function called in loop
 If Not (xT = "p" Or xT = "span") Then Return False
 Dim pNOTspan As Boolean = xT = "p"
 Dim PreTxt, s, col, Line As String, PT, TCR, CR, TA As String()
 PreTxt = "" : s = "" : col = "" : Line = Rest : Rest = ""
 If pNOTspan Then xLineOrTG = Line Else xLineOrTG = {Line}
 If Line = "" Then Return False
 If pNOTspan Then PreTxt = Filter1stBRs(Line)
 Do : Do : PT = Split(Line, "<", 2) : If PT.Count <> 2 Then Return False
 PreTxt &= PT(0) : TCR = Split(PT(1), ">", 2)
 If TCR.Count <> 2 Then Return False
 TA = Split(TCR(0), xT, 2, Txt.Cmp) : If TA.Count = 2 Then Exit Do
 PreTxt &= PT(0) & "<" & TCR(0) & ">" : Line = TCR(1)
 Loop : Line = TCR(1) : If Not pNOTspan Then col = GetCol(Trim(TA(1)))
 CR = Split(Line, "</" & xT & ">", 2, Txt.Cmp)
 If CR.Count <> 2 Then PreTxt &= CR(0) Else Exit Do
 Loop : If pNOTspan Then xLineOrTG = PreTxt & CR(0) : Rest = " " & CR(1)
 ' exports for False: xLine, ""
 ' exports for True: PreTxt & Content, Rest
 If Not pNOTspan Then xLineOrTG = {PreTxt, col, CR(0)} : Rest = CR(1)
 ' {PreText, Color, Content}, Rest
 Return True
 End Function
 Private Function JoinTAGelmts(ByRef SavedBytes As Integer, ByVal aTG As String()) As String
 Dim TGtxt, s As String : SavedBytes = 0
 ' aTG = {PreText, Color, Content} or {PreText, Color, } or {Rest}
 Select Case aTG.Count
 Case 1 : AddToLofElmts(aTG(0)) : Return aTG(0)
 Case 3 : s = Trim(aTG(2))
 If s.Replace(" ", "") = "" Then ' if " " within a span-TAG
 SavedBytes = Len("")
 TGtxt = aTG(2) : AddToLofElmts(TGtxt)
 ElseIf s = " " Then ' if within a span-TAG
 SavedBytes = Len("") + Len(aTG(2)) - Len(Trim(aTG(2)))
 If aTG(1) <> "" Then SavedBytes += Len(" style ='color:'") + Len(aTG(1))
 TGtxt = Trim(aTG(2)) : AddToLofElmts(TGtxt)
 Else : AddToLofElmts(aTG) : TGtxt = enColTAG(aTG(1), aTG(2))
 End If : Return aTG(0) & TGtxt
 Case Else : Return ""
 End Select ' aTG = {PreText, , Content}
 End Function
 Private Function Filter1stBRs(ByRef xLine As String) As String
 Dim A As String() = {"", Trim(xLine)}, PreTxt As String = ""
 Do : A = Split(A(1), "<", 2) : If A.Count < 2 Then xLine = A(0) : Return PreTxt
 If A(1) <> "" Then A(1) = LTrim(A(1))
 If Left(A(1), 3) <> "BR>" Then A(1) = "<" & A(1) : xLine = A(1) : Return PreTxt
 PreTxt += " " : A(1) = Mid(A(1), 4)
 Loop
 End Function
 Private Function GetCol(ByVal xAtts As String) As String
 ' lang=de style='font-size:9.5pt;line-height:119%;font-family:Consolas;color:blue;language:de'
 ' style='color:blue; font:bold;'
 If xAtts = "" Then Return ""
 Dim A, A1 As String(), att As String
 xAtts = Replace(xAtts, "STYLE", "style",, Txt.Cmp)
 A = Split(xAtts, " style") : If A.Count < 2 Then Return ""
 A = Split(Trim(A(1)), "=") : If A.Count <> 2 Then Return ""
 A = Split(Trim(A(1)), "'") : If A.Count <> 3 Then Return ""
 A = Split(Trim(A(1)), ";") : If A.Count < 1 Then Return ""
 For Each att In A : A1 = Split(Trim(att), ":")
 If A1.Count <> 2 Then Continue For
 If LCase(Trim(A1(0))) <> "color" Then Continue For
 Return Trim(A1(1))
 Next : Return ""
 End Function
 Private Sub AddToLofElmts(xElmts As Object)
 Dim A As List(Of String) = CLofS(xElmts)
 Select Case A.Count
 Case 1 : LofElmts.AddRange(A) : LofElmts.AddRange({CR0, CR0, CR0})
 Case 3 : LofElmts.AddRange(A) : LofElmts.Add("")
 End Select
 ' {PreTxt, Col, Content, ""} OR {Text, CR0, CR0, CR0}
 ' 0,1,2,3,0,1,2,3...
 ' 0,1,2,3,4,5,6,7
 End Sub

 Public Sub ReplaceBlanks(ByRef xTxt As Object) ' Replace in Strings or LofS
 Dim Lines As New List(Of String)
 For Each Line As String In CLofS(xTxt)
 For Each cc In {" ", Chr(160)} : Line = Line.Replace(cc, " ")
 Next : Lines.Add(Line)
 Next: xTxt = String.Join(Constants.vbCrLf, Lines)
 End Sub
 Public Function ReplaceBlanksToNbsps(ByVal LofS As List(Of String))
 Dim NewLine As New List(Of String)
 For Each Line In LofS : NewLine.Add(ReplaceBlanksToNbspsPerLine(Line))
 Next : Return NewLine
 End Function
 Private Function ReplaceBlanksToNbspsPerLine(ByVal xLine As String) As String
 Dim NewLine As String = "" : If Len(xLine) < 2 Then Return xLine
 For i = 1 To Len(xLine) - 1
 If Mid(xLine, i, 2) = " " Then NewLine &= " " Else NewLine &= Mid(xLine, i, 1)
 Next : Return NewLine & Right(xLine, 1)
 End Function
 Public Sub RemoveEmptyLines(ByRef xTxt As List(Of String))
 Dim i As Integer = 0
 Do While i < xTxt.Count
 If BlanksOnly(xTxt(i)) Then xTxt.RemoveAt(i) Else i += 1
 Loop
 End Sub
 Public Sub PutSingleBRsToNextLine(ByRef xTxt As List(Of String))
 Dim i, ctr As Integer, s, buf As String : i = 0 : buf = ""
 Do While i < xTxt.Count : s = Trim(xTxt(i)) : ctr = 0
 Do While Left(s, 4) = " " : ctr += 1 : s = Mid(s, 5) : Loop
 If s = "" Then
 For j = 1 To ctr : buf += " " : Next : xTxt.RemoveAt(i)
 ElseIf s.Replace(" ", " ").Replace(" ", "") = "" Then
 For j = 1 To ctr : buf += " " : Next : xTxt.RemoveAt(i)
 Else : xTxt(i) = buf & xTxt(i) : buf = "" : i += 1
 End If
 Loop
 End Sub
 Public Sub MakeNLsforBRs(ByRef xTxt As List(Of String))
 Dim A As New List(Of String)
 For Each Line In xTxt
 Line = Line.Replace(" ", CR0 & " ")
 If Left(Line, 1) = CR0 Then Line = Mid(Line, 2)
 A.AddRange(Line.Split(CR0))
 Next : xTxt = A
 End Sub

 ' ----------------- ReduceSameColorTAGs ------------------
 Public Sub ReduceSameColorTAGs(ByRef xTxt As List(Of String))
 ' 0 1 2|3 4 5|6 7 8
 ' 0 1 2|0 1 2|0 1 2
 'Exit Sub
 Dim A, TAGlist, Line, Lines As New List(Of String), Arr As String()
 Dim Elmt As String, i, ctr, NrOfItems, Bytes As Integer
 ctr = -1 : NrOfItems = 0 : Bytes = 0
 For Each Arr In AofElmts : A = CLofS(Arr) : TAGlist.Clear() : Line.Clear()
 For Each Elmt In A : ctr += 1 : TAGlist.Add(Elmt)
 If ctr Mod 3 = 2 Then TAGlist.Add("")
 Next : i = -4 : A.Clear() : A.AddRange(TAGlist)
 ' 0 1 2 3 4 5 6 7 8 9 0 1
 ' 0 1 2 3|0 1 2 3|0 1 2 3
 Do While i < A.Count - 5 : i += 4
 If Not BlanksOnly(String.Join("", A.GetRange(i, 3))) Then Continue Do
 A(i + 4) = A(i) & A(i + 2) & A(i + 4) : A.RemoveRange(i, 4) : i -= 4
 Loop
 For i = 0 To A.Count - 1 Step 4
 If BlanksOnly(A(i + 1)) Then _
 A(i + 1) = CR0 : A(i + 3) = CR0 : Continue For
 A(i + 1) = enColSpan(A(i + 1))
 Next
 For i = 4 To A.Count - 1 Step 4
 If A(i + 1) = CR0 Or A(i - 3) = CR0 Then Continue For
 If A(i + 1) = A(i - 3) Then
 NrOfItems += 1 : Bytes += Len(A(i - 1)) + Len(A(i + 1))
 A(i - 1) = CR0 : A(i + 1) = CR0
 End If
 Next : For Each Elmt In A : If Elmt <> CR0 Then Line.Add(Elmt)
 Next : Lines.Add(String.Join("", Line))
 Next : If Lines.Count > 0 Then If BlanksOnly(Lines.First) Then Lines.Remove(0)
 MakeNLsforBRs(Lines)
 PutSingleBRsToNextLine(Lines)
 SendInterim(Lines, "ReduceSameColorTAGs")
 SendReportFromTAGreduction("ReduceSameColorTAGs", NrOfItems, Bytes, xTxt)
 xTxt = Lines
 End Sub
 Private Function enColSpan(ByVal xCol As String) As String
 ' "", ""
 If xCol <> "" Then xCol = Replace(" style='color:*'", "*", xCol)
 Return Replace("<span*>", "*", xCol)
 End Function
 Private Function enTGcol(ByVal xCol As String) As String
 ' "" , ""
 If xCol = "" Then Return "" Else Return enColSpan(xCol)
 End Function
 Private Function enTGelmts(ByVal xA As List(Of String)) As String
 ' "PretxtContent", "Pretxtcontent"
 Dim A As New List(Of String) : A.AddRange(xA)
 If A(1) <> "" Then A(1) = enColSpan(A(1)) : A.Add("")
 Return String.Join("", A)
 End Function
 Private Function enColTAG(ByVal xCol As String, ByVal xContent As String) As String
 ' "Content", "Content"
 Return enColSpan(xCol) & xContent & ""
 End Function
 Public Sub TestOfReduceSameColTAGs(ByRef xTxt As List(Of String))
 Dim A, HTMLtxt As New List(Of String) : AofElmts.Clear() ' as ArrayList
 Dim AL As New ArrayList, s As String = StrDup(20, "-")

 A.Add("¦green¦'°Program°in°VB°2015,°Start°on°July°21st°2016|¶")
 A.Add(" ¦green¦'°=======================================================================|¶")
 A.Add(" ¦blue¦Public|¦¦°|¦blue¦Class|¦¦°|¦#2B91AF¦Form1|¶")
 A.Add(" ¦¦°°°°|¦blue¦Public|¦¦°PGM°|¦blue¦As|¦¦°|¦blue¦New|¦¦°|¦#2B91AF¦Program|¶")
 A.Add(" ¦¦°°°°|¦blue¦Private|¦¦°SCM°|¦blue¦As|¦¦°|¦blue¦New|¦¦°|¦#2B91AF¦SourceCodeMarkers|¶")
 A.Add(" ¦¦°°°°|¦blue¦Private|¦¦°TGP°|¦blue¦As|¦¦°|¦blue¦New|¦¦°|¦#2B91AF¦TAGprocs|¶")
 A.Add(" ¦¦°°°°|¦blue¦Private|¦¦°CHC°|¦blue¦As|¦¦°|¦blue¦New|¦¦°|¦#2B91AF¦ConvertHTMLcode|¶")
 A.Add(" ¦¦ |¶")
 For Each Line As String In A : Line = Line.Replace("|¶", "").Replace("|", "¦").Replace("°", " ")
 AofElmts.Add(Line.Split("¦").ToArray)
 Next
 AL.AddRange(AofElmts)
 A = CLofS(s & enBl("Reduced Color TAGs") & s)
 AL.Add(A.ToArray)
 ReduceSameColorTAGs(xTxt)
 'TBox.Text = String.Join(vbCrLf, xTxt)
 'SendInterim(xTxt.ToArray, "xTxt.ToArray")
 For Each Line In xTxt : A = CLofS(Line) : AL.Add(A.ToArray) : Next
 SendInterim(AL, "AofElmts")
 End Sub

 ' Common Use Procedures
 Private Function JoinLofElmts() As List(Of String)
 Dim ProcID As String = "JoinLofElmts"
 Dim AofElmtsCopy As New ArrayList() : AofElmtsCopy = AofElmts.Clone()
 Dim A, ALineNew As New List(Of String), Line, style, buf As String
 Dim ptr, ctr, NrOfEvents, SavedBytes As Integer
 Const n As Integer = 4 ' n = NrOfElements per TAG
 style = " style='color:" : buf = "" : NrOfEvents = 0 : SavedBytes = 0 : ptr = -n
 ' Remove all no-TAGs and move Text to next PreTxt
 For Each ALine As List(Of String) In AofElmtsCopy : ALineNew.Clear() : buf = ""
 Do While ALine.Count >= 4
 If DetectNoTAGtxt(ALine, n, 0) Then
 buf &= ALine(0)
 Else : ALine(0) = buf & ALine(0) : buf = ""
 ALineNew.AddRange(ALine.GetRange(0, n))
 End If : ALine.RemoveRange(0, n)
 Loop : If buf <> "" Then ALineNew.Add(buf) : buf = ""
 AofElmtsNew.Add(ALineNew)
 Next : AofElmtsCopy = AofElmtsNew.Clone() : AofElmtsNew.Clear()
 SendInterim(ConvArrToLofS(AofElmtsCopy), "Removed all no-TAGs and move Text to next PreTxt")

 ' Mark all which are to remove
 For Each ALine As List(Of String) In AofElmtsCopy : ALineNew.Clear()
 Do While Not (ALine.Count < 4) ' Mark all which are to remove
 A.Add(StrDup(40, "-")) : A.AddRange(ALine.GetRange(0, n))
 ALineNew.AddRange(ALine.GetRange(0, n)) : ALine.RemoveRange(0, n)
 If ALine.Count < 4 Then Exit Do
 If Not BlanksOnly(ALine(0)) Then Continue Do
 If ALine(1) <> ALineNew(ALineNew.Count - n + 1) Then Continue Do
 ALineNew(ALineNew.Count - 1) = CR0 : ALine(1) = CR0
 Loop : AofElmtsNew.Add(ALineNew)
 Next : AofElmtsCopy = AofElmtsNew.Clone() : AofElmtsNew.Clear()
 SendInterim(ConvArrToLofS(AofElmtsCopy), "ListMarked to remove")

 ' Remove all which are marked and send report
 For Each ALine As List(Of String) In AofElmtsCopy
 A.Clear() : ctr = -1
 For Each Elmt In ALine : ctr += 1 : If Elmt = CR0 Then Continue For
 Select Case ctr Mod n
 Case 0, 2, 3 : A.Add(Elmt)
 Case 1 : If Elmt <> "" Then Elmt = Replace(style & "*'", "*", Elmt)
 A.Add("<span" & Elmt & ">")
 End Select
 Next : AofElmtsNew.Add(A)
 Next
 SendInterim(ConvArrToLofS(AofElmtsNew), "removed marked and enstyled")
 A = ReplaceBlanksToNbsps(A)
 'RemoveEmptyLines(A)
 Line = Join(A.ToArray, "")
 Line = Line.Replace(Constants.vbCrLf, " ").Replace(" ", CR0 & Constants.vbCrLf & " ")
 A.Clear() : A.AddRange(Split(Line, CR0)) ' in Array but no CrLf
 SendInterim(A, "reformated")
 SendReportFromTAGreduction(ProcID, NrOfEvents, SavedBytes, A)
 Return A
 End Function

 Private Function BlanksOnly(ByVal xTxt As String) As Boolean
 For Each cc In {" ", " "} : xTxt = Strings.Replace(xTxt, cc, "", 1, -1, Txt.Cmp)
 Next : Return xTxt = ""
 End Function
 Private Function DetectNoTAGtxt(xLofElmts As List(Of String),
 n As Integer, xptr As Integer) As Boolean
 For i = xptr + 1 To xptr + 3 : If xLofElmts(i) <> CR0 Then Return False
 Next : Return True
 End Function
End Class
' ====================================================================================================
Public Class SourceCodeMarkers
 Private aErrTxt As String() = {"Error in Source-Code-Markers", "no markers found"}
 Private Const MenuItemPrefix As String = "Markers"
 Public MarkersInfo, MenuItems As New List(Of String)

 Public Function GetAllMarkers(xTxt As List(Of String)) As Boolean
 Dim Start_End As Integer = -1, p As New List(Of String)
 Do : If Not GetMarkersInfo(p, Start_End, xTxt) Then Exit Do
 If Not RemoveEmptyLines(p) Then Exit Do
 If SingleMarker(p) Then Exit Do
 If StartEndChanged(p) Then Exit Do
 If Overlaps(p) Then Exit Do
 GetMenuItems(p) ' from Markers
 MarkersInfo = p ' Variable
 Return True
 Loop Until True : BrkErrMsg.Insert(0, aErrTxt(0)) : Return False
 End Function
 Private Function GetMarkersInfo(ByRef p As List(Of String), ByRef Start_End As Integer,
 ByVal xTxt As List(Of String)) As Boolean
 Dim Line As String, A As String(), mON As Boolean = False
 Dim LineNr, mNr, ctr, se As Integer : LineNr = -1 : mNr = -1 : p.Clear() : Start_End = -1
 If aOFF(xTxt) Then BrkErrMsg.Add("GetMarkersInfo: no HTML-Text found") : Return False
 For Each Line In xTxt : Line = Trim(Line) : LineNr += 1 ' GetMarkers-Info
 If Not DetectMarkers(Start_End, mNr, Line) Then Continue For
 While mNr > p.Count - 1 : p.Add("") : End While ' mNr; LineNr, ctr; LineNr, ctr
 If p(mNr) = "" Then p(mNr) = CStr(mNr) & ";-1,0;-1,0"
 A = p(mNr).Split(";") : se = Start_End
 ctr = Val(A(se + 1).Split(",")(1))
 A(se + 1) = String.Join(",", {CStr(LineNr), CStr(ctr + 1)})
 p(mNr) = String.Join(";", A) : mON = True
 Next : If mON Then Return True
 BrkErrMsg.Add(aErrTxt(1)) : Return False
 End Function
 Private Function RemoveEmptyLines(ByRef aTxt As List(Of String)) As Boolean
 Dim A As New List(Of String)
 For Each Line As String In aTxt : If Line <> "" Then A.Add(Line)
 Next : aTxt = A : Return aON(A)
 End Function
 Private Function SingleMarker(ByRef aTxt As List(Of String)) As Boolean
 Dim A1, AllMs As New List(Of String), mNr, LNrs(1), ErrTxt As String
 Dim A, aTmp As String()
 For Each Line As String In aTxt : A = Line.Split(";") : AllMs.Clear() ' if occur single
 For i As Integer = 1 To 2 : aTmp = A(i).Split(",") : mNr = CVals(aTmp)(1)
 If mNr <> 1 Then
 If mNr < 1 Then ErrTxt = "missing" Else ErrTxt = "manifold (*)"
 BrkErrMsg.Add("marker " & Replace(ErrTxt, "*", CStr(mNr)))
 Return True
 End If : LNrs(i - 1) = aTmp(0)
 Next : AllMs.Add(A(0)) : AllMs.AddRange(LNrs)
 A1.Add(String.Join(",", AllMs))
 Next : aTxt = A1 : Return False
 End Function
 Private Function StartEndChanged(ByVal aTxt As List(Of String)) As Boolean
 Dim aN As New List(Of Integer)
 For Each Line As String In aTxt : aN = CVals(Line.Split(","))
 If aN(2) < aN(1) Then Return True
 Next : Return False
 End Function
 Private Function DetectMarkers(ByRef Start_End As Integer,
 ByRef mNr As Integer, ByVal xLine As String) As Boolean
 Dim A As String() = {}, Line, s As String, L As Integer
 Start_End = -1 : Line = Trim(xLine)
 ' aMarkersCode(0) = ""
 ' aMarkersCode(1) = ""
 For i = 0 To 1 : A = aMarkersCode(i).Split("#") : L = Len(A(0))
 If Left(Line, L) = A(0) Then Start_End = i : Exit For
 Next : If Start_End < 0 Then Return False
 s = Trim(Replace(Mid(Line, L + 1), aTAGsCmt(1), ""))
 If s = "0" Then Return False
 If s = "" Then s = "0"
 If IsNumber(s) Then mNr = Val(s) : Return True
 Return False
 End Function
 Private Function Overlaps(xTxt As List(Of String)) As Boolean ' Overlaps of Marker-ranges
 Dim A As List(Of String) = xTxt, aN1, aN2 As List(Of Integer)
 For i As Integer = 0 To A.Count - 1 : For j As Integer = 0 To A.Count - 1 ' if overlaps
 If i <> j Then
 aN1 = CVals(A(i).Split(",")) : aN2 = CVals(A(j).Split(","))
 If (aN1(1) > aN2(1)) And (aN1(1) < aN2(2)) Or
 (aN1(2) > aN2(1)) And (aN1(2) < aN2(2)) Then Return True
 End If
 Next : Next : Return False
 End Function
 Private Sub GetMenuItems(mInfo As List(Of String))
 Dim A As New List(Of String), mNr As String
 ' 0,1,3
 ' 1,14,16
 ' 2,10,12
 ' 3,5,7
 For Each Line In mInfo : mNr = Split(Line, ",")(0)
 If mNr = "0" Then mNr = "" Else mNr = " " & mNr
 A.Add(MenuItemPrefix & mNr)
 Next : MenuItems = A
 End Sub
 Public Function CallMenu() As Boolean
 If MenuItems.Count = 0 Then _
 BrkErrMsg.Add("no Markers found") : MainFinished = True : Return False
 With Form1
 With .ListBox1
 With .Items
 .Clear() : .AddRange(MenuItems.ToArray)
 End With : .Show()
 End With : .Label4.Show()
 End With : MainFinished = False : Return True
 End Function
End Class
' ====================================================================================================
Public Class DateToNow
 Private Dlg As String() = {"", ""}
 Private AllMasks As String() = {">#. @", ">##. @", " ####<", " ####<",
 ">@", ">@", " #<@@@>@@<@@@@> ####<", " ##<@@@>@@<@@@@> ####<"}
 Private Endings As String() = {"st", "nd", "rd"}
 Private sup As String() = {"", ""}

 Public Sub InsertDate(ByRef xTxt)
 ' aMarkersDate(#) = ""
 Dim A As New List(Of String), i, j As Integer
 Dim Mask, OldDate, NewDate, DateInfo(1, 2), aMasks(1, 3), r As String
 Dim lg As Byte = 0, DF As Boolean = False, s As String = StrDup(5, "-")
 For i = 0 To 1 : For j = 0 To 3 : aMasks(i, j) = AllMasks(4 * i + j) : Next : Next
 Report.Add(Constants.vbCrLf & s & " Date Replace " & s)
 For Each Line As String In xTxt : i = 0 : j = 0 : r = ""
 Mask = GetMaskFromLine(lg, aMasks, Dlg, Line) ' lg comes out
 Do : If Mask = "" Then A.Add(Line) : Exit Do
 GetDatePtrs(i, j, Mask, aMasks, lg)
 If i = 0 Or j = 0 Then A.Add(Line) : Exit Do
 OldDate = Line.Substring(i - 1, j - i + 1) : DF = True
 NewDate = GetDateFormatted(lg)
 A.Add(Substitute(Line, i, j, NewDate))
 DisplayDate(OldDate, NewDate, lg)
 Loop Until True
 Next : If DF Then xTxt = A : Exit Sub
 Report.Add("no date replaced")
 End Sub

 Private Function GetDateFormatted(lg As Byte) As String
 Dim Today, NewDate As String, D As String(), Dv(2) As Integer
 ' Months.De = "Jan,Feb,Mar,Apr,Mai,Jun,Jul,Aug,Sept,Okt,Nov,Dez"
 ' Months.En = "Jan,Feb,Mar,Apr,May,June,July,Aug,Sept,Oct,Nov,Dec"
 If Not (lg = 0 Or lg = 1) Then Return ""
 Today = DateAndTime.Today : D = Today.Split(".") ' Split(dd.mm.yy, ".")
 For i = 0 To 2 : Dv(i) = Val(D(i)) : D(i) = CStr(Dv(i)) : Next ' Removes leading zeros
 NewDate = mmDeEn(lg, Dv(1) - 1)
 If lg = 0 Then NewDate = D(0) & ". " & NewDate ' German
 If lg = 1 Then NewDate &= " " & D(0) & sup(0) & GetEnding(Dv(0)) & sup(1) ' English
 Return NewDate & " " & D(2)
 End Function
 Private Function GetEnding(ByVal dd As Integer) As String
 Dim d As Integer = dd Mod 10 : dd = dd \ 10
 If dd = 0 And d = 0 Then Return ""
 If dd = 1 Then Return "th"
 If d > 0 And d < 4 Then Return Endings(d - 1) Else Return "th"
 End Function
 Private Function GetMaskFromLine(ByRef lg As Byte, aMasks As String(,),
 Dlg As String(), xLine As String) As String
 Dim i, j As Integer, c, s, Mask As String
 For lg = 0 To 1 : i = InStrRev(xLine, Dlg(lg)) : Mask = ""
 If i = 0 Then Continue For
 For j = 1 To i - 1
 c = Mid(xLine, j, 1) : s = "@"
 If IsNumber(c) Then s = "#"
 If InStr(". <>", c) > 0 Then s = c
 Mask &= s
 Next : If Mask <> "" Then Return Mask
 Next : Return ""
 End Function
 Private Sub GetDatePtrs(ByRef i As Integer, ByRef j As Integer,
 Mask As String, aMasks As String(,), lg As Byte)
 Dim L As Integer
 Do : j = InStrRev(Mask, aMasks(lg, 3), -1, 1) : L = Len(aMasks(lg, 3))
 If j = 0 Then j = InStrRev(Mask, aMasks(lg, 2), -1, 1) : L = Len(aMasks(lg, 2))
 If j = 0 Then Exit Do
 i = InStrRev(Mask, aMasks(lg, 1), j, 1)
 If i = 0 Then i = InStrRev(Mask, aMasks(lg, 0), j, 1)
 If i = 0 Then Exit Do
 i += 1 : j += L - 2 : Exit Sub
 Loop Until True : i = 0 : j = 0
 End Sub
End Class
' ====================================================================================================
Public Class Diags
 ' Dialog Windows
 Public Function GetFileSelected(ByRef xfSpec As String, fNr As Byte) As Boolean
 Dim afSpec As New List(Of String) : xfSpec = ""
 Select Case fNr
 Case 1 : afSpec = FileOpen(Path.Script, "vbs")
 Case 2 : afSpec = FileOpen(Path.HTMLpub, "htm")
 Case 3 : afSpec = FileOpen(Path.Websites, "htm")
 Case Else : afSpec.Clear()
 End Select : If afSpec.Count > 0 Then xfSpec = afSpec(0) : Return True
 BrkErrMsg.Add("no file selected") : Return False
 End Function
 Public Function FileOpen(ByVal InitialPath As String, ByVal Filter As String) As List(Of String)
 Dim fPrefix As String = "all files (*.*)|*.*"
 Dim A As New List(Of String)
 If InitialPath = "" Then InitialPath = Path.MyDocs
 Select Case Filter
 Case "htm" : Filter = "|html files (*.htm*)|*.htm*"
 Case "vbs" : Filter = "|vbs files (*.vbs)|*.vbs"
 Case Else : Filter = ""
 End Select
 Dim OpenFileDialog1 As New OpenFileDialog()
 With OpenFileDialog1
 .Title = "Open the File"
 .Filter = fPrefix & Filter
 .FilterIndex = 2
 .Multiselect = False
 .RestoreDirectory = True
 .InitialDirectory = InitialPath
 If .ShowDialog() <> DialogResult.OK Then Return A
 A.AddRange(.FileNames) : Return A
 End With
 End Function
End Class