Fotoğraf kayması

[58Muhendis58]

Sayın abiler aşağıdaki kodda klasörden resim getiriyorum kod çalışıyor tek sorunum şu resim sayısı sütundan aşağı indikçe çoğalıyor. resim sayısı arttıkça bulunması gereken hücreden aşağı kayıyor. örnek 28-29. resim yaklaşık yüksekliği 18 (30piksel) olacak şekilde bir alt hücreye kaymış oluyor. bu kayma alt resimlerde gide gide artıyor neden olur ki?

Sub DikdörtgenKöseleriYuvarlatilmis1272_Click()

Dim res As Picture
Dim x As Long
Dim fotoAd As String
Dim dosyaYolu As String
Dim fotoPath As String
Dim uzantilar As Variant
Dim uzanti As Variant
Dim fotoBulundu As Boolean
Dim hücreGenislik As Double
Dim hücreYükseklik As Double
Dim hedefHücre As Range

' Fotoğraf uzantılarını tanımla
uzantilar = Array(".JPG", ".JPEG", ".JFIF", ".PNG") ' Desteklenen uzantılar

' Fotoğraf yolunu belirle (Hücreden al)
dosyaYolu = Trim(CStr(Sheets("RAPORLAMA-2").Range("G3").Value))
If dosyaYolu = "" Then
MsgBox "Fotoğraf yolu belirtilmemiş. Lütfen 'G3' hücresine fotoğraf yolunu yazın.", vbExclamation
Exit Sub
End If

' Fotoğraf yolunun sonunda "\" yoksa ekle
If Right(dosyaYolu, 1) <> "\" Then dosyaYolu = dosyaYolu & "\"

' Performans artırıcı ayarlar
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

' 5. satırdan 680. satıra kadar fotoğraf yükle
For x = 5 To 680
fotoBulundu = False

' A sütununa fotoğraflar eklemek için J sütunundan fotoğraf numarasını al
fotoAd = Trim(CStr(Range("J" & x).Value)) ' Fotoğraf numarasını J sütunundan al ve boşlukları temizle

' Fotoğraf numarasını kontrol et
If fotoAd <> "" Then
' Her bir uzantı için fotoğrafı ara
For Each uzanti In uzantilar
fotoPath = dosyaYolu & fotoAd & uzanti ' Fotoğrafın tam yolunu oluştur

' Fotoğrafın mevcut olup olmadığını kontrol et
If Dir(fotoPath) <> "" Then
Set hedefHücre = Range("A" & x)
hücreGenislik = hedefHücre.Width
hücreYükseklik = hedefHücre.Height

' Önceki resimleri sil
On Error Resume Next
ActiveSheet.Pictures("Foto_" & x & "_A").Delete
On Error GoTo 0

' Fotoğrafı ekle
Set res = ActiveSheet.Pictures.Insert(fotoPath)
If Not res Is Nothing Then
' Resmi biçimlendir ve hücreye sabitle
With res
.Name = "Foto_" & x & "_A"
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Width = hücreGenislik ' Resmin genişliğini hücre genişliğine ayarla
.ShapeRange.Height = hücreYükseklik ' Resmin yüksekliğini hücre yüksekliğine ayarla
.Top = hedefHücre.Top ' Fotoğraf üst kısma oturacak
.Left = hedefHücre.Left ' Sol kenara oturacak
.Placement = xlMoveAndSize ' Hücreye sabitle
End With
fotoBulundu = True
End If
Exit For ' Fotoğraf bulundu, diğer uzantıları kontrol etme
End If
Next uzanti
End If

' B sütununa fotoğraflar eklemek için AP sütunundan fotoğraf numarasını al
fotoAd = Trim(CStr(Range("AP" & x).Value)) ' Fotoğraf numarasını AP sütunundan al ve boşlukları temizle

' Fotoğraf numarasını kontrol et
If fotoAd <> "" Then
' Her bir uzantı için fotoğrafı ara
For Each uzanti In uzantilar
fotoPath = dosyaYolu & fotoAd & uzanti ' Fotoğrafın tam yolunu oluştur

