Sub RemoveSmallSegments()

Dim sShape As Shape
If ActiveShape Is Nothing Then Exit Sub Else Set sShape = ActiveShape

Dim oShapeRange As ShapeRange
Dim dDist As Double
Dim X As Double, Y As Double, W As Double, H As Double, i As Long
Dim lDirection As cdrContourDirection

sShape.GetBoundingBox X, Y, W, H

'set offset as 0.02 (2%) of heigth of the selected shape
dDist = H * 0.02

For i = 1 To 4
    If i = 1 Or i = 4 Then lDirection = cdrContourOutside Else lDirection = cdrContourInside
    sShape.CreateContour lDirection, dDist, 1, cdrDirectFountainFillBlend, , , , 0, 0, cdrContourSquareCap, cdrContourCornerMiteredOffsetBevel, 0
    sShape.ConvertToCurves
    Set oShapeRange = sShape.Effects(1).Separate
    Set sShape = oShapeRange(1)
    oShapeRange(2).Delete
Next i

sShape.Selected = True
Set oShapeRange = Nothing

End Sub

Sub ImageInfos()

Dim objImage

Set objImage = CreateObject("WIA.ImageFile")
objImage.LoadFile ścieżka_do_pliku

MsgBox "Szerokość: " & objImage.Width & vbCrLf & _
          "Wysokość: " & objImage.Height & vbCrLf & _
          "Rozdz. pozioma: " & objImage.Horizontalresolution & vbCrLf & _
          "Rozdz. pionowa: " & objImage.Verticalresolution

Set objImage = Nothing

End Sub

Option Explicit

Function GetFolder(sTitle As String, Optional sButtonName As String = vbNullString, Optional strPath As String = vbNullString) As String

Dim fldr As FileDialog
Dim sItem As String

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

With fldr
    .Title = sTitle
    .AllowMultiSelect = False
    .ButtonName = sButtonName
    .InitialFileName = strPath
    If .Show = -1 Then GetFolder = .SelectedItems(1) Else GetFolder = vbNullString
End With

Set fldr = Nothing

End Function

Sub GetFilelist()

Dim sPath As String
sPath = GetFolder("Wybierz folder z plikami", "Wybierz")
If sPath = vbNullString Then Exit Sub

Dim oFS, oFolder, oFile
Dim i As Long: i = 2

Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFS.GetFolder(sPath)

If oFolder.Files.Count = 0 Then
    MsgBox "W wybranym katalogu nie ma plików.", vbInformation
    Set oFolder = Nothing
    Set oFS = Nothing
    Exit Sub
End If

Dim lWKCount As Long
Dim oWBK As Workbook

lWKCount = Application.SheetsInNewWorkbook

Application.SheetsInNewWorkbook = 1
Set oWBK = Application.Workbooks.Add

Application.SheetsInNewWorkbook = lWKCount

oWBK.Worksheets(1).Range("A1").Value = "nazwa pliku"
oWBK.Worksheets(1).Range("B1").Value = "rozmiar"
oWBK.Worksheets(1).Range("C1").Value = "data utworzenia"
oWBK.Worksheets(1).Range("A1").Font.Italic = True
oWBK.Worksheets(1).Range("B1").Font.Italic = True
oWBK.Worksheets(1).Range("C1").Font.Italic = True

For Each oFile In oFolder.Files

    oWBK.Worksheets(1).Range("A" & i).Value = oFile.Name
    
    Select Case oFile.Size
        Case 0 To 1023
            oWBK.Worksheets(1).Range("B" & i).Value = Format(oFile.Size, "0") & " B"
        Case 1024 To 1048575
            oWBK.Worksheets(1).Range("B" & i).Value = Format(oFile.Size / 1024, "0") & " KB"
        Case 1048576 To 1073741823
            oWBK.Worksheets(1).Range("B" & i).Value = Format(oFile.Size / 1048576, "0") & " MB"
        Case 1073741824 To 1.11111111111074E+20
            oWBK.Worksheets(1).Range("B" & i).Value = Format(oFile.Size / 1073741823, "0.00") & " GB"
    End Select
    
    oWBK.Worksheets(1).Range("B" & i).HorizontalAlignment = xlRight
    
    oWBK.Worksheets(1).Range("C" & i).Value = oFile.DateCreated
    
    i = i + 1
    
