René Houkema

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    Application.EnableEvents = False

    thisPath = ThisWorkbook.Path

    myName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") – 1))

    ext = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) – InStrRev(ThisWorkbook.Name, "."))

    'backupdirectory = myName & " backups"

    backupdirectory = "backup"

    Set FSO = CreateObject("Scripting.FileSystemObject")

    If Not FSO.FolderExists(ThisWorkbook.Path & "/" & backupdirectory) Then

        FSO.CreateFolder (ThisWorkbook.Path & "/" & backupdirectory)

    End If

    T = Format(Now, "mmm dd yyyy hh mm ss")

    ThisWorkbook.SaveCopyAs thisPath & "\" & backupdirectory & "\" & myName & " " & T & "." & ext

    Application.EnableEvents = True

End Sub

Sub TableCreate()

'

' TableCreate Macro

'

'https://msdn.microsoft.com/en-us/library/office/ff823155.aspx

' ctrl+l

Dim objTable As ListObject

Set objTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes)

objTable.TableStyle = "TableStyleMedium2"

    With Selection

        .HorizontalAlignment = xlGeneral

        .VerticalAlignment = xlTop

        .WrapText = False

        .Orientation = 0

        .AddIndent = False

        .IndentLevel = 0

        .ShrinkToFit = False

        .ReadingOrder = xlContext

        .MergeCells = False

    End With

End Sub

Sub DeleteActiveWorksheet()

'ctrl + w

    Application.DisplayAlerts = False

    ActiveSheet.Delete

    Application.DisplayAlerts = True

End Sub

Sub LineUpMyCharts()

    Dim MyWidth As Single, MyHeight As Single

    Dim NumWide As Long

    Dim iChtIx As Long, iChtCt As Long

    MyWidth = 375

    MyHeight = 250

    NumWide = 2

    iChtCt = ActiveSheet.ChartObjects.Count

    For iChtIx = 1 To iChtCt

        With ActiveSheet.ChartObjects(iChtIx)

            .Width = MyWidth

            .Height = MyHeight

            .Left = ((iChtIx – 1) Mod NumWide) * MyWidth

            .Top = Int((iChtIx – 1) / NumWide) * MyHeight

        End With

        pngName = ActiveWorkbook.Path & "\png\" & iChtIx & ".png"

        ActiveSheet.ChartObjects(iChtIx).Activate

        ActiveChart.Export FileName:=pngName, FilterName:="PNG"

    Next

End Sub

Public Function Printf(mask As String, ParamArray tokens()) As String

    Dim i As Long

     For i = 0 To UBound(tokens)

          mask = Replace$(mask, "%s", tokens(i), , 1)

     Next

     Printf = mask

End Function

Public Sub ExportToCsv()

     Dim FName As String

     Dim Sep As String

     Dim Enclose As String

     Dim wsSheet As Worksheet

     Dim nFileNum As Integer

     Dim csvPath As String

     'Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", "Export To Text File")

     Sep = ";"

     Enclose = """"

     'csvPath = InputBox("Enter the full path to export CSV files to: ")

     'csvPath = GetFolderName("Choose the folder to export CSV files to:")

     'If csvPath = "" Then

     '    MsgBox ("You didn't choose an export directory. Nothing will be exported.")

     '    Exit Sub

     'End If

     'For Each wsSheet In Worksheets

          'wsSheet.Activate

          Set wsSheet = ActiveSheet

          FName = ActiveWorkbook.Path & "\" & wsSheet.Name & ".csv"

          ExportToUTF8CsvFile FName, Sep, Enclose, True

     'Next wsSheet

End Sub

Public Sub ExportToUTF8CsvFile(FName As String, Sep As String, Enclose As String, SelectionOnly As Boolean)

    Dim WholeLine As String

    Dim RowNdx As Long

    Dim ColNdx As Integer

    Dim StartRow As Long

    Dim EndRow As Long

    Dim StartCol As Integer

    Dim EndCol As Integer

    Dim CellValue As String

    Dim fso, file, test

    Application.ScreenUpdating = False

    On Error GoTo EndMacro:

    If SelectionOnly = True Then

        With Selection

            StartRow = .Cells(1).Row

            StartCol = .Cells(1).Column

            EndRow = .Cells(.Cells.Count).Row

            EndCol = .Cells(.Cells.Count).Column

            If (StartRow – EndRow) = 0 And (StartCol – EndCol) = 0 Then

                SelectionOnly = False

            End If

        End With

    End If

    If SelectionOnly = False Then

        With ActiveSheet.UsedRange

            StartRow = .Cells(1).Row

            StartCol = .Cells(1).Column

            EndRow = .Cells(.Cells.Count).Row

            EndCol = .Cells(.Cells.Count).Column

        End With

    End If

    Set fso = CreateObject("ADODB.Stream")

    fso.Type = 2 'Specify stream type – we want To save text/string data.

    fso.Charset = "utf-8" 'Specify charset For the source text data.

    fso.Open 'Open the stream And write binary data To the object

    For RowNdx = StartRow To EndRow

        WholeLine = ""

        For ColNdx = StartCol To EndCol

            If Cells(RowNdx, ColNdx).Value = "" Then

                CellValue = ""

            Else

                CellValue = Cells(RowNdx, ColNdx).Value

            End If

            If CellValue = "(blank)" Then

                CellValue = ""

            End If

            CellValue = Enclose & CellValue & Enclose

            WholeLine = WholeLine & CellValue & Sep

        Next ColNdx

        WholeLine = Left(WholeLine, Len(WholeLine) – Len(Sep)) & vbCrLf

        fso.WriteText WholeLine

    Next RowNdx

    fso.SaveToFile FName, 2 'Save binary data To disk

    fso.Close

    MsgBox (RowNdx – 1) & " record(s) exported to " & FName

EndMacro:

    On Error GoTo 0

    Application.ScreenUpdating = True

End Sub