• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kodu Revize Etmek İçin Yardım

B

BedriA

Katılım
3 Haziran 2017
Mesajlar
797
Excel Vers. ve Dili
2007, 32
Arkadaşlar,

Aşağıdaki kod ile belli bir klasörden D hücresine ismini girdiğim resim aynı satırın E hücresine geliyor.

Ben bu kod ile aynı zamanda F hücresine resim ismi girdiğimde, G hücresine de resim gelsin istiyorum.


Not: Kod forumdan alıntıdır. Kod sayfanın kod bölümünde.
Kodun çalışması için C diskinde Sorular isimli bir resim kalsörü ve klasördeki resimlerin formatının .jpg olması gerekir.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [D:D]) Is Nothing Then Exit Sub
Dim p As Object, t As Double, l As Double, w As Double, h As Double


ResimDosya = "C:\Azmun\Sorular5" & "\" & Target.Value & ".jpg"

On Error Resume Next
If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)

With Cells(Target.Row, Target.Column + 1)
    t = .Top
    l = .Left
    w = .Offset(0, .Columns.Count).Left - .Left
    h = .Offset(.Rows.Count, 0).Top - .Top
End With

With p
    .Top = t
    .Left = l
    .Width = w
    .Height = h
End With

Set p = Nothing


End Sub
 
Son düzenleme:
Aşağıdaki şekilde deneyin.
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [D:D]) Is Nothing Then
Dim p As Object, t As Double, l As Double, w As Double, h As Double


ResimDosya = "C:\Azmun\Sorular5" & "\" & Target.Value & ".jpg"

On Error Resume Next
If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)

With Cells(Target.Row, Target.Column + 1)
    t = .Top
    l = .Left
    w = .Offset(0, .Columns.Count).Left - .Left
    h = .Offset(.Rows.Count, 0).Top - .Top
End With

With p
    .Top = t
    .Left = l
    .Width = w
    .Height = h
End With

Set p = Nothing

ElseIf Intersect(Target, [F:F]) Is Nothing Then
'Dim p As Object, t As Double, l As Double, w As Double, h As Double


ResimDosya = "C:\Azmun\Sorular5" & "\" & Target.Value & ".jpg"

On Error Resume Next
If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)

With Cells(Target.Row, Target.Column + 1)
    t = .Top
    l = .Left
    w = .Offset(0, .Columns.Count).Left - .Left
    h = .Offset(.Rows.Count, 0).Top - .Top
End With

With p
    .Top = t
    .Left = l
    .Width = w
    .Height = h
End With

Set p = Nothing
End If
End Sub
 
Kod: 
If Intersect(Target, [[COLOR="Red"]D:D,F:F[/COLOR]]) Is Nothing Then Exit Sub


Alternatif kod bu kod aynı hücreye birden fazla resim eklerken ilkini siler ve bir kaç çeşit uzantılı resimleri ekler

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [[COLOR="Red"]D2:D100,F2:F100[/COLOR]]) Is Nothing Then Exit Sub
yatay = 1 ' bu kadar hücre sağa kayacak
dikey = 0  ' bu kadar hücre aşağıya kayacak
Dim s1
Set s1 = Sheets(ActiveSheet.Name)
If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") = 0 Then
Set Adres = s1.Cells(Target.Row + dikey, Target.Column + yatay)

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

Set yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column)
If yer.Address = Adres.Address Then
Picture.Delete
Exit For
End If
End If
Next Picture

ReDim uzanti(11)
uzanti(1) = "bmp":        uzanti(2) = "jpg"
uzanti(3) = "gif":        uzanti(4) = "pcx"
uzanti(5) = "jpeg"

For j = 1 To 5

Dosya = "C:\Azmun\Sorular5" & "\" & Target.Value & "." & uzanti(Val(j))

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
's1.Shapes.AddPicture Dosya, msoFalse, msoCTrue, Range(Adres).Left + 2, Range(Adres).Top + 2, Range(Adres).Width - 4, Range(Adres).Height - 4
ad = s1.Pictures.Insert(Dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse

s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 2
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 2
s1.Shapes(ad).OLEFormat.Object.Name = Target.Address
s1.Cells(Target.Row + 1, Target.Column).Select

Exit For
End If
Next

End If
End Sub
 
askm' Alıntı:
Aşağıdaki şekilde deneyin.
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [D:D]) Is Nothing Then
Dim p As Object, t As Double, l As Double, w As Double, h As Double


ResimDosya = "C:\Azmun\Sorular5" & "\" & Target.Value & ".jpg"

On Error Resume Next
If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)

With Cells(Target.Row, Target.Column + 1)
    t = .Top
    l = .Left
    w = .Offset(0, .Columns.Count).Left - .Left
    h = .Offset(.Rows.Count, 0).Top - .Top
End With

With p
    .Top = t
    .Left = l
    .Width = w
    .Height = h
End With

Set p = Nothing

ElseIf Intersect(Target, [F:F]) Is Nothing Then
'Dim p As Object, t As Double, l As Double, w As Double, h As Double


ResimDosya = "C:\Azmun\Sorular5" & "\" & Target.Value & ".jpg"

On Error Resume Next
If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)

With Cells(Target.Row, Target.Column + 1)
    t = .Top
    l = .Left
    w = .Offset(0, .Columns.Count).Left - .Left
    h = .Offset(.Rows.Count, 0).Top - .Top
End With

With p
    .Top = t
    .Left = l
    .Width = w
    .Height = h
End With

Set p = Nothing
End If
End Sub
Genişletmek için tıkla ...

Çok teşekkür ederim.
 
halit3' Alıntı:
Kod: 
If Intersect(Target, [[COLOR="Red"]D:D,F:F[/COLOR]]) Is Nothing Then Exit Sub


Alternatif kod bu kod aynı hücreye birden fazla resim eklerken ilkini siler ve bir kaç çeşit uzantılı resimleri ekler

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [[COLOR="Red"]D2:D100,F2:F100[/COLOR]]) Is Nothing Then Exit Sub
yatay = 1 ' bu kadar hücre sağa kayacak
dikey = 0  ' bu kadar hücre aşağıya kayacak
Dim s1
Set s1 = Sheets(ActiveSheet.Name)
If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") = 0 Then
Set Adres = s1.Cells(Target.Row + dikey, Target.Column + yatay)

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

Set yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column)
If yer.Address = Adres.Address Then
Picture.Delete
Exit For
End If
End If
Next Picture

ReDim uzanti(11)
uzanti(1) = "bmp":        uzanti(2) = "jpg"
uzanti(3) = "gif":        uzanti(4) = "pcx"
uzanti(5) = "jpeg"

For j = 1 To 5

Dosya = "C:\Azmun\Sorular5" & "\" & Target.Value & "." & uzanti(Val(j))

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
's1.Shapes.AddPicture Dosya, msoFalse, msoCTrue, Range(Adres).Left + 2, Range(Adres).Top + 2, Range(Adres).Width - 4, Range(Adres).Height - 4
ad = s1.Pictures.Insert(Dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse

s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 2
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 2
s1.Shapes(ad).OLEFormat.Object.Name = Target.Address
s1.Cells(Target.Row + 1, Target.Column).Select

Exit For
End If
Next

End If
End Sub
Genişletmek için tıkla ...

Halit Hocam,

İkincisinin ilkini silme olayı çok güzel oldu.
Çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst