The folder contents - VB Script

Dacă aveți nevoie să scoateți rapid un raport în care să existe conținutul unui folder, puteți folosi VB Script. Următorul cod va genera un fișier .csv. Se poate folosi Microsoft Excel pentru deschidere.
Pentru departajarea coloanelor, datorită setărilor locale se va putea folosi alternativ "," sau ";".


If you need to quickly extract a report with a certain folder contents, you may use VB Script. The following code will generate a .csv file. You may use Microsoft Excel to open it.
For the separation of the columns, due to the local settings it will be possible to use alternatively "," or ";".



'source: https://code-for-vb.blogspot.com/2019/11/the-folder-contents-vb-script.html
'please to mention

Dim Fol  
Dim sFol
Dim Fil   
Dim strPath  
Dim fso   

Dim objShell
Dim MyFile
Dim CurrentDirectory 

Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0



Set fso = CreateObject("Scripting.FileSystemObject")
CurrentDirectory = fso.GetAbsolutePathName(".")

Set objShell=CreateObject("WScript.Shell")

strPath = InputBox("Input the folder address:")

On Error Resume Next
Set Fol = fso.GetFolder(strPath)
If Err.Number <> 0 Then 
   Eroare()
   WScript.Quit
End if
On Error GoTo 0

If fso.FileExists(CurrentDirectory & "\txtStructList.csv") Then fso.DeleteFile(CurrentDirectory & "\txtStructList.csv")

Set MyFile = fso.OpenTextFile(CurrentDirectory & "\txtStructList.csv", ForAppending, True, TristateUseDefault) 
MyFile.WriteLine "Name , Type , Date created , Date modified , Date accessed , Files number , Subfolders number , Size" 

For Each sFol In Fol.SubFolders
    MyFile.WriteLine sFol.Name & " , folder , " & sFol.DateCreated & " , " & sFol.DateLastModified & " , " & sFol.DateLastAccessed & " , " & sFol.Files.Count & " , " & sFol.SubFolders.Count & " , " & sFol.Size & " bytes"
Next

For Each Fil In Fol.Files
    MyFile.WriteLine Fil.Name & " , fisier , " & Fil.DateCreated & " , " & Fil.DateLastModified & " , " & Fil.DateLastAccessed & " , , , " & Fil.Size & " bytes"
Next

MyFile.Close
objShell.Run CurrentDirectory & "\txtStructList.csv"



Sub Eroare()
    MsgBox Err.Description, vbExclamation, "ERR: " & Err.Number
End Sub

How Much Time Has Passed - VBA

Uneori avem nevoie sa stim cat timp a trecut intre doua date, in termeni de zile, luni si ani. Simpla scadere a datei mai mici din data mai mare nu este suficienta: numarul rezultat este doar numarul zilelor. Din nefericire, felul in care ne-am structurat timpul in zile, luni si ani nu face usor calculul in acesti termeni: luna poate avea 28, 29, 30 sau 31 de zile; intre 28 februarie si 31 martie avem o luna si 3 zile, iar odata la patru ani avem o luna si 2 zile.

Functia de mai jos simplifica lucrurile. Ea poate fi folosita ca atare. In Excel, va aparea in lista de functii si se vor putea face referinte catre celule. Variabilele declarate la nivel de modul pot fi folosite separat in alte functii sau rutine.

--------------------------------------------------------------------------------------
Sometimes we need to know how much time has elapsed between two dates, in terms of days, months and years. Simply subtracting the smaller date from the larger date is not enough: the resulting number is just the number of days. Unfortunately, the way we have structured our time in days, months and years does not make the calculation easy in these terms: the month can be 28, 29, 30 or 31 days; between February 28 and March 31 we have a month and 3 days, and every four years we have a month and 2 days.

The function below simplifies things. It may be used as such. In Excel, it will appear in the list of functions and will be able to make references to cells. The variables declared at the module level can be used separately in other functions or routines.



'source:  https://code-for-vb.blogspot.com/2019/11/how-much-time-has-passed.html
'please to mention

Option Explicit

Public y As Integer, m As Byte, d As Byte


