• DİKKAT

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

Hücreye eklenen fotoğrafın ölçülerinin otomatik ayarlanması ve köprü atama

  • Konbuyu başlatan Konbuyu başlatan DMR 7
  • Başlangıç tarihi Başlangıç tarihi
DMR 7

DMR 7

Katılım
14 Eylül 2017
Mesajlar
129
Excel Vers. ve Dili
2016 / Tr
Excelde hücrelere fotoğraf ekleyip daha sonra fotoğrafı "en" boyutlarına göre o hücreye sığdırıyorum. ve hücreye eklediğim bu küçük fotoğrafa, fotoğrafın kendisini köprü olarak ekliyorum.


hücreye eklenecek fotoğraf için, hücreye "en" boyutlarında sığdırma ve otomatik köprü oluşturmayı sağlayacak bir makro yazılabilir mi?
 
ben makro kaydet ile birkaç şey denedim. bunu if - else olarak nasıl çevirebilirim.

yani bir hücreye resim eklersem, resmin "En" boyutunu şu yap ve eklediğim resmin köprüsünü ata diye.

Kod: 
ActiveSheet.Pictures.Insert("C:\Users\DMR\Desktop\Örnek\IMG.JPG").Select
Selection.ShapeRange.Width = Selection.ColumnWidth * 5.4
'Selection.ShapeRange.Width = 160.157480315
'Selection.ColumnWidth * 5.4 --> bunu deneyerek ben hesapladım. sütun genişliğini 5.4 ile çarpar isek, eklenen resmin "EN" boyutu hücre enine eşit oluyor.
 ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:= _
        "IMG.JPG"
 
Örnek dosyanız olsa daha kolay işlem yapılır.
 
DMR 7;

Bilgisayarımda eski bir dosyada bulduğum kod işinize yarayabilir.

Bu kod, seçeceğiniz resmi A2 hücresine en ve boy olarak bire bir sığdıracaktır.

A2 hücresini istediğiniz boyuta getirin, daha sonra kodu çalıştırın....

Kod: 
Sub InsertPicture2()
    '
    ' Haluk ® - 31/07/08
    '
    '
    Dim MyRng As Range
    On Error Resume Next
        ActiveSheet.Shapes("MyPicture").Delete
    On Error GoTo 0
    
    Set MyRng = ActiveSheet.Range("A2")
    PicFile = Application.GetOpenFilename("Resim dosyası (*.jpg), *.jpg")
    PicTop = MyRng.Top
    PicLeft = MyRng.Left
    PicW = MyRng.Width
    PicH = MyRng.Height
    
    Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
    MyPic.Name = "MyPicture"
End Sub
 
Haluk' Alıntı:
DMR 7;

Bilgisayarımda eski bir dosyada bulduğum kod işinize yarayabilir.

Bu kod, seçeceğiniz resmi A2 hücresine en ve boy olarak bire bir sığdıracaktır.

A2 hücresini istediğiniz boyuta getirin, daha sonra kodu çalıştırın....

Kod: 
Sub InsertPicture2()
    '
    ' Haluk ® - 31/07/08
    '
    '
    Dim MyRng As Range
    On Error Resume Next
        ActiveSheet.Shapes("MyPicture").Delete
    On Error GoTo 0
    
    Set MyRng = ActiveSheet.Range("A2")
    PicFile = Application.GetOpenFilename("Resim dosyası (*.jpg), *.jpg")
    PicTop = MyRng.Top
    PicLeft = MyRng.Left
    PicW = MyRng.Width
    PicH = MyRng.Height
    
    Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
    MyPic.Name = "MyPicture"
End Sub
Genişletmek için tıkla ...


hocam kod sayfasına yapıştırdım ama ya ben çalıştıramadım ya da çalışmadı. excel 2010 version kullanıyorum. bu arada teşekkür ederim.

olur da çalıştırabilirsek 2 şey sormak istiyorum.

ilki : direk hücre boyutuna en ve boy olarak ayarlanması iyi bir şey tabi ki ancak sadece en ya da sadece boy olarak ayarlamak istersek aşağıdaki satırlardan ilgili olanları silsek bi sıkıntı olur mu?

PicTop = MyRng.Top
PicLeft = MyRng.Left
PicW = MyRng.Width
PicH = MyRng.Height

ikincisi: eklediğimiz resmin köprüsünü hücrede küçülen fotoğrafa nasıl atayabiliriz?
 
Son düzenleme:
Bunda çalıştıramayacak bir şey yok ...

Bir modül ekleyin, kodları yapıştırın, makroyu çalıştırın. Bu kadarını yaparsınız herhalde ....

.
 
Haluk' Alıntı:
Bunda çalıştıramayacak bir şey yok ...

Bir modül ekleyin, kodları yapıştırın, makroyu çalıştırın. Bu kadarını yaparsınız herhalde ....

