aranan resim yoksa başka bir resim gostersin

[echobrain]

merhaba arkadaşlar benim bir konuda yardıma ihtiyacım var.yardım ederseniz cok sevinirim.

şimdi ben bir yine sizlerin yardımıyla bir makro yazdım.makro a1 hucresinde yolu yazan resmi getirmesini saglıyor.
şöyle :
Image1.PictureSizeMode = fmPictureSizeModeZoom
Image1.Picture = LoadPicture(['BİLGİLER'!A3])

benim istedegim yolda resim aranan resim yoksa gidip benim belirledigim bir resmi getirsin bunu nasıl yaparız.yardımlarınız için şimdiden çok teşekkur ederim

 

[hsayar]

Image1.PictureSizeMode = fmPictureSizeModeZoom
Image1.Picture = LoadPicture(['BİLGİLER'!A3])​

[LEFT]Sub ........()
.................
Image1.PictureSizeMode = fmPictureSizeModeZoom
Kaynak = ['BİLGİLER'!A3]
Set FSO = CreateObject("Scripting.FileSystemObject") 'Dosya kontorol objesine değer ata
If FSO.FileExists(Kaynak) = False Then 'Kaynak dosya var mı yokmu bak, yoksa
Image1.Picture = LoadPicture(['BİLGİLER'!A1]) 'makrodan çık
Else
Image1.Picture = LoadPicture(Kaynak)
End If
.....................
End Sub[/LEFT]

not: bilgiler A1 de varsayılan resim olduğu kabul edilmiştir bunun yerine siz kod içinde yol belirtip onuda değişkene atayabilrsiniz.​

 

[echobrain]

yardımınız için çok teşekkur ederim.benim bir sorum daha olacaktı ek te gonderdigim dosyada sizin yazdıgınız kod nasıl oluryor ben bunu uyarlayamadım da.incelerseniz sevinirim

 

[hsayar]

1) Aynı klasör altına bir adet yok.gif oluşturunuz....
2) Çalışma sayfasındaki İmage nesnelerini kaldırınız(Ax hücresinde açıklama eklenecek ve resim oraya verilecek) aşağıdaki kodları denermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b3:b1000]) Is Nothing Then Exit Sub       'Değişen Hücre B3:B1000 aralığında ise
If Target.Count > 1 Then Exit Sub                               'Seçili hücre sayısı 1 den büyük ise işlem iptal edilir.
Dim dsYol, Dosya, ActHcr As String                              'Değişkenler tanımlanır
Dim Fso As Object                                               ' ***

ActHcr = ActiveCell.Address                                     'Geilne hücre adresi sabitlenir.
    On Error Resume Next
    Target.Offset(0, -1).ClearComments                          'Solumzudaki hücredki açıklma kaldırılır.
    On Error GoTo 0
    If Target.Value = "" Then GoTo Son                          'Eğer Target (Bx) boşsa Son altprosodürüne geçilir.
[COLOR=Red]dsYol = "c:\Resim"  [/COLOR]        'ThisWorkbook.Path                  'Burada dosyanın bulunduğu klasör yer alır
'dsYol = ThisWorkbook.Path                  'Burada dosyanın bulunduğu klasör yer alır
Dosya = dsYol & "\s0" & Target.Value & ".gif"
 
Set Fso = CreateObject("Scripting.FileSystemObject")              'Dosya kontorol objesine değer ata
If Fso.FileExists(Dosya) = False Then Dosya = dsYol & "\yok.gif"  'belirtilen klasörde hedef ile eşleşne resim yok ise yok gifi alınır.
    
    With Target.Offset(0, -1)                                     'Solumzudaki hücreye
                .AddComment                                       'açıklama ekle
                .Comment.Visible = True                           ' Görünür olsun
                .Comment.Text Text:=" "                           ' içi boş olsun
                .Comment.Shape.Select True                        ' Metin kutusunu seç
    End With
    With Selection.ShapeRange
                        .Fill.UserPicture (Dosya)                 ''Dolgu olarak resim kullan
                        .IncrementLeft -189#                      'Mevcut sol konumunu deiştir.
                        .IncrementTop 6#                          'Mevcut üst konumunu deiştir.
                        .ScaleWidth 1.65, msoFalse, msoScaleFromTopLeft    'soldan-sağa ne kadar uzun
                        .ScaleHeight 2.04, msoFalse, msoScaleFromTopLeft   'üstten-aşağı ne kadar uzun
    End With
    