Public Function TimeSTR(ByRef DataStart As Date, ByRef DataEnd As Date) As String
Dim yearStart As Integer, yearEnd As Integer
Dim monthStart As Byte, monthEnd As Byte
Dim dayStart As Byte, dayEnd As Byte

Dim dayMonthFinal As Byte
Dim inReverse As Boolean, TemporarData As Date



If DataStart = 0 Or DataEnd = 0 Then
   TimeSTR = "no begining / ending date"
   Exit Function
End If

10
Select Case DataEnd >= DataStart
Case True
     yearStart = Year(DataStart)
     yearEnd = Year(DataEnd)

     monthStart = Month(DataStart)
     monthEnd = Month(DataEnd)

     dayStart = Day(DataStart)
     dayEnd = Day(DataEnd)

Case False
     inReverse = True
     
     TemporarData = DataStart
     DataStart = DataEnd
     DataEnd = TemporarData
     
     GoTo 10
End Select

'finding leap years and odd or even months
Select Case monthEnd
Case 1, 3, 5, 7, 8, 10, 12 '31 days
     dayMonthFinal = 31
        
Case 2 'February - see leap years
     Select Case yearEnd Mod 4
     Case 0
          dayMonthFinal = 29
                     
     Case Else
          dayMonthFinal = 28
     End Select
        
Case 4, 6, 9, 11 '30 days
     dayMonthFinal = 30
End Select


'y=years
'm=months
'd=days
Select Case yearStart = yearEnd
Case True 'year
     Select Case monthStart = monthEnd
     Case True 'month
          y = 0
          m = 0
          d = dayEnd - dayStart
          
     Case False 'month
          Select Case dayEnd >= dayStart
          Case True 'day
               y = 0
               m = monthEnd - monthStart
               d = dayEnd - dayStart
               
          Case False 'day
               y = 0
               m = monthEnd - monthStart - 1
               d = dayEnd + dayMonthFinal - dayStart
          End Select 'day
     End Select 'month
     
Case False 'year
     Select Case monthEnd >= monthStart
     Case True 'month
          Select Case dayEnd >= dayStart
          Case True 'day
               y = yearEnd - yearStart
               m = monthEnd - monthStart
               d = dayEnd - dayStart
               
          Case False 'day
               Select Case monthStart = monthEnd
               Case True 'month
                    y = yearEnd - yearStart - 1
                    m = 11 '(12-1)
                    d = dayEnd + dayMonthFinal - dayStart + 1
                    
               Case False 'month
                    y = yearEnd - yearStart
                    m = monthEnd - monthStart - 1
                    d = dayEnd + dayMonthFinal - dayStart
               End Select 'month
          End Select 'day
     
     Case False 'month
          Select Case dayEnd >= dayStart
          Case True 'day
               y = yearEnd - yearStart - 1
               m = 12 - monthStart + monthEnd
               d = dayEnd - dayStart
               
          Case False 'day
               y = yearEnd - yearStart - 1
               m = 12 - monthStart + monthEnd - 1
               d = dayEnd + dayMonthFinal - dayStart
          End Select 'day
     End Select 'month
End Select 'year

TimeSTR = y & " years, " & m & " months, " & d & " days" & IIf(inReverse, " in reverse", "")
End Function

Normalizing Fields - VBA Access

MS Access permite campuri cu valori multiple, ceea ce nu este intotdeauna potrivit. In cazul in care tabelele nu sunt folosite ca atare, pentru programator nu este nici un avantaj sa aiba campuri cu valori multiple. Tot ceea ce are de facut, este sa normalizeze datele prin atomizarea campurilor.

MS Access allows multiple values fields, which is not always appropriate. If the tables are not used as it is, there is no advantage for the programmer to having fields with multiple values. All he has to do is normalize the data by atomizing the fields.


De exemplu, avem un tabel unde codificam grupurile de utilizatori.

For example, we have a table where we code the users groups.

Si un tabel cu utilizatori si grupurile din care fac parte. Un utilizator poate face parte din mai multe grupuri.

And a table with users and the groups they belong to. A user may be part of several groups.

Sursa campului GroupID arata astfel:

The source of the GroupID field looks like this:

Pentru atomizare, folositi acest cod:

For atomization, use this code:


'source:  https://code-for-vb.blogspot.com/2019/10/normalizing-fields-vba-access.html
'please to mention

Sub ColumnsAtomization()
  Dim rst_1 As Recordset
  Dim rst_2 As Recordset
  Dim str() As String
  Dim aaa   As String
  Dim i     As Integer


  CurrentDb.Execute "CREATE TABLE [Users_New] (UserID INTEGER, UserName TEXT(20), GroupID INTEGER)"
  
  Set rst_2 = CurrentDb.OpenRecordset("Users_New")
  Set rst_1 = CurrentDb.OpenRecordset("Users")
  Do
    aaa = DLookup("GroupID", "Users", "UserID = " & rst_1!UserID)
    str = Split(aaa, ", ") 'or  str = Split(aaa, "; ") - depends on regional settings
    For i = 0 To UBound(str)
        rst_2.AddNew
        rst_2!UserID = rst_1!UserID
        rst_2!UserName = rst_1!UserName
        rst_2!GroupID = str(i)
        rst_2.Update
    Next i
  
    rst_1.MoveNext
  Loop Until rst_1.EOF = True

  Set rst_1 = Nothing
  Set rst_2 = Nothing
End Sub

The Zig-Zag Problem - VBA Excel

https://www.geeksforgeeks.org/print-matrix-zag-zag-fashion/


La aceasta adresa am gasit o problema interesanta.
Pagina ofera solutii in C++, Java, Python3, C# si PHP. Eu voi oferi o solutie Vizual Basic cu ceva animatie intr-un sheet Excel.

I found an interesting problem at the address above.
The web page offers C++, Java, Python3, C# and PHP solutions. Here I offer a Visual Basic solution with a minimum Excel sheet animation. 

Intai, construiti un buton undeva in sheet-ul activ.

Insert a button somewhere into active sheet, first. 

Deschideti editorul Visual Basic si construiti un formular ca cel din imaginea de mai jos.
Open the Visual Basic editor and insert a form as in picture below: 

Codul se afla in modulul formularului frmZigZag si este urmatorul / The Visual Basic code will follow in frmZigZag form module:



'source code: https://code-for-vb.blogspot.com/2019/10/the-zig-zag-problem-vba-excel.html
'please to mention


Option Explicit


Private Sub cmdCancel_Click()
    End
End Sub

Private Sub cmdOK_Click()
    If Me!txtRanduri.Value = 0 Or IsNull(Me!txtRanduri) Or Me!txtRanduri = "" Then
       MsgBox "You have to input a rows number.", vbInformation, "Zig Zag"
       Me!txtRanduri.SetFocus
       Exit Sub
    End If
    If Me!txtColoane.Value = 0 Or IsNull(Me!txtColoane) Or Me!txtColoane = "" Then
       MsgBox "You have to input a columns number.", vbInformation, "Zig Zag"
       Me!txtColoane.SetFocus
       Exit Sub
    End If

    ZigZag
End Sub

Private Sub ZigZag()
    Dim nRow As Integer, nCol As Integer
    Dim r As Integer, c As Integer, k As Integer
    Dim Go As String
    Dim objCel As Object, Final As String


    nRow = Me!txtRanduri
    nCol = Me!txtColoane


    Me.Hide

    For r = 1 To nRow
        For c = 1 To nCol
            k = k + 1
            ActiveSheet.Cells(r, c) = k
            Application.Wait Now + TimeValue("0:00:01")
        Next c
    Next r

    Range(Cells(1, 1), Cells(nRow, nCol)).EntireColumn.AutoFit
    Application.Wait Now + TimeValue("0:00:01")


    r = 1
    c = 1
    Cells(r, c).Select

    Set objCel = ActiveCell
    objCel.Font.Bold = True
    objCel.Font.Color = -16776961

    Final = objCel.Value
    Application.Wait Now + TimeValue("0:00:01")

    Go = "up"
    Do
      Select Case Go
      Case "up"
           c = c + 1
           r = r - 1
           If r < 1 Then
              r = 1
              Go = "down"
           End If
       
      Case "down"
           r = r + 1
           c = c - 1
           If c < 1 Then
              c = 1
              Go = "up"
           End If
      End Select
   
  
      Cells(r, c).Select
      objCel.Font.Bold = False
      objCel.Font.Color = 0
  
      Set objCel = ActiveCell
      objCel.Font.Bold = True
      objCel.Font.Color = -16776961
  
      Final = Final & "," & objCel.Value
      Application.Wait Now + TimeValue("0:00:01")
  
      If r = nRow And c = nCol Then Exit Do
  
  
      Select Case Go
      Case "up"
           If c = nCol Then
              c = c + 1
              Go = "down"
           End If
       
      Case "down"
           If r = nRow Then
              r = r + 1
              Go = "up"
           End If
      End Select
    Loop Until r >= nRow And c >= nCol

    Cells(nRow + 2, 1).Select
    objCel.Font.Bold = False
    objCel.Font.Color = 0

    Set objCel = ActiveCell
    objCel.Font.Bold = True
    objCel.Font.Color = -16776961

    objCel.Value = Final
    MsgBox "Final!", vbInformation, "Zig Zag"

    End