.
Genişletmek için tıkla ...

o şekilde çalışıyor hocam. lakin sadece a2 hücresine ayarlı. ben sayfada 20 ayrı yere fotoğraf koyup boyut ayarlayıp daha sonra aynı fotoğrafı küçük fotoğrafa köprü yapıyorum. a2 değilde seçili olan hücreye bunu uygulasam ? makro çalıştır demeden, ben her resim ekle dediğimde bunu yapsa. o şekilde düzenlenebilir mi?
 
PLİNT; hocama çok teşekkür ediyorum. Kodları ve örnek dosyayı paylaşıyorum arkadaşlar. Bir başkasının da işine yarasın.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row < 27 Then Exit Sub 'seçili hücre satırı 27 den küçükse çık
If Target.Column > 12 Then Exit Sub 'seçili hücre sütunu 12 den büyükse çık
For Each x In ActiveSheet.Shapes
If Not Intersect(x.TopLeftCell, Target) Is Nothing Then x.Delete
Next
ChDir (ThisWorkbook.Path) '"ThisWorkbook.Path yerine resimlerin adresi olabilir "C:\Resimler" veya satır komple silinir
PicFile = Application.GetOpenFilename("Resim dosyası (*.jpg), *.jpg")
If PicFile = False Then Exit Sub
    PicTop = Target.Top 'konum
    PicLeft = Target.Left 'konum
    PicW = Target.Width 'seçilen hücre eni
    PicH = Target.Height ' seçili hücre boyu
    Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
    MyPic.Name = "Pictur" & Target.Column & Target.Row
  ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes.Range(Array(MyPic.Name)).Item(1), Address:=PicFile
  MsgBox "İşlem tamam; köprü oluşturuldu"
End Sub

http://www.dosya.tc/server11/adzrt5/Fotograf_ekleme_-_kopru_atama.rar.html
 
Son düzenleme:
DMR 7' Alıntı:
PLİNT; hocama çok teşekkür ediyorum. Kodları ve örnek dosyayı paylaşıyorum arkadaşlar. Bir başkasının da işine yarasın.
Genişletmek için tıkla ...

PLİNT hocanızın bu konu başlığında 1 tane mesajı yokken, benim kodları nasıl adapte etmiş de size vermiş o da ilginç doğrusu ...

.
 
Haluk' Alıntı:
PLİNT hocanızın bu konu başlığında 1 tane mesajı yokken, benim kodları nasıl adapte etmiş de size vermiş o da ilginç doğrusu ...

.
Genişletmek için tıkla ...

özelden yazmıştım ben ona. kendi son düzenlemeyi benim işime yarayacak şekilde yaptı . sonra haluk hocanın boyut ayarlama satırlarını ekler misiniz dedim ekleyip gönderdi. son düzenleme için teşekkür ediyorum bende. bi kaç üst mesajda da size teşekkür etmiştim. burada insanların yararına birşeyler paylaşılıyor bende başkalarının işine yarar diye koymak istedim.

bi kaç mesaj öncesinde de bunu yapamayacak ne var diye küçümser şekilde konuşmuştunuz. belki yapmayı bilmiyorum ve yardım istiyorum. bilmeyen birilerine karşı daha güzel bir üslup ile konuşmanız sizin ve rencide edebileceğiniz herhangi biri için daha iyi olacaktır.

burada amaç emek hırsızlığı değil ! paylaşım yapmak.
 
Son düzenleme:
DMR 7' Alıntı:
özelden yazmıştım ben ona. kendi son düzenlemeyi benim işime yarayacak şekilde yaptı . ....
Genişletmek için tıkla ...

Mesajınızda bu ayrıntıyı vermemiştiniz ...

Kendi adıma; konuyu daha fazla uzatmanın gerekli olduğunu düşünmüyorum.

.
 
DMR 7' Alıntı:
PLİNT; hocama çok teşekkür ediyorum. Kodları ve örnek dosyayı paylaşıyorum arkadaşlar. Bir başkasının da işine yarasın.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row < 27 Then Exit Sub 'seçili hücre satırı 27 den küçükse çık
If Target.Column > 12 Then Exit Sub 'seçili hücre sütunu 12 den büyükse çık
For Each x In ActiveSheet.Shapes
If Not Intersect(x.TopLeftCell, Target) Is Nothing Then x.Delete
Next
ChDir (ThisWorkbook.Path) '"ThisWorkbook.Path yerine resimlerin adresi olabilir "C:\Resimler" veya satır komple silinir
PicFile = Application.GetOpenFilename("Resim dosyası (*.jpg), *.jpg")
If PicFile = False Then Exit Sub
    PicTop = Target.Top 'konum
    PicLeft = Target.Left 'konum
    PicW = Target.Width 'seçilen hücre eni
    PicH = Target.Height ' seçili hücre boyu
    Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
    MyPic.Name = "Pictur" & Target.Column & Target.Row
  ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes.Range(Array(MyPic.Name)).Item(1), Address:=PicFile
  MsgBox "İşlem tamam; köprü oluşturuldu"
