veriye ait foto

[metin_0606]

C:\ nin içinde FOTO isimli klasörün içinde TC kimlik numaraları ile isimlendirilmiş 8000 adet JPG formatında foto var. Benim yapmak istediğim personele ait verileri tuttuğum ANA SAYFA isimli sayfada yön tuşları yada fare ile personelin isminin üzerine geldiğimde personelin resmi görünsün istiyorum. Bunu makro ile nasıl yapabiliriz. Saygılar

 

[metin_0606]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Target.Column = 3 Then
Image1.PictureSizeMode = fmPictureSizeModeStretch
Image1.Top = Target.Offset(0 + 1, 1).Top
Image1.Left = Target.Offset(0 + 1, 1).Left
If IsError(Range("D2").Value) Then
'Exit Sub
End If
If Dir$("C:\FOTO\" & Target.Offset(0, 4).Value & ".jpg") = "" Then
Image1.Visible = False
'Exit Sub
Else
Image1.Visible = True
Image1.Picture = LoadPicture("C:\FOTO\" & Target.Offset(0, 4) & ".jpg")
End If
Else
Image1.PictureSizeMode = fmPictureSizeModeStretch
Image1.Top = Target.Offset(0 + 1, 1).Top
Image1.Left = Target.Offset(0 + 1, 1).Left
If IsError(Range("D2").Value) Then
'Exit Sub
End If
If Dir$("C:\FOTO\" & Target.Offset(0, 5).Value & ".jpg") = "" Then
Image1.Visible = False
'Exit Sub
Else
Image1.Visible = True
Image1.Picture = LoadPicture("C:\FOTO\" & Target.Offset(0, 5) & ".jpg")
End If
End If
End sub
Böyle bir kod buldum ama listeme uyarlayamadım[/CODE]

 

[metin_0606]

Bu makroyu buldum ama kendime uyarlayamadım

 

[muygun]

Merhaba;
Sayfanın kod bölümüne;

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim hcr As Range
Dim c As Integer
Dim yuk As Double, gen As Double
Columns("c").ClearComments
If Intersect(Target, [b2:b15000]) Is Nothing Then Exit Sub
If Target.Count > 2 Then Exit Sub
With Cells(Target.Row, "c")
.AddComment
.Comment.Visible = True
.Comment.Shape.Select True
End With
On Error GoTo yok
Selection.ShapeRange.Fill.UserPicture "C:\FOTO\" & Cells(Target.Row, "b") & ".jpg"
Selection.Height = 150 'yuk
Selection.Width = 150 'gen
Exit Sub
yok:
Selection.Height = 150 'yuk
Selection.Width = 150 'gen
Selection.ShapeRange.Fill.UserPicture "C:\FOTO\ResimYok.jpg"
Cells(Target.Row, "b").Select
End Sub

Kodlarını ekleyip deneyin.
İyi çalışmalar.

Not: Resim yoksa gösterilecek resmi ResimYok adı ve jpg formatıyla FOTO klasörüne ekleyin.

 

[metin_0606]

Merhaba;
Sayfanın kod bölümüne;

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim hcr As Range
Dim c As Integer
Dim yuk As Double, gen As Double
Columns("c").ClearComments
If Intersect(Target, [b2:b15000]) Is Nothing Then Exit Sub
If Target.Count > 2 Then Exit Sub
With Cells(Target.Row, "c")
.AddComment
.Comment.Visible = True
.Comment.Shape.Select True
End With
On Error GoTo yok
Selection.ShapeRange.Fill.UserPicture "C:\FOTO\" & Cells(Target.Row, "b") & ".jpg"
Selection.Height = 150 'yuk
Selection.Width = 150 'gen
Exit Sub
yok:
Selection.Height = 150 'yuk
Selection.Width = 150 'gen
Selection.ShapeRange.Fill.UserPicture "C:\FOTO\ResimYok.jpg"
Cells(Target.Row, "b").Select
End Sub

Kodlarını ekleyip deneyin.
İyi çalışmalar.

Not: Resim yoksa gösterilecek resmi ResimYok adı ve jpg formatıyla FOTO klasörüne ekleyin.

Sayın muygun teşekkür ederim yön tuşları ilede resmi göstermemiz mümkünmü acaba