Resim ekleme ve otomatik olarak hücreye sığdırma

[BedriA]

Merhaba,

Sn. Halit3' e ait olan kod; fotoğrafı çalışma sayfasında seçili olan hücreye ekliyor. Bu kod ayrıca fotoğrafı hücrenin her iki yanına yaslayarak, yani hücre içine yerleştirerek ekliyor. Benim istediğim kodların mevcut yapısını bozmadan ilgili hatayı düzeltebilmek.

Yine de teşekkür etmek zor değil değil mi?
Tanımadığınız bir insan sonuçta size yardım etmeye çalışmış, ihtiyacınıza cevap olmasa bile.

Kodunuzu aşağıdaki ile değiştirince sorun düzelecektir.
Koda kırmızı kısım eklendi.
Buyrun.

Sub InsertPicture()
Dim sPicture As String, pic As Picture

sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")

If Show = -1 Then Exit Sub

Adres = ActiveWindow.RangeSelection.Address

Dim Picture As Object

For Each Picture In ActiveSheet.Shapes

If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

yer1 = Picture.TopLeftCell.Address
yer2 = (Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address)

If yer1 = Adres Or yer2 = Adres Then
Picture.Delete
Exit For
End If
End If
Next Picture
[COLOR="Red"]On Error Resume Next[/COLOR]
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic

.ShapeRange.LockAspectRatio = msoFalse
.Height = Range(Adres).Height - 4
.Width = Range(Adres).Width - 4
.Top = Range(Adres).Top + 2
.Left = Range(Adres).Left + 2
.Placement = xlMoveAndSize
End With

Set pic = Nothing

End Sub

 

[denese]

Yine de teşekkür etmek zor değil değil mi?
Tanımadığınız bir insan sonuçta size yardım etmeye çalışmış, ihtiyacınıza cevap olmasa bile.

Sn. BedriA,

Teşekkür etmek elbette ki zor değil. Ancak sonuca ulaşma düşüncesiyle konunun tam olarak anlaşılmadığını düşündüm ve detaylı açıklama yapma ihtiyacı duydum. Kusuruma bakmayın lütfen.

İlginize ve desteğinize teşekkür ederim.

İyi çalışmalar

 

[BedriA]

Sn. BedriA,

Teşekkür etmek elbette ki zor değil. Ancak sonuca ulaşma düşüncesiyle konunun tam olarak anlaşılmadığını düşündüm ve detaylı açıklama yapma ihtiyacı duydum. Kusuruma bakmayın lütfen.

İlginize ve desteğinize teşekkür ederim.

İyi çalışmalar

Sorun değil.
Kodu yukarıdaki gibi deneyince bende hata vermedi.
Kodu burdan olduğu gibi kopyalayıp yapıştırınca sizde de çalışacaktır.

İyi çalışmalar.

 

[halit3]

Merhaba,

Buton yardımıyla fotoğraf ekle dediğimde gözat penceresi açılıyor, ancak fotoğrafı eklemeden iptal deyip çıkmak istediğimde kod hata veriyor.

Bunu nasıl düzeltebilirim?

Dosya ektedir.

Dosya ve hata koduna buradan da ulaşabilirsiniz.

kod:

Sub dosya_ac_penceresi()

Dim i As Long
yol = ThisWorkbook.Path
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.InitialFileName = yol
.ButtonName = "Seçileni Aç"
.Title = "Dosya Açma penceresi"
.FilterIndex = 1
.Show

For i = 1 To .SelectedItems.Count
sPicture = .SelectedItems(i)

Adres = ActiveWindow.RangeSelection.Address

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes

If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer1 = Picture.TopLeftCell.Address
yer2 = (Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address)
If yer1 = Adres Or yer2 = Adres Then
Picture.Delete
Exit For
End If
End If
Next Picture

Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic

.ShapeRange.LockAspectRatio = msoFalse
.Height = Range(Adres).Height - 4
.Width = Range(Adres).Width - 4
.Top = Range(Adres).Top + 2
.Left = Range(Adres).Left + 2
.Placement = xlMoveAndSize
End With

Set pic = Nothing




Next i
End With

[COLOR="Red"]End Sub[/COLOR]

 

[denese]

Merhaba Sn. Halit3

Desteğiniz için teşekkürler, Sn. BedriA' nın çözümü ile kod kusursuz çalışıyor. Ancak bu kodu denediğimde ise ekteki hatayı alıyorum.

İyi çalışmalar.

 

[halit3]

Merhaba Sn. Halit3

Desteğiniz için teşekkürler, Sn. BedriA' nın çözümü ile kod kusursuz çalışıyor. Ancak bu kodu denediğimde ise ekteki hatayı alıyorum.

İyi çalışmalar.

kodun son bölümü eklenmemiş üstdeki mesajımda kırmızı yeri ekledim

 

[denese]

kodun son bölümü eklenmemiş üstdeki mesajımda kırmızı yeri ekledim

Çok teşekkür ederim.

İyi çalışmalar

 

[denese]

kod:

Sub dosya_ac_penceresi()

Dim i As Long
yol = ThisWorkbook.Path
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.InitialFileName = yol
.ButtonName = "Seçileni Aç"
.Title = "Dosya Açma penceresi"
.FilterIndex = 1
.Show

For i = 1 To .SelectedItems.Count
sPicture = .SelectedItems(i)

Adres = ActiveWindow.RangeSelection.Address

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes

If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer1 = Picture.TopLeftCell.Address
yer2 = (Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address)
If yer1 = Adres Or yer2 = Adres Then
Picture.Delete
Exit For
End If
End If
Next Picture

Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic

.ShapeRange.LockAspectRatio = msoFalse
.Height = Range(Adres).Height - 4
.Width = Range(Adres).Width - 4
.Top = Range(Adres).Top + 2
.Left = Range(Adres).Left + 2
.Placement = xlMoveAndSize
End With

Set pic = Nothing




Next i
End With

[COLOR="Red"]End Sub[/COLOR]

Merhaba,

Sayfaya eklediğim resmi, eklediğim alanda bir metin kutusu var olduğunu varsayarak, resmi en arkaya göndermesi için bu kodu nasıl revize edebiliriz.
(Örn, aşağıdaki alana sertifika şablonu ekleyeceğim ve metin kutularının en önde durmasını istiyorum)