End Sub

Private Sub lblColoane_Click()
    Me!txtColoane.SetFocus
End Sub

Private Sub lblRanduri_Click()
    Me!txtRanduri.SetFocus
End Sub

Private Sub txtColoane_AfterUpdate()
    Me!txtColoane = Int(Abs(Me!txtColoane))
End Sub

Private Sub txtRanduri_AfterUpdate()
    Me!txtRanduri = Int(Abs(Me!txtRanduri))
End Sub



'Construiti un modul separat pentru codul care va activa butonul din sheetul activ si legati codul de acest buton / Insert a separate module for the code for button in active sheet and link the code with the button event.


Option Explicit

Sub Button1_Click()
    frmZigZag.Show
End Sub

'Rularea programului / Running the code:

'Rezultatul / The result:

Sorting & Grouping Vectors - VBA

'*****************************************************************
'Urmatorul cod va face:                                          *
'                                                                *
'1.Ordoneaza vectorul                                            *  
'2.Numara grupurile de valori ale vectorului                     *
'3.Calculeaza frecventa de aparitie a fiecarei valori din grup   *
'4.Ordoneaza frecventele de aparitie a valorilor vectorului      *
'5.Grupeaza frecventele de aparitie                              *
'6.Identifica un numar in ce grupa de frecvente se afla          *

'*****************************************************************

'*****************************************************************
'The following code will do:                                     *
'                                                                *
'1.Sort the vector                                               *  
'2.Number the groups of values of the vector                     *
'3.Count the frequency of occurrence of each value in the group  *
'4.Sort the frequencies of the vector values                     *
'5.Group the occurrence frequencies                              *
'6.Identify a number in which frequency group it is              *

'*****************************************************************

'source: https://code-for-vb.blogspot.com/2019/10/sorting-grouping-vectors-vba.html
'please to mention

Option Compare Database
Option Explicit

Private V() As Integer, VRez() As Integer
Private Nr  As Integer, NrGr   As Integer


Sub PornesteVector()
    Nr = InputBox("Introduceti numarul / Input number")
    CheamaVectorSort
End Sub

Sub CheamaVectorSort()
    Dim j          As Integer
    Dim strIni     As String 'acesta este sirul pe care il voi ordona / this is the string I want to sort
    Dim strSplit() As String

    strIni = "-1;4;-1;4;-7;-1;-7;-1;-5;-7;8"
    strSplit = Split(strIni, ";")

    ReDim V(UBound(strSplit)), VRez(UBound(strSplit))
    For j = LBound(strSplit) To UBound(strSplit)
        V(j) = strSplit(j)
        Debug.Print "V(" & j & ") = " & V(j)
    Next j

    For j = LBound(V) To UBound(V) - 1
        VectorSort
    Next j

    Debug.Print "sortez valorile vectorului / sort the vector values:"
    For j = LBound(V) To UBound(V)
        Debug.Print "V(" & j & ") = " & V(j)
        VRez(j) = V(j)
    Next j

    GrupuriV
End Sub