End Sub

http://www.dosya.tc/server11/adzrt5/Fotograf_ekleme_-_kopru_atama.rar.html
Genişletmek için tıkla ...

hali hazırda zaten çalışan bu kodlarda bir düzeltme istiyorum. yardım edebilecek biri var mıdır?

ilgili dosyanın konumu değiştirilince köprüler çalışmıyor. Nasıl düzeltebilirim?
 
yardım edebilecek herhangi biri yok mudur?
 
Köprü dışı çözüm

Sayfadaki kod:

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim s1
Set s1 = Sheets(ActiveSheet.Name)

If Target.Row < 27 Then Exit Sub 'seçili hücre satırı 27 den küçükse çık
If Target.Column > 12 Then Exit Sub 'seçili hücre sütunu 12 den büyükse çık
For Each x In ActiveSheet.Shapes
If Not Intersect(x.TopLeftCell, Target) Is Nothing Then x.Delete
Next

Dosya = Application.GetOpenFilename("Resim dosyası (*.jpg), *.jpg")

If Dosya = False Then Exit Sub

Set Adres = Range(s1.Cells(Target.Row, Target.Column), s1.Cells(Target.Row, Target.Column + 3))
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).OnAction = "resim_goster"
s1.Shapes(ad).OLEFormat.Object.Name = Dir(Dosya)

MsgBox "İşlem tamamu"

End Sub


Modüldeki kod:

Kod: 
Sub resim_goster()

Dosya = ThisWorkbook.Path & "\" & Application.Caller

If Dosya <> "" Then
CreateObject("Shell.Application").Open (Dosya)
End If

End Sub
 
halit3' Alıntı:
Köprü dışı çözüm

Sayfadaki kod:

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim s1
Set s1 = Sheets(ActiveSheet.Name)

If Target.Row < 27 Then Exit Sub 'seçili hücre satırı 27 den küçükse çık
If Target.Column > 12 Then Exit Sub 'seçili hücre sütunu 12 den büyükse çık
For Each x In ActiveSheet.Shapes
If Not Intersect(x.TopLeftCell, Target) Is Nothing Then x.Delete
Next

Dosya = Application.GetOpenFilename("Resim dosyası (*.jpg), *.jpg")

If Dosya = False Then Exit Sub

Set Adres = Range(s1.Cells(Target.Row, Target.Column), s1.Cells(Target.Row, Target.Column + 3))
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).OnAction = "resim_goster"
s1.Shapes(ad).OLEFormat.Object.Name = Dir(Dosya)

MsgBox "İşlem tamamu"

End Sub


Modüldeki kod:

Kod: 
Sub resim_goster()

Dosya = ThisWorkbook.Path & "\" & Application.Caller

If Dosya <> "" Then
CreateObject("Shell.Application").Open (Dosya)
End If

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

hocam çok teşekkür ederim. ellerinize saglık
 
Farklı bir alternatif daha

kod.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim s1
Set s1 = Sheets(ActiveSheet.Name)

If Target.Row < 27 Then Exit Sub 'seçili hücre satırı 27 den küçükse çık
If Target.Column > 12 Then Exit Sub 'seçili hücre sütunu 12 den büyükse çık
For Each x In ActiveSheet.Shapes
If Not Intersect(x.TopLeftCell, Target) Is Nothing Then x.Delete
Next

Dim i As Long
yol = ThisWorkbook.Path

With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Filters.Add "Resim Files", "*.jpg", 1
.InitialFileName = yol
.ButtonName = "Seçileni Aç"
.Title = "Dosya Açma penceresi"
.Show

For i = 1 To .SelectedItems.Count
Dosya = .SelectedItems(i)
Set Adres = Range(s1.Cells(Target.Row, Target.Column), s1.Cells(Target.Row, Target.Column + 3))
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).OnAction = "resim_goster"
s1.Shapes(ad).OLEFormat.Object.Name = ekle & ":" & Dir(Dosya)
MsgBox "İşlem tamam"
GoTo atla1
Next i
End With
MsgBox "İşlemi iptal ettiniz."
atla1:
End Sub


modüldeki kod:

Kod: 
Sub resim_goster()

hucre = Application.Caller
deg1 = Split(hucre, ":")
If UBound(deg1) > 0 Then
ekle = deg1(1)
Else
ekle = Application.Caller
End If

Dosya = ThisWorkbook.Path & "\" & ekle
MsgBox Dosya
If Dosya <> "" Then
CreateObject("Shell.Application").Open (Dosya)
End If

End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst