Logo Foltyn Presentation
Table of Contents Previous Page Next Page

Ein Programm in der Programmiersprache A program in the programming language
Visual BASIC 2015
Beispiele von wichtigen Programm-Funktionen Examples of important program-functions

      Mit vbScript werden Programme mit mehr als 800 Zeilen unübersichtlich und Auslagern von Code in externe Scripts, die vom Hauptprogramm aufgerufen werden, erfordern noch mehr Code als zuvor für die Übergabe von Daten.
      Daher habe ich nach 5 Jahren Pause das Programmieren mit Visual Basic wieder aufgenommen und hier sind ein paar Beispiele vom Beginn einer Bibliothek:

      In vbScript programs with more than 800 lines get confusing and outsourcing of code into external scripts, which are called by the main-program, need even more code as before for the handing over of data.
      Therefore, after a pause of 5 years, I restarted programming with Visual Basic and here are some example of the beginning of a library:

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
23. Sept 2016 Sept 23th 2016

New Writing Style for String Operations

In VB 2015 a String has become to an Object with Properties and Methods

Procedure Examples

' Code in Visual BASIC 2015
Public Class Form1
    Private OWN As New OWNsysVars
    Private PGM As New Program
    Private ControlMenuItems1 = Split("TestProcedures,OpenFile,SaveFile,BrowseFolder", ",")
Private Task
Private Const RD = 1, WR = 2

Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
' Close() ' Form close
    End Sub

 Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
End Sub

 Sub Label1_Click(sender As Object, e As EventArgs) Handles Label1.Click
End Sub

'Dialog Windows
    Private Sub DiagListboxMenu(xTsk)
Dim A = {}, Result As Array = {}, CMI = CArr(ControlMenuItems1)
With ListBox1
Select Case xTsk
Case "Init" For Each Line In CMI : .Items.Add(Line) : Next
                Case "GetChoice" For Each Line In .SelectedItems : PUSH(A, Line) : Next
                    If aON(A) Then Task = A(0) Else Task = ""
                Case "CallPgm"
                    PUSH(A, CMI)
Select Case Task
Case A(0) : PGM.TestProcedures()
Case A(1) : Result = DiagFileOpen("")
Case A(2) : DiagFileSave("", {"asdf", "jklo", "qwert"})
Case A(3) : Result = {DiagFolderBrowse()}
End Select
            End Select
        End With : DisplayInLabel1(Result)
End Sub

' Display
    Public Sub DisplayInLabel1(xVar)
Dim A = CArr(xVar) : If Not aON(A) Then Exit Sub
        Label1.Text = A(0)
End Sub
End Class
' ============================================================================================
Public Module GeneralUsedProcedures
    Private OWN As New OWNsysVars

Public Const RD = 1, WR = 2, AP = 3, ASC = 1, DSC = -1

Public Const GraficFormats = ".pcx.bmp.tif.tiff.gif.jpg.jpe.jpeg.png"
    Public Const Numerics = "0123456789"
    Public Const HexChars = "0123456789ABCDEF"
    ' HTMLSpecChrs(i) = "&" & HTMLSpecChrs(i) & ";"
    Public Const HTMLSpecChrs = "<>&""§äöüÄÖÜß;lt;gt;amp;quot;sect;auml;ouml;uuml;Auml;Ouml;Uuml;szlig"
    Public Const Chars_Prev = "([{ /*\,;:=<>+-"
    Public Const Chars_Next = ")]} /*\,;:=<>+-"
    Public Const allbracks = "()[]{}"

Public Result As Array = {}, Report As Array = {}, ErrMsg As Array = {}, BrkErrMsg As Array = {}
Public Property Chrs_Prev As Object

 Function DiagFileOpen(ByVal InitialPath As String)
If InitialPath = "" Then InitialPath = OWN.Path.MyDocs
Dim OpenFileDialog1 As New OpenFileDialog()
With OpenFileDialog1
            .Title = 
"Open the File"
            .Filter = "txt files (*.txt)|*.txt|html files (*.htm*)|*.txt"
            .FilterIndex = 2
            .Multiselect = 
            .RestoreDirectory = True
            .InitialDirectory = InitialPath