Sub VectorSort()
    Dim a, b, c, d, e
    Dim i As Integer
    Dim VN() As Integer

    ReDim VN(LBound(V) To UBound(V))
    'la prima iteratie compar primele doua valori ale vectorului V
    'inmagazinez valoarea mai mare intr-o variabila fixa (d)
    'si de la a doua iteratie, compar valoarea vectorului V cu valoarea reziduala d
    'la final, trec valorile vectorului nou VN ca valori ale vectorului V

    'at the first iteration I compare the first two values of the vector V
    'store the higher value in a fixed variable (d)
    'and from the second iteration, I compare the value of vector V with the residual value d
    'at the end, pass the values of the new vector VN as values of the vector V

    e = 0
    For i = LBound(V) + 1 To UBound(V)
        e = e + 1
    
        a = V(i)
        If e = 1 Then
           b = V(i - 1)
        Else
            b = d
        End If
    
        If a > b Then
           c = b
           VN(i) = a
        Else
            c = a
            VN(i) = b
        End If
    
        VN(i - 1) = c
        d = VN(i)
    Next i

    For i = LBound(V) To UBound(V)
        V(i) = VN(i)
    Next i
End Sub

Sub GrupuriV()
    Dim k As Integer, gr() As Integer, i As Integer, fr() As Integer, j As Integer
    Dim a As Byte

    Do
      k = 1
      For i = LBound(V) + 1 To UBound(V)
          If V(i) > V(i - 1) Then
             k = k + 1
          End If
      Next i

      Debug.Print k; "grupuri / groups"
      NrGr = k
  
      ReDim gr(k), fr(k)
      k = 1
      gr(1) = V(LBound(V))
      fr(k) = 1
      j = 1
  
      For i = LBound(V) + 1 To UBound(V)
          If V(i) > V(i - 1) Then
             k = k + 1
             j = 1
          Else
              j = j + 1
          End If
          gr(k) = V(i)
          fr(k) = j
      Next i

      Select Case a
      Case 0
           For i = 1 To k
               Debug.Print "gr(" & i & ") = " & gr(i), "freq(" & i & ") = " & fr(i)
           Next i

           ReDim V(k - 1)
           For i = 1 To k
               V(i - 1) = fr(i)
           Next i
       
           Debug.Print "sortez frecventele / sort the frequencies:"
           For i = LBound(V) To UBound(V) - 1
               VectorSort
           Next i
           For i = LBound(V) To UBound(V)
               Debug.Print "V(freq(" & i & ")) = " & V(i)
           Next i
  
      Case Else
           For i = 1 To k
               Debug.Print "gr(" & i & ") = " & gr(i)
           Next i
      End Select
  
      a = a + 1
    Loop Until a = 2

    ApartineV
End Sub

Sub ApartineV()
    Dim i As Integer, a As Integer

    For i = LBound(VRez) To UBound(VRez)
        If Nr = VRez(i) Then
           a = a + 1
        End If
    Next i

    Debug.Print "nr. " & Nr & " apartine gr. " & a & " din " & NrGr
    Debug.Print "no. " & Nr & " belong to gr. " & a & " from " & NrGr
End Sub

'Sa presupunem ca numarul introdus este 8 / Assume that the input number is 8.
'Rezultatul / The result:

V(0) = -1
V(1) = 4
V(2) = -1
V(3) = 4
V(4) = -7
V(5) = -1
V(6) = -7
V(7) = -1
V(8) = -5
V(9) = -7
V(10) = 8
sortez valorile vectorului / sort the vector values:
V(0) = -7
V(1) = -7
V(2) = -7
V(3) = -5
V(4) = -1
V(5) = -1
V(6) = -1
V(7) = -1
V(8) = 4
V(9) = 4
V(10) = 8
 5 grupuri / groups
gr(1) = -7    freq(1) = 3
gr(2) = -5    freq(2) = 1
gr(3) = -1    freq(3) = 4
gr(4) = 4     freq(4) = 2
gr(5) = 8     freq(5) = 1
sortez frecventele / sort the frequencies:
V(freq(0)) = 1
V(freq(1)) = 1
V(freq(2)) = 2
V(freq(3)) = 3
V(freq(4)) = 4
 4 grupuri / groups
gr(1) = 1
gr(2) = 2
gr(3) = 3
gr(4) = 4
nr. 8 apartine gr. 1 din 4
no. 8 belong to gr. 1 in 4