Son:
Set Fso = Nothing
Range(ActHcr).Select
End Sub

 

[echobrain]

size ne kadar teşekkur etsem azdır.gerçeten cok teşekkur ederim.cok işime yaradı çok sağolun

 

[hsayar]

afedersiniz rahatsız ediyorum ama başınıza bela oldum sanırım.bu yaptıgınız macro için cok teşekkur ederim ama bu resimleri c:\resim klasorunden nasıl alacagız dosya kontorola deger ata demişsiniz ama yapamadım.yardım ederseniz çok sevinirim

estağfurullah...

4. mesajada istediğiniz şekilde kodları düzelltim. ayrıca bayağı bşr saçmalamışıkm kodlard onu farketim yeniden düzenledim.

 

[echobrain]

cok teşşekkur ederim.oldu gerçekten ama sadece bir problemin kaldı ben bunları printerden nasıl çıktı alacagım açıklama oldugu için gozukmuyor.bu yolu var mı bunun

 

[hsayar]

Eklenen açıklmamanın nesne yazdır özelliği bildiğim kadarıyla yok metin kutusu kullanmayı deneyecem.... ama bilmem gereken bir şey var
bu arada gizli hücre kullanacak veya bir hücrenin yüksekliği diğerlerinden farklı olacaksa çalışamaa ihtimali var.

 

[echobrain]

size zahmet oluyor ama aynı açıklama yaptıgınız metinler gibi resimlerin boyutu aynı olmasını istiyorum tabi mumkunse

 

[hsayar]

Sizin için araştırdım ve Sn Ferhat PAzarçevirdi hocamdan Hücre Açıklamayla kamufle etmeyi öğrendim.

Sn. Adminleirmiz başlık olarak: Hücre Dolgu Rengi Olarak Resim Dosyası Kullanma diyerek düzeltirlerse daha çok kişinin faydalanacağına inanıyorum

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b3:b1000]) Is Nothing Then Exit Sub       'Değişen Hücre B3:B1000 aralığında ise
If Target.Count > 1 Then Exit Sub                               'Seçili hücre sayısı 1 den büyük ise işlem iptal edilir.
Dim dsYol, Dosya, ActHcr As String                              'Değişkenler tanımlanır
Dim Fso As Object                                               ' ***
Dim oAck As Comment
Dim oHcr As Range
Set oHcr = Target.Offset(0, -1)
ActHcr = ActiveCell.Address                                     'Geilne hücre adresi sabitlenir.
    On Error Resume Next
    oHcr.ClearComments                          'Solumzudaki hücredki açıklma kaldırılır.
    On Error GoTo 0
    If Target.Value = "" Then GoTo Son                          'Eğer Target (Bx) boşsa Son altprosodürüne geçilir.
'dsYol = "c:\Resim"          'ThisWorkbook.Path                  'Burada dosyanın bulunduğu klasör yer alır
dsYol = ThisWorkbook.Path                  'Burada dosyanın bulunduğu klasör yer alır
Dosya = dsYol & "\s0" & Target.Value & ".gif"

Set Fso = CreateObject("Scripting.FileSystemObject")              'Dosya kontorol objesine değer ata
If Fso.FileExists(Dosya) = False Then Dosya = dsYol & "\yok.gif"  'belirtilen klasörde hedef ile eşleşne resim yok ise yok gifi alınır.
    
    
Set oAck = oHcr.AddComment
With oAck
     .Text Text:=" "
      With .Shape
           .Left = oHcr.Left
           .Top = oHcr.Top
           .Width = oHcr.Width
           .Height = oHcr.Height
           .Fill.UserPicture (Dosya)
'           .Placement = xlMoveAndSize
'           .PrintObject = True
      End With
     .Visible = True
End With

   oHcr.Comment.Shape.Select True
    With Selection
        .Placement = xlMoveAndSize
        .PrintObject = True
    End With
Son:
Set oHcr = Nothing
Set oAck = Nothing
Set Fso = Nothing
Range(ActHcr).Select
End Sub

Buda Açıklamalar Yazdırılsın dediğimniz için Çözüm yöntemi:
Dosya>Sayfa yapısı (Gerisi Zaten belli)

 

[echobrain]

cok teşekkuer ederim size ne kadar teşekkur etsem azdır.

 

[hsayar]

rica ederim sizin sorunuz sayesinde bana da bir gün lazım olacak bir şey öğrendim.