Logo Foltyn Presentation
Table of Contents Previous Page Next Page
Content-Symbol-Img
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
        DiagListboxMenu("Init")
        ' Close() ' Form close
    End Sub

    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
        DiagListboxMenu("CallPgm")
    End Sub

    Private 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"
    Public Const Alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    ' 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

    Public 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 = True
            .RestoreDirectory = True
            .InitialDirectory = InitialPath
            If .ShowDialog() <> DialogResult.OK Then Return {}
            Return .FileNames
        End With
    End Function

    Public 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 = True
            .InitialDirectory = InitialPath
            If .ShowDialog() <> DialogResult.OK Then Exit Sub
            RDWRfile(WR, LofA(xArr), .FileName)
        End With
    End Sub

    Public Function DiagFolderBrowse()
        Dim sPath = "", FolderBrowserDialog1 = New FolderBrowserDialog
        With FolderBrowserDialog1
            .RootFolder = Environment.SpecialFolder.MyComputer
            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 A 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
            V.AddRange({
            "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 d 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 d 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 d In GetAllInfo() : a = Split(d, ":")
            If StrComp(a(1), xName, CompareMethod.Text) Then Return UCase(a(0))
        Next : Return ""
    End Function
End Class