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

Option Explicit

Function GetNumber(strText As Variant, sVariable As String) As Variant

Dim oRegex As Object, oMatches As Object, oM As Object
Dim vValue As Variant

Set oRegex = CreateObject("VBScript.Regexp")

'Wynajduje liczby oraz łańcuchy tekstowe przed którymi jest nazwa zmiennej i znak równości
oRegex.Pattern = "(" & sVariable & "=" & ")" & _
    "(\d+(?:[\.\,]\d+)?|$|\s)"

'wyszukuje wszystkie ciagi znaków spelniajace warunek
oRegex.Global = True

Set oMatches = oRegex.Execute(strText)

Select Case True
    Case oMatches.Count = 1
        If oMatches(0).submatches.Count = 2 Then
            vValue = oMatches(0).submatches(1)
        Else
            vValue = ""
        End If
        
        If IsNumeric(vValue) Then GetNumber = CDbl(vValue) Else GetNumber = vValue
        
    Case oMatches.Count = 0
        GetNumber = "[#NM]"
    Case oMatches.Count > 1
        GetNumber = "[#O]"
End Select

Set oRegex = Nothing
Set oMatches = Nothing

End Function

Sub PodajWartosc()

   MsgBox GetNumber("Wartość X=1050", "X")

End Sub

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Do Until GetAsyncKeyState(vbKeyEscape) <> 0
     '..... tutaj operacje w pętli
     DoEvents
Loop