Buton Sabitleme- Yeniden getirme

[semih001]

selamlar;

çalışma Sayfası yenilendiğinde eklediğim buton kayboluyor. Sayfa yenilendiğinde makro atadığım buton kaybolmasın ya da yeniden gelsin istiyorum. Sayfadaki diğer makro resim getirme makrosu. Yardımcı olabilirseniz sevinirim.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ResimYolu As String
If Not Intersect(Target, [E3]) Is Nothing Then
DrawingObjects.Delete
ResimYolu = ActiveWorkbook.Path & "\" & Range("E3")

If Dir(ResimYolu & ".jpg") <> "" Then
ResimYolu = ResimYolu & ".jpg"
ElseIf Dir(ResimYolu & ".png") <> "" Then
ResimYolu = ResimYolu & ".png"
Else
MsgBox "'" & Range("E3") & "' adlı resim bulunamıyor." & vbLf & "Lütfen kontrol edip yeniden deneyiniz."
Exit Sub
End If

Set resim = Pictures.Insert(ResimYolu)
With Range("H5:I14")
resim.ShapeRange.LockAspectRatio = msoFalse
resim.Top = .Top
resim.Left = .Left
resim.Height = .Height
resim.Width = .Width
End With
End If
End Sub

 

[semih001]

Elimde bir de bu kod var ancak düzenleyemedim

Private Sub Worksheet_Change(ByVal Target As Range)
Dim btn As Button
For Each btn In Me.Buttons
btn.Delete
Next btn
Set btn = Me.Buttons.Add(Left:=100, Top:=50, Width:=100, Height:=30)
With btn
.Caption = "Yeni Buton"
.OnAction = " Butonun çalıştıracağı MakroAdı"
End With
End Sub

 

[Biolightant]

Merhaba,

resim.Width = .Width satırının altına aşşağıda ki satırı ekleyiniz.

resim.OnAction = "MakroIsmi"

 

[semih001]

Merhaba,

resim.Width = .Width satırının altına aşşağıda ki satırı ekleyiniz.

resim.OnAction = "MakroIsmi"

selamlar, denedim fakat sonuç alamadım. Buton yine kayboluyor.

 

[Biolightant]

E3 hücresin de bir değişiklik olduğun da
Excel kitabının kayıtlı olduğu dosya yolunda
E3 hücresi Değeri(Value) ile aynı Ad da jpg veya png dosyası var ise
Bu image dosyasını sayfanın H5:I14 hücrelerinin olduğu yeri kaplayacak şeklinde yerleştiriyor
Ve bu image tıklanınca istediğiniz makro çalışıyor (image button a dönüştü)

Bu butondan mı bahsediyorsunuz ?
isteginiz bu ise sizin kodlarınızda revizeye göre çalışıyor

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ResimYolu As String
If Not Intersect(Target, [E3]) Is Nothing Then
DrawingObjects.Delete
ResimYolu = ActiveWorkbook.Path & "\" & Range("E3")

If Dir(ResimYolu & ".jpg") <> "" Then
ResimYolu = ResimYolu & ".jpg"
ElseIf Dir(ResimYolu & ".png") <> "" Then
ResimYolu = ResimYolu & ".png"
Else
MsgBox "'" & Range("E3") & "' adlı resim bulunamıyor." & vbLf & "Lütfen kontrol edip yeniden deneyiniz."
Exit Sub
End If

Set resim = Pictures.Insert(ResimYolu)
With Range("H5:I14")
resim.ShapeRange.LockAspectRatio = msoFalse
resim.Top = .Top
resim.Left = .Left
resim.Height = .Height
resim.Width = .Width
resim.OnAction = "MakroIsmi" ' kendi makronuzun ismini yazacaksınız.
End With
End If
End Sub

 

[Biolightant]

Sanırım sorun Sayfada bulunan başka buton ve image ların yok olması
bu sefer sorunu doğru anladıysam

Problem DrawingObjects.Delete satından kaynaklanmakta, sayfada ki tüm nesneleri yok ediyor.
En kolay çözüm sayfaya ekleyeceğimiz nesne ye Ad(name) verip istediğimiz zaman kolayca yakalamak ( Bu kodlarda ImageE3 tanımlandım )

Private Sub Worksheet_Change(ByVal Target As Range)
 
    If Target.Address = "$E$3" Then

        ' Resim yolu belirleme
        Dim ResimYolu As String
        ResimYolu = ActiveWorkbook.Path & "\" & Target.Value

        ' Resim uzantısı kontrolü
        If Dir(ResimYolu & ".jpg") <> "" Then
            ResimYolu = ResimYolu & ".jpg"
        ElseIf Dir(ResimYolu & ".png") <> "" Then
            ResimYolu = ResimYolu & ".png"
        Else
            MsgBox "'" & Range("E3").Value & "' adlı resim bulunamıyor." & vbLf & "Lütfen kontrol edip yeniden deneyiniz."
            Exit Sub
        End If

        ' Eski fotoğraf varsa sil
        On Error Resume Next
            ActiveSheet.Shapes("ImageE3").Delete
        On Error GoTo 0

        ' Yeni resmi ekle
        Dim resim As Object
        Set resim = ActiveSheet.Pictures.Insert(ResimYolu)

        ' Resmi biçim,konum ve AD ayarla
        With Range("H5:I14")
            resim.ShapeRange.LockAspectRatio = msoFalse
            resim.Top = .Top
            resim.Left = .Left
            resim.Height = .Height
            resim.Width = .Width
            resim.Name = "ImageE3"
        End With
     
    End If
 
End Sub