Sub SetContactPictureForSpecificCompany()
    Dim objContact As Outlook.ContactItem
    Dim objContacts As Outlook.Items
    Dim strPicturePath As String
    Dim strCompany As String
    
    ' Nastavte cestu k obrázku, který chcete použít
    strPicturePath = "C:\Users\Robin\Pictures\group\SPOL.png"
    
    ' Nastavte název společnosti, kterou chcete vyhledat
    strCompany = "SPOLEČNOST a.s."
    
    ' Získejte přístup k aktuální složce kontaktů
    Set objContacts = Application.ActiveExplorer.CurrentFolder.Items
    
    ' Pro každý kontakt v seznamu kontaktů
    For Each objContact In objContacts
        If TypeName(objContact) = "ContactItem" Then
            ' Zkontrolujte, zda pole Společnost obsahuje požadovaný řetězec
            If InStr(1, objContact.CompanyName, strCompany, vbTextCompare) > 0 Then
                ' Nastavte profilový obrázek
                objContact.AddPicture (strPicturePath)
                objContact.Save
            End If
        End If
    Next
End Sub