If .ShowDialog() <> DialogResult.OK Then Return {}
Return .FileNames
End With
    End Function

 Sub DiagFileSave(ByVal InitialPath As String, ByVal xArr As Array)
If InitialPath = "" Then InitialPath = OWN.Path.MyDocs
Dim SaveFileDialog1 As New SaveFileDialog()
With SaveFileDialog1
            .Filter = 
"txt files (*.txt)|*.txt|All files (*.*)|*.*"
            .FilterIndex = 2
            .RestoreDirectory = 
            .InitialDirectory = InitialPath
If .ShowDialog() <> DialogResult.OK Then Exit Sub
            RDWRfile(WR, LofA(xArr), .FileName)
End With
    End Sub

 Function DiagFolderBrowse()
Dim sPath = "", FolderBrowserDialog1 = New FolderBrowserDialog
        With FolderBrowserDialog1
            .RootFolder = 
If .ShowDialog() = DialogResult.OK Then sPath = .SelectedPath
End With Return sPath
End Function

' Array and Variant Procedures
    Public Function Ubd(xA)
Return UBound(xA) : End Function
    Public Sub PUSH(ByRef xA, ByVal xVar) ' xVar can be a String, Numeric or a Variant Array
        For Each item In CArr(xVar) : ReDim Preserve xA(Ubd(xA) + 1) : xA(Ubd(xA)) = item : Next
    End Sub
    Public Function CArr(ByRef xVar)
If Not IsArray(xVar) Then xVar = {xVar}
Return xVar
End Function
    Public Function LofA(ByRef xVar) As List(Of String)
' Returns an Array A as Object List(Of String) from
        ' an Array xVar or from a string or a chain
        ' a chain is a string "txt1,txt2,txt3"
        ' The other direction of the conversion is: Array = LofS.ToArray
        Dim As New List(Of String) : A.AddRange(CArr(xVar)) : Return A
End Function

' Files + Folders
    Public Function FiE(xfSpec)
Return My.Computer.FileSystem.FileExists(xfSpec)
End Function
    Public Sub FiD(xfSpec)
If FiE(xfSpec) Then My.Computer.FileSystem.DeleteFile(xfSpec)
End Sub
    Public Function FiB(xfSpec)
Return IO.Path.GetFileNameWithoutExtension(xfSpec)
End Function
    Public Function FiN(xfSpec)
Return IO.Path.GetFileName(xfSpec)
End Function
    Public Function BPth(xPath, xFile)
Return IO.Path.Combine(xPath, xFile)
End Function

' Display Procedures
    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, "="), T1 = sd, T = enBl(Title) & sd, T2 = T1 & " End Of" & T : T1 = T1 & T
        Dim LofS As New List(Of String)
        LofS.AddRange({"", T1, T2}) : 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 OWN As New OWNsysVars

Public Sub TestProcedures()
Dim A = OWN.ListOfSysVars()
        PUSH(A, Respond())
        DisplayMsg(A, BPth(OWN.fPath, 
"tmp.txt"), "System Variables")
End Sub
End Class
' ============================================================================================
Imports System.IO

Public Class OWNsysVars
    Public Mainboards, ComputerName, Mainboard, ScreenWidth, ScreenHeight, OS, UserName
Public Screen As Object My.Computer.Screen.Bounds.Size

' Sub New() replaces Class_Initialise in older VB-Versions
    ' and is started automaticly everytime, if the Class is
    ' instantiated in another class
    Public Sub New()
        ' ----------- System Variables -----------
        Dim fSys As Object = My.Computer.FileSystem
        ' More than one Mainboard if you have running the program on other computers
        Mainboards = "YourMainBoardName1,YourMainBoardName2,YourMainBoardName3"
        ComputerName = Environment.MachineName
        ' ComputerName is extended versus MainboardName for versions of different installations
        Mainboard = GetMainBoard()  ' as part of the computername
        OS = Split(My.Computer.Info.OSFullName, " ")(2) ' Operating System
        UserName = Environment.UserName
        ' ----------- File-Specs -----------
        With fSpec
            .Name = IO.Path.GetFileName(Application.ExecutablePath) ' (FulName)
            .Base = IO.Path.GetFileNameWithoutExtension(Application.ExecutablePath)
            .File = BPth(Path.Current, .Name) ' Path & FulName
            .INI = BPth(Path.Work, .Base & ".INI")
        End With
        ' ----------- Pathes -----------
        With Path
            .MyDocs = fSys.SpecialDirectories.MyDocuments
            .Current = fSys.CurrentDirectory
            ' Path.Preliminary is used for test-phase before pgm finished
            ' and is made to WorkPath by GetWorkPath() for general use
            .Preliminary = "YourPath"
            .ProjectSub = "Visual Studio 2015\Projects\*\*\bin\Debug"
            .ProjectSub = Replace(.ProjectSub, "*", fSpec.Base)
            .Project = BPth(.MyDocs, .ProjectSub)
            .Work = GetWorkPath()
            .Constituents = BPth(.Work, "Constituents") ' used if more files as INI extant
        End With
        ' ----------- Drive-Specs -----------
        DRV.Specs = DRV.GetAllInfo()
    End Sub
    ' ----------- Procedures -----------
     Private Function GetMainBoard() As String
        For Each MB In Split(Mainboards, ",")
If StrComp(MB, Left(ComputerName, Len(MB)), CompareMethod.Text) Then Return MB
Next Return ""
    End Function

Private Function GetWorkPath()
If Path.Current = Path.Project Then Return Path.Preliminary
Return Path.Current
End Function

Public Function Respond()
Return OWN.UserName & _
" is here, test that information from OWN is processed by GUP to program"
    End Function

    Public Function ListOfSysVars()
        Dim V, A As New List(Of String)
        With OWN
            "Screen.Width", Screen.Width,
            "Screen.Height", Screen.Height,
            "Mainboard", .Mainboard,
            "ComputerName", .ComputerName,
            "OS", .OS,
            "UserName", .UserName,
            "DriveInfo", String.Join(", ", DRV.GetAllInfo.ToArray),
            "Path.MyDocs", Path.MyDocs,
            "Path.Project", Path.Project,
            "Path.Preliminary", Path.Preliminary,
            "Path.Current", Path.Current,
            "OWN.fname", .fname,
            "OWN.fSpec", .fSpec,
            "Path.Work", Path.Work,
            "Path.Constituents", Path.Constituents,
            "fSpec.INI", .INI,
            "fSpec.DefaultINI", fSpec.DefaultINI})
            For i = 0 To V.Count - 2 Step 2 : A.Add(String.Join(" = ", V.GetRange(i, 2))) : Next
        End With : Return A
    End Function
End Class
' =========================================================================================
Public Class PathSpecs
Public Current, MyDocs, Preliminary, Project, ProjectSub, Work, Constituents
End Class
' =========================================================================================
Public Class FileSpecs
Public Base, Name, File, INI
End Class
' =========================================================================================
Imports System.IO ' needed for DriveInfo
Public Class DriveSpecs
Public Specs As New List(Of String)

' Procedures
    Public Function GetAllInfo() As List(Of String)
If Specs.Count > 0 Then Return Specs
Dim DrvInf As New List(Of String)
For Each As DriveInfo In DriveInfo.GetDrives()
If d.IsReady Then DrvInf.Add(Left(d.Name, 2) & d.VolumeLabel)
Next Return DrvInf
End Function
    Public Function Exists(xName) As Boolean ' xName = ":Name" or "letter:"
        If Len(xName) < 2 Then Return False
        Dim Typ = -1, A As String() = Split(xName, ":") : If Ubd(A) <> 1 Then Return False
        For i = 0 To 1 : If A(i) = "" Then Typ = 1 - i
Next If Not (Typ = 0 Or Typ = 1) Then Return False
        For Each In GetAllInfo()
If StrComp(Split(d, ":")(Typ), A(Typ), CompareMethod.Text) Then Return True
        Next Return False
    End Function
    Public Function GetLetterFromName(xName As String) As String
        Dim a : If Not Exists(":" & xName) Then Return ""
        For Each In GetAllInfo() : a = Split(d, ":")
If StrComp(a(1), xName, CompareMethod.Text) Then Return UCase(a(0))
Next Return ""
    End Function
End Class