' Fotoğrafın mevcut olup olmadığını kontrol et
If Dir(fotoPath) <> "" Then
Set hedefHücre = Range("B" & x)
hücreGenislik = hedefHücre.Width
hücreYükseklik = hedefHücre.Height

' Önceki resimleri sil
On Error Resume Next
ActiveSheet.Pictures("Foto_" & x & "_B").Delete
On Error GoTo 0

' Fotoğrafı ekle
Set res = ActiveSheet.Pictures.Insert(fotoPath)
If Not res Is Nothing Then
' Resmi biçimlendir ve hücreye sabitle
With res
.Name = "Foto_" & x & "_B"
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Width = hücreGenislik ' Resmin genişliğini hücre genişliğine ayarla
.ShapeRange.Height = hücreYükseklik ' Resmin yüksekliğini hücre yüksekliğine ayarla
.Top = hedefHücre.Top ' Fotoğraf üst kısma oturacak
.Left = hedefHücre.Left ' Sol kenara oturacak
.Placement = xlMoveAndSize ' Hücreye sabitle
End With
fotoBulundu = True
End If
Exit For ' Fotoğraf bulundu, diğer uzantıları kontrol etme
End If
Next uzanti
End If
Next x

' Performans ayarlarını eski haline getir
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[Biolightant]

Merhaba,
Sanırım DikdörtgenKöseleriYuvarlatilmis şekillerin içinde resim var
bu mevcud resminizin boyutunu büyültüyor olabilir.
Aşağıda yazdığım işlemi bir test edin belki çözüm olur.

Her iki makroda bulunan

.ShapeRange.Width = hücreGenislik ' Resmin genişliğini hücre genişliğine ayarla
.ShapeRange.Height = hücreYükseklik ' Resmin yüksekliğini hücre yüksekliğine ayarla
.Top = hedefHücre.Top ' Fotoğraf üst kısma oturacak
.Left = hedefHücre.Left ' Sol kenara oturacak

Aşağıdaki şekilde değiştirip test ediniz

.ShapeRange.Width = hücreGenislik - 6 ' Resmin genişliğini hücre genişliğine ayarla
.ShapeRange.Height = hücreYükseklik - 6 ' Resmin yüksekliğini hücre yüksekliğine ayarla
.Top = hedefHücre.Top + 3 ' Fotoğraf üst kısma oturacak
.Left = hedefHücre.Left + 3 ' Sol kenara oturacak

Not:
top ve left e eklenen +3 ( projenize göre yükseltip düşürebilirsiniz )
width ve Height -6 (top ve left in -*2 değer olmalı )

 

[58Muhendis58]

Merhaba,
Sanırım DikdörtgenKöseleriYuvarlatilmis şekillerin içinde resim var
bu mevcud resminizin boyutunu büyültüyor olabilir.
Aşağıda yazdığım işlemi bir test edin belki çözüm olur.

Her iki makroda bulunan

.ShapeRange.Width = hücreGenislik ' Resmin genişliğini hücre genişliğine ayarla
.ShapeRange.Height = hücreYükseklik ' Resmin yüksekliğini hücre yüksekliğine ayarla
.Top = hedefHücre.Top ' Fotoğraf üst kısma oturacak
.Left = hedefHücre.Left ' Sol kenara oturacak

Aşağıdaki şekilde değiştirip test ediniz

.ShapeRange.Width = hücreGenislik - 6 ' Resmin genişliğini hücre genişliğine ayarla
.ShapeRange.Height = hücreYükseklik - 6 ' Resmin yüksekliğini hücre yüksekliğine ayarla
.Top = hedefHücre.Top + 3 ' Fotoğraf üst kısma oturacak
.Left = hedefHücre.Left + 3 ' Sol kenara oturacak

Not:
top ve left e eklenen +3 ( projenize göre yükseltip düşürebilirsiniz )
width ve Height -6 (top ve left in -*2 değer olmalı )

üstad söylediğinizi yaptım olmadı cevap için teşekkür ederim

 

[Biolightant]

üstad söylediğinizi yaptım olmadı cevap için teşekkür ederim

Üzgünüm, İlgili diğer arkadaşlar yardımcı olacaktır.
Kolay gelsin.