Bilgi ve resim getirerk yazdırmada hata

[mars2]

İyi Günler;
Çalşıma kitabımda "Liste" ve "bilgiformu" sayfaları bulunmaktadır.
bilgi formu sayfasındaki forma listeden bilgileri getirmekte ve yazdırma işlemini yapmaktaydım ancak; sayfaya image ekleyerek,

On Err GoTo sonhata1

Dim sut As Integer
Dim sat As Integer


sut = Selection.Cells.Column
sat = Selection.Cells.Row


Image1.PictureSizeMode = fmPictureSizeModeStretch

If IsError(Range("D" & sat).Value) Then
Exit Sub
End If

If Dir$(ThisWorkbook.Path & "\Resimler\" & Range("D" & sat).Value & ".jpg") = "" Then


Image1.Visible = False

Exit Sub



Else
Image1.Visible = True
Image1.Picture = LoadPicture(ThisWorkbook.Path & "\Resimler\" & Range("D" & sat) & ".jpg")

End If


Exit Sub
sonhata1:
Exit Sub
Resume
kodu ekleyince hata vermekte, hem bilgileri ve aynı anda resmi alamıyorum.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

On Err GoTo sonhata1

Dim sut As Integer
Dim sat As Integer


sut = Selection.Cells.Column
sat = Selection.Cells.Row


Image1.PictureSizeMode = fmPictureSizeModeStretch

If IsError(Range("D" & sat).Value) Then
Exit Sub
End If

If Dir$(ThisWorkbook.Path & "\Resimler\" & Range("D" & sat).Value & ".jpg") = "" Then


Image1.Visible = False

Exit Sub



Else
Image1.Visible = True
Image1.Picture = LoadPicture(ThisWorkbook.Path & "\Resimler\" & Range("D" & sat) & ".jpg")

End If


Exit Sub
sonhata1:
Exit Sub
Resume


On Error Resume Next
If Intersect(Target, [D7]) Is Nothing Then Exit Sub
If Target.Value = Empty Then Exit Sub
Set s1 = Sheets("bilgiformu")
Set s2 = Sheets("Liste")

Range("D2123").ClearContents

For Each bul In s2.Range("B5:B5000")
If bul = Target.Value Then sat = bul.Row
Next
If sat = "" Then
MsgBox "ARADIĞINIZ TAŞINMAZ NO BULUNAMADI.", vbInformation, "BİLGİ"

Exit Sub
End If
s1.Cells(9, "D").Value = s2.Cells(sat, "D").Value
s1.Cells(10, "D").Value = s2.Cells(sat, "E").Value
s1.Cells(11, "D").Value = s2.Cells(sat, "F").Value
s1.Cells(12, "D").Value = s2.Cells(sat, "G").Value

Set s1 = Nothing
Set s2 = Nothing

Dim a As Variant
Dim Yazıcı As String

If MsgBox("YAZDIRMA İŞLEM YAPILACAK MI?", vbYesNo + 32, "DİKKAT !") = vbNo Then

Else
Yazıcı = Application.Dialogs(xlDialogPrinterSetup).Show
a = InputBox("KAÇ ADET GEREKLİ?", "TAKİP CETVELİ", "")
If a = Empty Or a = 0 Then Exit Sub

If IsNumeric(a) And a <> vbNullString Then

ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

End If
End If

End Sub

Yardımlarınız için şimdiden teşekkür ederim.

 

[systran]

Resimlerin olduğu klasöre bir tane "Noimage.jpg" adında olmayan resimleri temsilen boş bir resim dosyası atıp, şu kodları deneyiniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Err GoTo sonhata1

Dim sut As Integer
Dim sat As Integer
 
sut = Selection.Cells.Column
sat = Selection.Cells.Row
  
Image1.PictureSizeMode = fmPictureSizeModeStretch

If IsError(Range("D" & sat).Value) Then
    Exit Sub
End If

If Dir$(ThisWorkbook.Path & "\Resimler\" & Range("D" & sat).Value & ".jpg") = "" Then
    Image1.Picture = LoadPicture(ThisWorkbook.Path & "\Resimler\Noimage.jpg")
Else
    Image1.Picture = LoadPicture(ThisWorkbook.Path & "\Resimler\" & Range("D" & sat) & ".jpg")
End If
Image1.Visible = True
sonhata1:
   

On Error Resume Next
If Intersect(Target, [D7]) Is Nothing Then Exit Sub
If Target.Value = Empty Then Exit Sub
Set s1 = Sheets("bilgiformu")
Set s2 = Sheets("Liste")

Range("D21:D23").ClearContents
sat = 0
For Each bul In s2.Range("B5:B5000")
    If bul = Target.Value Then sat = bul.Row
Next

If sat = 0 Then
    MsgBox "ARADIĞINIZ TAŞINMAZ NO BULUNAMADI.", vbInformation, "BİLGİ"
End If

s1.Cells(9, "D").Value = s2.Cells(sat, "D").Value
s1.Cells(10, "D").Value = s2.Cells(sat, "E").Value
s1.Cells(11, "D").Value = s2.Cells(sat, "F").Value
s1.Cells(12, "D").Value = s2.Cells(sat, "G").Value

Set s1 = Nothing
Set s2 = Nothing

Dim a As Variant
Dim Yazıcı As String

If MsgBox("YAZDIRMA İŞLEM YAPILACAK MI?", vbYesNo + 32, "DİKKAT  !") = vbYes Then
    Yazıcı = Application.Dialogs(xlDialogPrinterSetup).Show
    a = InputBox("KAÇ ADET GEREKLİ?", "TAKİP CETVELİ", "")
    If a = Empty Or a = 0 Then
        MsgBox "Yazdırma işlemi iptal edildi."
        Exit Sub
    End If

    If IsNumeric(a) And a <> vbNullString Then
        ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
    End If
End If

End Sub

yok illaki olmayan resimler görünmesin istiyorsanız yukarıdaki kodda şu düzeltmeyi yapınız.

If Dir$(ThisWorkbook.Path & "\Resimler\" & Range("D" & sat).Value & ".jpg") = "" Then
   [B][COLOR="Red"] image1.visible=false[/COLOR][/B]
Else
    Image1.Picture = LoadPicture(ThisWorkbook.Path & "\Resimler\" & Range("D" & sat) & ".jpg")
End If
[B][COLOR="Red"]'Image1.Visible = True[/COLOR][/B]
sonhata1:

ayrıca şu konuyu da inceleyiniz.
http://www.excel.web.tr/f136/personel-resim-gosterme-rnekleri-t22790.html

 

[mars2]

Sayın systran;
İlginize teşekkürler. yukarıda gönderdiğim örnekte çalışmakta ancak, uygulamanın yapıldığı excel kitabında Run time error 5 invalid procedure call or argument hatası vermektedir. Neden kaynakmış olabilir.

 

[systran]

VBA editöründe Tools-> references kısmında mising yazan referans var mı kontrol edin.

 

[mars2]

VBA editöründe Tools-> references kısmında mising yazan refarns yok

 

[systran]

o zaman uygulamanın kendisini yükleyin, hatayı görelim.