Sub BILD_1_Filter()

If MsgBox("Are You sure?", 64 + vbYesNo, "Message!") = vbYes Then

' Bild 1...................................................
On Error Resume Next
    Set rngPics = Range("A2:A10000")
    Set rngOut = Range("A2:A10000")
    rngOut.ClearComments
    For i = 1 To rngPics.Cells.Count
        If rngPics.Cells(i, 1).Value <> "" Then
            p = rngPics.Cells(i, 1).Value
            With rngOut.Cells(i, 1)
                .AddComment.Text Text:=""
                .Comment.Shape.Width = 200
                .Comment.Shape.Height = 200
                .Comment.Visible = True
                .Comment.Shape.Select True
            End With
            With rngOut.Cells(i, 1).Comment.Shape
                .Fill.UserPicture p
            End With
        End If
    Next i
    Application.DisplayCommentIndicator = xlCommentIndicatorOnly
    

      
    End If
End Sub

Sub download()
Application.DisplayAlerts = False
    
Dim csvURL As String
    csvURL = "http://haendlerportal.sit-moebel.de/csv/verfuegbarkeit.csv"
    DownloadBinaryFile csvURL, ThisWorkbook.Path & "\BL - Lieferanten\Bestand - SIT.csv", True
        
    csvURL = "http://haendlerportal.moebilia.de/csv/verfuegbarkeit.csv"
    DownloadBinaryFile csvURL, ThisWorkbook.Path & "\BL - Lieferanten\Bestand - Mцbilia.csv", True
    
    csvURL = "http://skyport.myapix.de/export/exportListing.php?id=8236646963963"
    DownloadBinaryFile csvURL, ThisWorkbook.Path & "\BL - Lieferanten\Bestand - Skyport.csv", True
    

            If i Mod Int(iLoopCount * 0.02) = 0 Then Call UpdateProgress(i / iLoopCount)
            If bCancel Then
                MsgBox "Процесс прерван пользователем !", vbExclamation
                Exit Sub
            End If

    ProgressForm.Hide
    MsgBox "Процесс успешно завершен !", vbInformation       
End Sub

Private Sub UpdateProgress(Pct As Double)
    With ProgressForm
        .FrameProgress.Caption = Format(Pct, "0%")
        .LabelProgress.Width = Pct * (.FrameProgress.Width - 10)
        .Repaint
    End With
End Sub

Function GetPictureSize(sPath As String, sFileName As String)
    Dim objFile As Object, sPictureSize As String, sFS As String, sLS As String
    Dim lWidth As Long, lHeight As Long
     
    Set objFile = CreateObject("Shell.Application").Namespace(CVar(sPath)).ParseName(sFileName)
    sPictureSize = objFile.ExtendedProperty("Dimensions")
    sFS = Left$(sPictureSize, 1)
    sLS = Right$(sPictureSize, 1)
 
    sPictureSize = Mid$(sPictureSize, 2, Len(sPictureSize) - 2)
    lWidth = Val(sPictureSize)
    lHeight = Val(Mid$(sPictureSize, InStr(sPictureSize, "x") + 1))
  
    GetPictureSize = Array(lWidth, lHeight)
End Function


Sub DateiInfos()
Dim objFSO         As Object
Dim objOrdner      As Object
Dim objDatei       As Object
Dim i              As Integer
Dim pic            As Picture
Dim aPicSize
'Hier Pfad anpassen
  
Const Pfad = "C:\Users\Computer\Desktop\DONT TOUCH\sit_bilder\"
  
i = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.GetFolder(Pfad)
  
With ThisWorkbook.Worksheets("Tabelle1")

    .Range("A1:C1") = Array("Name", "Breite", "Hohe")
       
    On Error Resume Next
    For Each objDatei In objOrdner.Files
        .Cells(i, 1) = objDatei.Name
        aPicSize = GetPictureSize(Pfad, objDatei.Name)
        .Cells(i, 2) = aPicSize(0)
        .Cells(i, 3) = aPicSize(1)
        i = i + 1
    Next
    .Columns("A:C").AutoFit
End With
End Sub

.Range("A1:C1") = Array("Name", "Breite", "Hohe", "Size")

s = GetPictureSize(Pfad, objDatei.Name)

Sub DateiInfos()
Dim objFSO         As Object
Dim objOrdner      As Object
Dim objDatei       As Object
Dim i              As Integer
Dim pic            As Picture

'Hier Pfad anpassen

Const Pfad = "C:\Users\alexa\Desktop\files\BK\Hauptbilder\"

i = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOrdner = objFSO.GetFolder(Pfad)

With ThisWorkbook.Worksheets("Tabelle3")
    .Range("A1:E3000").ClearContents
    .Range("A1:C1") = Array("Name", "Breite", "Hцhe")
     
On Error Resume Next
   
    For Each objDatei In objOrdner.Files
    Set pic = .Pictures.Insert(Pfad & objDatei.Name)
        .Cells(i, 1) = objDatei.Name
        .Cells(i, 2) = pic.Width
        .Cells(i, 3) = pic.Height
        i = i + 1
    Next
    .Pictures.Delete
    .Columns("A:C").AutoFit
End With
End Sub