VBA snippets


'-----------------------------------------------------------------------------------------------------------------------
' Auteur        : pascalterheege.nl
' Datum         : 10-1-2020
' Doel          : array vs dictionary vs collection
' Opmerking     : verwijzing Microsoft Scripting Runtime (dictionary)
' Bron          : https://excelmacromastery.com/vba-dictionary
'-----------------------------------------------------------------------------------------------------------------------

Sub Arr()

    Dim a() As Variant
    
    Dim r As Integer
    Dim k As Integer
    
    For r = 0 To 5
    
        For k = 0 To 2
        
            ReDim Preserve a(2, r)
            
            a(k, r) = k & "+" & r
            
            Debug.Print a(k, r)
        
        Next k
    
    Next r
    
    Debug.Print "-------------------------------------------"
    
    For r = LBound(a, 2) To UBound(a, 2)        ' dimension 2 = r

        For k = LBound(a, 1) To UBound(a, 1)    ' dimension 1 = k

            Debug.Print a(k, r)

        Next k

    Next r
   
End Sub

Sub Dict()

    Dim d As New Scripting.Dictionary
    Dim key As Variant
    
    d.Add key:="Appel", item:=0
    d.Add key:="Peer", item:=2
    d.Add key:="Mandarijn", item:=3
        
    If d.Exists("Appel") Then d("Appel") = 1
    d.Remove "Mandarijn"
        
    For Each key In d.Keys
    
        MsgBox key & ":" & d(key)
    
    Next key
    

End Sub

Sub Col()

    Dim c As New Collection
    Dim item As Variant
        
    c.Add key:="Appel", item:=1
    c.Add key:="Peer", item:=2
    c.Add key:="Mandarijn", item:=3
        
    For Each item In c
    
        MsgBox item
    
    Next item

End Sub

Option Explicit

'-----------------------------------------------------------------------------------------------------------------------
' Auteur        : pascalterheege.nl
' Datum         : 28-2-2020
' Doel          : voortgangsindicator
' Opmerking     : via UserForm of StatusBar
'-----------------------------------------------------------------------------------------------------------------------

Sub start()

    Dim huidig As Integer
    Dim max As Integer: max = 10
    
    For huidig = 1 To max
    
        DoEvents
    
        Application.Wait Now + TimeValue("00:00:01")
        
        toonVoortgangUserForm huidig, max
        toonVoortgangStatusBar huidig, max
    
    Next huidig

End Sub

'-----------------------------------------------------------------------------------------------------------------------
' Doel          : voortgangsindicator via UserForm
' Objecten      : UserForm1 | Frame1 | Label1 (zelf maken)
' Opmerking     : plaats Label1 in Frame1
'-----------------------------------------------------------------------------------------------------------------------

Sub toonVoortgangUserForm(huidig, max)
    
    With UserForm1
        
        .Label1.BackColor = vbBlue
        .Label1.Width = huidig / max * .Frame1.Width
        .Show 0
        .Repaint
    
    End With

End Sub

'-----------------------------------------------------------------------------------------------------------------------
' Doel          : voortgangsindicator via StatusBar
' Objecten      : Application.StatusBar (ingebouwd)
' Opmerking     : lengte is aantal |||
' Bron          : https://wellsr.com/vba/2017/excel/vba-application-statusbar-to-mark-progress/
'-----------------------------------------------------------------------------------------------------------------------

Sub toonVoortgangStatusBar(huidig As Integer, max As Integer)
    
    Dim Percentage As Integer
    Dim Voltooid As Integer
    
    Dim Lengte As Integer: Lengte = 100
    
    Percentage = Int((huidig / max) * Lengte)
    Voltooid = Round(Percentage / 100 * Lengte, 0)
    
    Application.StatusBar = " [" & String(Percentage, "|") & _
                            Space(Lengte - Percentage) & "] " & Voltooid & _
                             "% Voltooid"

End Sub




Option Explicit

'------------------------------------------------------------------------------------------
' Auteur        : pascalterheege.nl
' Datum         : 10-1-2020
' Object        : clsAccess
' Doel          : verbinding maken met Access
' Opmerking     : verwijzing Microsoft Active X Objects 2.8
'               : CursorLocation = adUseClient voor correcte werking recordcount
'------------------------------------------------------------------------------------------

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

Private Sub Class_Initialize()

    Set cn = New ADODB.Connection
    
    With cn
        .ConnectionString = "Provider = Microsoft.ACE.OLEDB.12.0; Data Source = Databank.accdb"
        .Open
    End With

End Sub

Sub toonData()

    Dim r As Integer
    Dim f As Integer
       
    Set rs = New ADODB.Recordset
     
    With rs
    
        .CursorLocation = adUseClient
        .Open "SELECT * FROM tblGebruiker", cn
        
        If .RecordCount = 0 Then Exit Sub

        .MoveFirst
        
        For r = 1 To rs.RecordCount
        
            For f = 0 To rs.Fields.Count - 1
            
                MsgBox rs.Fields(f).Name & ": " & rs.Fields(f).Value
            
            Next f
        
        Next r
    
    End With
             

End Sub

Private Sub Class_Terminate()

    Set rs = Nothing
    Set cn = Nothing
    
End Sub

'------------------------------------------------------------------------------------------
' Auteur        : pascalterheege.nl
' Datum         : 9-1-2020
' Object        : corrigeerDocument
' Doel          : lege enters verwijderen en pagina einde invoegen
' Opmerking     : foutmelding bij laatste paragraaf kan genegeerd worden
'------------------------------------------------------------------------------------------
 
Sub corrigeerDocument()

    Dim d As Document
    Dim p As Long
    Dim t As Long
    
    Set d = ActiveDocument
    t = d.Paragraphs.Count
    
    For p = 1 To t
    
        If d.Paragraphs(p).Range.Characters.Count = 1 Then
        
            DoEvents
            
            Do
                d.Paragraphs(p).Range.Select
                d.Paragraphs(p).Range.Delete
                t = d.Paragraphs.Count
            Loop Until Selection.Paragraphs(1).Range.Characters.Count > 1
            
            If Selection.Style = "Kop 1" Then Selection.InsertBreak Type:=wdPageBreak

        End If

    Next p

End Sub

'------------------------------------------------------------------------------------------
' Auteur        : pascalterheege.nl
' Datum         : 9-1-2020
' Object        : corrigeerStijl
' Doel          : zoeken naar pagina einde en stijl corrigeren
' Opmerking     : ^m = pagina einde
'------------------------------------------------------------------------------------------

Sub corrigeerStijl()

    Dim f As Range

    Set f = ActiveDocument.Range

    With f.Find
        .Text = "^m"
        .Wrap = wdFindStop
    End With
    
    f.Find.Execute
    
    Do While f.Find.Found
        f.Select
        f.Style = "Standaard"
        f.Find.Execute
    Loop

End Sub