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
Automatisches Datensammeln in einem Ordner Automatic Data Collection in one single directory

Das Programm dient dem Sammeln von Daten aus mehreren Ordnern in einem einzelnen Ordner, ohne dass sie dadurch überschrieben werden und leere Verzeichnisse werden gelöscht. Es stellt eine Studie dar, wie man mit den verbesserten Mitteln der VB 2015 Programmier-Sprache Verzeichnisbäume bewegen, Dateien oder Unterverzeichnisse in Verzeichnisbäumen individuell behandeln oder leere Verzeichnisse löschen kann.

The program serves the collection of data from several directories into one single directory, without beeing overwritten by the process and how empty directories can be deleted. It presents a study, how one can, with the improved means of the VB 2015 programming language, move directory trees, files or subdirectories in directory-trees can be treated individually or empty directories deleted.

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
11. Juli 2016 July 11th 2016

Automatic Data Collection in a single Directory

AutoDataCollect

Program-Code

' Program in Visual BASIC 2015
' ========================================================================================
Option Strict On
Option Explicit On
Public Class Form1
    Private OWN As New OwnSpecs
    Private PGM As New Program
 
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        Dim BEM As List(Of String) = BreakErrMsg
        Me.CenterToScreen()
        With TextBox1
            .TextAlign = HorizontalAlignment.Center
            .Text = vbCrLf & vbCrLf & "Waiting for Start"
            OWN.Init() : If lON(BEM) Then .Text = CText(BEM)
        End With
    End Sub
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
        Dim BEM As List(Of String) = BreakErrMsg
        If lON(BEM) Then Me.Close() : Exit Sub ' Form close
        'Me.Left = 40 : Me.Top = 40
        With TextBox1
            .TextAlign = HorizontalAlignment.Left
            PGM.Main() : Button1.Enabled = False : .DeselectAll()
            If lON(BEM) Then .Text = CText(BEM) : Exit Sub
            .Text = PGM.GetReport(Report)
        End With
    End Sub
End Class
' ========================================================================================
Option Explicit On
 
Public Class OwnSpecs
    Public Const CoFilesFldr As String = "CoFiles" ' Cofiles are needed for the complete function
    Public Const CoFiles As String = "" ' Chain of filenames if any given
    Private Path As New Pathes
 
    Public Sub Init()
        If Not FoE(Path.Downloads, 0) Then _
            BreakErrMsg.Add("no path " & qo(Path.Downloads) & " exists") : Exit Sub
        If Not CoFilesOK() Then Exit Sub
        ' other inits
    End Sub
    Private Function CoFilesOK() As Boolean
        With BreakErrMsg
            .Clear() : If CoFiles = "" Then Return True
            For Each File In Split(CoFiles, ",")
                If Not FiE(File) Then .Add(Space(4) & qo("..\" & BPth(CoFilesFldr, File)))
            Next : If lOFF(BreakErrMsg) Then Return True
            .Insert(0, "CoFile(s)") : .Add("not exist")
        End With : Return False
    End Function
End Class
' ========================================================================================
Option Explicit On
Imports System.IO
 
Public Class Program
    Private OWN As New OwnSpecs
 
    Public Sub Main()
        Dim SubPathes, SubSubPathes, fList As New List(Of String)
 
        If Not FoE(Path.Downloads, 1) Then Exit Sub
        DelEmptyFolders(Path.Downloads)
        fSys.CreateDirectory(Path.AllCollected)
        SubPathes = GetSubPathes(Path.Downloads)
        SubSubPathes = GetSubSubPathes(SubPathes)
        MoveSubSubPathes(SubSubPathes)
        fList = GetFiles(Path.Downloads, 1)
        MoveFiles(fList, Path.AllCollected)
        DelEmptyFolders(Path.Downloads)
        Report.AddRange(fList) ' Report
    End Sub
 
    Public Function GetReport(xList As List(Of String)) As String
        Dim pc As String = Path.AllCollected
        Dim d As String = StrDup(10, "-")
        Dim lTmp As New List(Of String)
        Dim l As Byte = Len(pc) + 2
 
        xList.Add(d & " PathsCollected " & d)
        For Each line In GetSubPathes(pc) : lTmp.Add(Mid(line, l)) : Next
        xList.Add(d & " FilesCollected " & d)
        For Each line In GetFiles(pc, 1) : lTmp.Add(Mid(line, l)) : Next
        xList.AddRange(lTmp) : xList.Add(d & " Job done " & d)
        Return CText(xList)
    End Function
End Class
' ========================================================================================
Option Explicit On
Imports System.IO
 
Module BasicFunctions
    Public Const Fldr_AllCollected As String = "AllCollected"
    Public Const Numerics As String = "0123456789"
 
    Public fSys As Object = My.Computer.FileSystem ' doesn't work with Option Strict On
    Public BreakErrMsg, ErrMsg, Report As New List(Of String)
    Public Path As New Pathes
    Private fREN As New FileRename
 
    Public Class Pathes
        Public Current As String = fSys.CurrentDirectory
        Public Downloads As String = "c:\YourPath"
        Public AllCollected As String = BPth(Downloads, Fldr_AllCollected)
    End Class
 
    ' Strings
    Public Function qo(xStr As String) As String
        Return """" & xStr & """"
    End Function
    Public Function CText(LofS As List(Of String)) As String
        Return String.Join(vbCrLf, LofS)
    End Function
    Public Function IsNumeric(xStr As String) As Boolean
        If xStr = "" Then Return False
        For Each c In ToCharArray(xStr)
            If InStr(Numerics, c) = 0 Then Return False
        Next : Return True
    End Function
    Public Function ToCharArray(xStr) As List(Of String)
        Dim A As New List(Of String) : If xStr = "" Then Return A
        For i = 1 To Len(xStr) : A.Add(Mid(xStr, i, 1)) : Next : Return A
    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)
        Return Mid(xStr, x1, x2 - x1 + 1)
    End Function
    Function Remove(xStr As String, x1 As Integer, xd As Integer) As String
        If x1 < 1 Or x1 > Len(xStr) Then Return xStr
        If xd < 1 Or (x1 + xd - 1) > Len(xStr) Then Return xStr
        Return Left(xStr, x1 - 1) & Mid(xStr, x1 + xd)
    End Function
    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
    Function Substitute(xStr As String, x1 As Integer, x2 As Integer, iStr As String) As String
        Substitute = Insert(Remove(xStr, x1, x2 - x1 + 1), x1, iStr)
    End Function
 
    ' List of Strings
    Public Function lON(xL As List(Of String)) As Boolean
        Return xL.Count > 0
    End Function
    Public Function lOFF(xL As List(Of String)) As Boolean
        Return Not lON(xL)
    End Function
    Public Function SortLofS(LofS As List(Of String), SD As Integer) As List(Of String)
        If Not SDOK(SD) Then Return LofS
        LofS.Sort() : If SD = -1 Then LofS.Reverse()
        Return LofS
    End Function
 
    ' Pathes
    Public Function BPth(xPath As String, xFile As String) As String
        Return IO.Path.Combine(xPath, xFile)
    End Function ' Path Procedures
    Public Function GetSubPathes(xPath As String) As List(Of String)
        Dim sPths As New List(Of String)
        sPths.AddRange(fSys.GetDirectories(xPath))
        Dim ix = sPths.IndexOf(Path.AllCollected) : If ix > -1 Then sPths.RemoveAt(ix)
        Return sPths
    End Function
    Public Function GetSubSubPathes(xSubPathList As List(Of String)) As List(Of String)
        Dim ssp As New List(Of String) : Dim pTmp As String
        For Each sPth In xSubPathList
            If sPth = Path.AllCollected Then Continue For
            Dim dir As New DirectoryInfo(sPth)
            pTmp = BPth(Path.AllCollected, dir.Name)
            If Not FoE(pTmp, 0) Then ssp.Add(sPth)
        Next : Return ssp
    End Function
    Public Sub MoveSubSubPathes(xssPathes As List(Of String))
        For Each ssPath In xssPathes
            fSys.MoveDirectory(ssPath, Path.AllCollected)
        Next
    End Sub
 
    ' Folders
    Public Function FoE(xPath As String, Msg As Byte) As Boolean
        Dim fe As Boolean = fSys.DirectoryExists(xPath)
        If fe Then Return True
        Dim txt = "Folder " & qo(xPath) & " not exists"
        If Msg = 1 Then BreakErrMsg.Add(txt)
        If Msg = -1 Then ErrMsg.Add(txt)
        Return False
    End Function ' FolderExists
    Public Function FoP(xfSpec As String) As String
        Return IO.Directory.GetParent(xfSpec).ToString
    End Function ' Parentfolder
    Public Function FolderEmpty(xPath As String) As TriState ' FolderEmpty = -2 if FolderNotExists
        If Not (FoE(xPath, 0)) Then Return vbUseDefault
        If lON(GetSubFolders(xPath, 0, False)) Then Return False
        If lON(GetFiles(xPath, 0)) Then Return False
        Return True
    End Function
 
    Public Function GetSubFolders(xPath As String, SD As Integer,
                                  BasePath As Boolean) As List(Of String)
        Dim Fldrs As New List(Of String)
        If Not (FoE(xPath, 0) And SDOK(SD)) Then Return Fldrs
        For Each foSpec In fSys.GetDirectories(xPath)
            If Not BasePath Then foSpec = Mid(foSpec, Len(xPath) + 2)
            Fldrs.Add(foSpec)
        Next : Return SortLofS(Fldrs, SD)
    End Function
    Public Function GetSubTree(ByVal xPath As String, ByVal SD As Integer,
                               BasePath As Boolean) As List(Of String)
        Dim Tree, SubTree As New List(Of String)
        If Not (FoE(xPath, 0) And SDOK(SD)) Then Return Tree
        Dim Ptr As Integer = -1, Path As String = xPath
        Do : Tree.AddRange(GetSubFolders(Path, SD, True).ToArray)
            Ptr += 1 : If Ptr > Tree.Count - 1 Then Exit Do
            Path = Tree.Item(Ptr)
            If Not BasePath Then SubTree.Add(Mid(Path, Len(xPath) + 2))
        Loop : If Not BasePath Then Tree = SubTree
        Return SortLofS(Tree, SD)
    End Function
    Public Sub DelEmptyFolders(ByVal xPath As String)
        For Each xPath In GetSubTree(xPath, -1, True)
            If Not FolderEmpty(xPath) Then Continue For
            Try : My.Computer.FileSystem.DeleteDirectory(xPath,
                               FileIO.DeleteDirectoryOption.ThrowIfDirectoryNonEmpty)
            Catch ex As System.IO.IOException
            End Try
        Next
    End Sub
 
    ' Files
    Public Function FiE(xfSpec As String) As Boolean
        If xfSpec = "" Then Return False Else Return fSys.FileExists(xfSpec)
    End Function ' File Exists
    Public Function FiN(xfSpec As String) As String
        Return IO.Path.GetFileName(xfSpec)
    End Function ' returns Filename
    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 Function GetFiles(xPath As String, SD As Integer) As List(Of String)
        Dim Files As New List(Of String)
        If Not (FoE(xPath, 0) And SDOK(SD)) Then Return Files
        For Each fi As String In fSys.GetFiles(xPath) : Files.Add(fi) : Next
        Return SortLofS(Files, SD)
    End Function
    Public Sub MoveFiles(xfList As List(Of String), xPath As String)
        Dim FulName As String, fSpecNew As String
        For Each fSpec In xfList : FulName = FiN(fSpec)
            fSpecNew = fREN.GetUnusedFileNameForSaving(BPth(xPath, FulName))
            fSys.MoveFile(fSpec, fSpecNew)
        Next
    End Sub
    Private Sub MoveFile(xfSpec As String, xPath As String)
        Dim Path As String = FoP(xfSpec), FulName As String = FiN(xfSpec)
        fSys.MoveFile(xfSpec, BPth(xPath, FulName))
    End Sub
    Public Class FileRename
        Public Function GetUnusedFileNameForSaving(ByVal xfSpec) As String
            If Not xfSpecOK(xfSpec) Then Return ""
            Dim Path, FulName, FileName, Ext, fSpec, BrExpr As String
            Path = "" : FulName = "" : FileName = "" : Ext = "" : BrExpr = "" : fSpec = xfSpec
            Dim nr, i1, i2 As Integer
            Do : GetFSpecs(Path, FulName, FileName, Ext, fSpec)
                If Not FiE(fSpec) Then Return fSpec
                BrExpr = GetBrackExpression(i1, i2, FileName)
                If IsNumeric(BrExpr) Then ' change number
                    nr = Val(BrExpr) : nr += 1
                    FileName = Substitute(FileName, i1, i2, CStr(nr))
                Else ' add number
                    FileName = FileName & " (1)"
                End If : fSpec = BPth(Path, FileName & Ext)
            Loop
        End Function
 
        Private Function GetBrackExpression(ByRef i1 As Integer, ByRef i2 As Integer,
                                        ByVal xFileName As String) As String
            If Right(xFileName, 1) <> ")" Then Return ""
            i1 = InStrRev(xFileName, "(") : If i1 = 0 Then Return ""
            i1 += 1 : i2 = Len(xFileName) - 1 : If i1 < i2 - 1 Then i1 = 0 : i2 = 0 : Return ""
            Return SubStrg(xFileName, i1, i2)
        End Function
        Private Sub GetFSpecs(ByRef Path As String, ByRef FulName As String,
                          ByRef FileName As String, ByRef Ext As String, ByRef xfSpec As String)
            Path = Trim(FoP(xfSpec)) : FulName = Trim(FiN(xfSpec))
            FileName = Trim(FiB(FulName)) : Ext = Trim(FiExt(FulName))
            xfSpec = BPth(Path, FileName & Ext)
        End Sub
        Private Function xfSpecOK(ByVal xfSpec As String) As Boolean
            If xfSpec = "" Then Return False
            Dim Path, FulName, FileName, Ext As String
            Path = "" : FulName = "" : FileName = "" : Ext = ""
            GetFSpecs(Path, FulName, FileName, Ext, xfSpec)
            If Not FoE(Path, 0) Then Return False
            If FulName = "" Then Return False
            If FileName = "" Then Return False
            If Ext = "." Or Ext = "" Then Return False
            Return True
        End Function
    End Class
    Private Function GetFSpecsOfTree(xPath As String, SD As Integer) As List(Of String)
        Dim fSpecs As New List(Of String) : If Not SDOK(SD) Then Return fSpecs
        For Each xPath In GetSubTree(xPath, SD, True)
            If xPath = Path.AllCollected Then Continue For
            fSpecs = GetFiles(xPath, SD)
        Next : Return fSpecs
    End Function
 
    ' Small Service Routines
    Public Function SDOK(SD) ' SD = Sortdirection, True for -1,0,1
        Return (Math.Abs(SD) = 1 Or SD = 0)
    End Function
End Module
' ========================================================================================