Next oFile

oWBK.Worksheets(1).Columns("A:C").AutoFit
    
Set oWBK = Nothing
Set oFolder = Nothing
Set oFS = Nothing

End Sub

Const sInstalator = "Instalator"
Dim oExcel

On Error Resume Next

Set oExcel = GetObject(,"Excel.Application")

If Err.Number = 0 Then
     MsgBox "Um die Installation weiter durchfüren zu können, schließen Sie Excel.", vbCritical, sInstalator
Else
     Err.Clear

     Const sExt = "xlam"
     Dim oFS, oInstallFolder, sTitle, N, cAddonCol

     Set oFS = CreateObject("Scripting.FileSystemObject")
     Set oInstallFolder = oFS.GetFile(WScript.ScriptFullName).ParentFolder
     Set cAddonCol = CreateObject("Scripting.Dictionary")

     N=0
     For Each oFileItem In oInstallFolder.Files
           If oFS.GetExtensionName(oFileItem.Name) = sExt Then sTitle = GetName(oInstallFolder.Path, oFileItem.Name): sFile=oFileItem.Name: cAddonCol.Add N, oFileItem.Name : N=N+1
     Next

      If N=1 Then
          Dim OF

          Set oExcel= CreateObject("Excel.Application")
          If Err.Number <> 0 Then
               Msgbox Err.Description, vbCritical, sInstalator & " " & sTitle
               Err.Clear
          Else
               Dim oFile

               For Each oF in oInstallFolder.Files
                    If oFS.FileExists(oF) And oF.Name <> oFS.GetFilename(WScript.ScriptFullName) Then oFS.CopyFile OF, oExcel.UserLibraryPath , True
               Next
               If Err.Number <> 0 Then
                    oExcel.Quit
                    Set oExcel = Nothing
                    Msgbox Err.Description, vbCritical, sInstalator & " " & sTitle
                    Err.Clear
               Else
                    Dim oWbk

                    Set oWbk = oExcel.Workbooks.add
                    oExcel.AddIns.Add (oFS.BuildPath(oExcel.UserLibraryPath, sFile)).Installed=true

                    If Err.Number <> 0 Then
                        oWbk.Close False
                        oExcel.Quit
                        Msgbox Err.Description, vbCritical, sInstalator & " " & sTitle
                        Err.Clear
                    Else
                        oWbk.Close False
                        oExcel.Quit
                        Msgbox "Installation vom Addin '" & sTitle & "' erfolgreich abgeschlossen.", vbInformation, sInstalator & " " & sTitle
                    End If
                   Set oWbk = Nothing
               End If
               Set oExcel = Nothing
          End If
     ElseIf N=0
          MsgBox "Keine Addin-Datei in diesem Folder.", vbCritical, sInstalator & " " & sTitle
     Else
          Dim key, sLista
          For Each key In cAddonCol.keys
               sLista = sLista & cAddonCol.Item(key) & vbcrlf
          Next
          MsgBox "Es gibt " & N & " Addin-Dateien in diesem Folder:" & vbcrlf & vbcrlf & Trim(sLista) & vbcrlf & _
                      "Es darf nur eine Addin-Datei im Folder sein.", vbCritical, sInstalator
     End If
     Set oFS = Nothing
     Set oInstallFolder = Nothing
     Set cAddonCol = Nothing
End If

Function GetName(sFolder, SFile)

   Dim objShell, objFolder, objFolderItem

   Set objShell = CreateObject("Shell.application")
   Set objFolder = objShell.Namespace(sFolder)
   Set objFolderItem = objFolder.ParseName(sFile)
   
    GetName = objFolder.GetDetailsOf(objFolderItem, 21)

    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing

End Function