Resim taşıma problemi

[Muhammet Okumuş]

Merhaba arkadaşlar,

Sub Resim_Ekle()
Application.ScreenUpdating = False
Dim MyPath, ResimYolu, Resim, Res, x, i, resimm
Dim uzanti()

ActiveSheet.DrawingObjects.Delete
Set MyPath = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\user\Desktop\fstone")

ReDim uzanti(4)
uzanti(1) = "*.jpg*": uzanti(2) = "*.gif*": uzanti(3) = "*.png*": uzanti(4) = "*.jpeg*"

For x = 1 To 4

ResimYolu = Dir(MyPath & Application.PathSeparator & uzanti(Val(x)), vbDirectory)

Do While ResimYolu <> ""
If ResimYolu = ThisWorkbook.Name Then GoTo git:
i = i + 1

Set resimm = ActiveSheet.Shapes.AddPicture(MyPath & "\" & ResimYolu, False, True, 1, 1, -1, -1)
resimm.Select

Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = 300

Selection.Left = Cells(i + 1, i + 27).Left
Selection.Top = Cells(i + 1, i + 27).Top


git:
ResimYolu = Dir
Loop
Next
Set resimm = Nothing
Set MyPath = Nothing

End Sub

Bu kod ile resimleri klasörden excel sayfasına alıyorum. Buraya kadar her şey normal. Aldığım resimlerden resim seçip kes-yapıştır yaptığımda resmi aşağı veya sağa kaydırarak yapıştırıyor. Dosyayı resim alıp kaydedip açtığımda resmi istediğim yere yapıştırabiliyorum.

 

[Muhammet Okumuş]

Arkadaşlar sorun ekranın Zoom oranı ile alakalıymış. Ekran %100 olunca sorun çıkmıyor.