Değer Değiştirme Düğmesi veya Liste Kutusuna Bağlı MAKRO çalışmıyor.
:yardim: Arkadaşlar Benim Sorum Şu
Personel Listesi var ve Bu Personelin Bilgilerini Dosya numarasını Bir Hücreye Girip ENTER tuşuna Basarak Ad, Soyad, Resim Vb. ÇAĞIRA BİLİYORUM Yanlız O dosya numarasını bir liste kutusundan veya başka hücreden Değer değiştirme düğmelerinden değiştirdim de makro yenilenmiyor zaten o makroda personel resimlerini göstermek için araştırdım bulamdaım bir kaç kişi sormuş cevap alamamış sizden ricam bu satırlara ne eklesem düzelir .
AH4: Dosya Numarası kısaca bu hücredeki değeri başka yerden aldındada kişi resmi gelsim. Umarım anlatabilmişimdir..
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Resim As OLEObject
Dim Yeni_Resim As OLEObject
Dim Adres As Range
Dim Dosya_Yolu As String
Dim Resim_Adı As String
If Intersect(Target, [AH4]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Dosya_Yolu = ThisWorkbook.Path & "\Resimler\"
Resim_Adı = Target.Value & ".jpg"
Set Adres = Range(Target.Offset(0, -3).Address, Target.Offset(5, -6).Address)
If ActiveSheet.Shapes.Count > 0 Then
For Each Resim In ActiveSheet.OLEObjects
If Not Intersect(Range(Resim.TopLeftCell.Address & ":" & Resim.BottomRightCell.Address), Adres) Is Nothing Then
Resim.Delete
End If
Next
End If
If Dir(Dosya_Yolu & Resim_Adı) <> "" Then
Set Yeni_Resim = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
DisplayAsIcon:=False, Left:=Adres.Left, Top:=Adres.Top, Width:=Adres.Width, Height:=Adres.Height)
With Yeni_Resim
.Top = Adres.Top
.Left = Adres.Left
.Height = Adres.Height
.Width = Adres.Width
.Object.PictureSizeMode = fmPictureSizeModeStretch
End With
Yeni_Resim.Object.Picture = LoadPicture(Dosya_Yolu & Resim_Adı)
Else
MsgBox "resim yok"
'Yeni_Resim.Object.Picture = LoadPicture(Dosya_Yolu & Stok_Resmi_Yok.jpg")
End If
Application.ScreenUpdating = True
End Sub
:yardim: Arkadaşlar Benim Sorum Şu
Personel Listesi var ve Bu Personelin Bilgilerini Dosya numarasını Bir Hücreye Girip ENTER tuşuna Basarak Ad, Soyad, Resim Vb. ÇAĞIRA BİLİYORUM Yanlız O dosya numarasını bir liste kutusundan veya başka hücreden Değer değiştirme düğmelerinden değiştirdim de makro yenilenmiyor zaten o makroda personel resimlerini göstermek için araştırdım bulamdaım bir kaç kişi sormuş cevap alamamış sizden ricam bu satırlara ne eklesem düzelir .
AH4: Dosya Numarası kısaca bu hücredeki değeri başka yerden aldındada kişi resmi gelsim. Umarım anlatabilmişimdir..
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Resim As OLEObject
Dim Yeni_Resim As OLEObject
Dim Adres As Range
Dim Dosya_Yolu As String
Dim Resim_Adı As String
If Intersect(Target, [AH4]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Dosya_Yolu = ThisWorkbook.Path & "\Resimler\"
Resim_Adı = Target.Value & ".jpg"
Set Adres = Range(Target.Offset(0, -3).Address, Target.Offset(5, -6).Address)
If ActiveSheet.Shapes.Count > 0 Then
For Each Resim In ActiveSheet.OLEObjects
If Not Intersect(Range(Resim.TopLeftCell.Address & ":" & Resim.BottomRightCell.Address), Adres) Is Nothing Then
Resim.Delete
End If
Next
End If
If Dir(Dosya_Yolu & Resim_Adı) <> "" Then
Set Yeni_Resim = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
DisplayAsIcon:=False, Left:=Adres.Left, Top:=Adres.Top, Width:=Adres.Width, Height:=Adres.Height)
With Yeni_Resim
.Top = Adres.Top
.Left = Adres.Left
.Height = Adres.Height
.Width = Adres.Width
.Object.PictureSizeMode = fmPictureSizeModeStretch
End With
Yeni_Resim.Object.Picture = LoadPicture(Dosya_Yolu & Resim_Adı)
Else
MsgBox "resim yok"
'Yeni_Resim.Object.Picture = LoadPicture(Dosya_Yolu & Stok_Resmi_Yok.jpg")
End If
Application.ScreenUpdating = True
End Sub
Son düzenleme:
