Klasör içindeki resimleri excele linksiz kopyalama

[GeoScience]

Arkadaşlar Merhaba,

Yazdığım kod belirtilen klasördeki tüm resimleri (.*png) excel içersine ayrı sekmeler açarak kopyalıyor fakat klasör içindeki resimleri sildiğim zaman resimler excel içindende siliniyor. Bu resimleri linksiz bir şekilde excele göndermemde bana yardımcı olursanız çok memnun olurum.

Saygılarımla.

Sub InsertAllPictures() 'Well Construction Desigh Plan

Dim DB, Dosya As Workbook, s1, s2, s3, s4, s5, s6 As Worksheet
Set DB = ThisWorkbook
Set s1 = ThisWorkbook.Worksheets("Main")

Dim strPath As String
Dim strFileName As String
Dim myPict As Picture

With ActiveCell.Range("A1:B19")

strPath = "C:\Users\TNY\Desktop\RECOVERY WELLS\" ' change folder to suit
strFileName = Dir(strPath & "*.png") ' change file type to suit

Do While Len(strFileName) > 0
Set s1 = ActiveSheet
s1.Cells(1, 1).Select

Set myPict = ActiveSheet.Pictures.insert(strPath & strFileName)

With myPict.Select

    Selection.ShapeRange.Height = 768
    Selection.ShapeRange.Width = 1024

    Selection.ShapeRange.LockAspectRatio = msoFalse
    'Selection.ShapeRange.IncrementTop 10 '60.75
    Selection.ShapeRange.ScaleHeight 1, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 1024
    Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 1448
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 0
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = -10   '-10
  
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.ScaleHeight 0.7803157883, msoFalse, msoScaleFromTopLeft   'sadece bunu ve       '0.7803157883 well constraction design plan için
    Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 1024
    Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 1448
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 0
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = 100   '30      'bunu değiştir

    Selection.ShapeRange.LockAspectRatio = msoFalse
    'Selection.ShapeRange.IncrementLeft 93
    Selection.ShapeRange.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 1023
    Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 1448
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 0   '-48
    'Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = -10
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.ScaleWidth 0.6283567435, msoFalse, msoScaleFromTopLeft      '0.6283567435 well constraction design plan için
    Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 1023
    Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 1448
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 50    '126
    'Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = -10

    
    Application.ScreenUpdating = True

End With

                s1.Visible = True
                s1.Copy After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = UCase(Left(strFileName, 5))
               
                For Each Shape In s1.Shapes
                Shape.Delete
                Next

strFileName = Dir
s1.Activate
s1.Cells(1, 1).Select

Loop

End With

End Sub

 

[tahsinanarat]

Sn. GeoScience resimleri çekip excel dosyasını kaydettikten sonra, klasör içindeki resim silinse bile excel sayfasında kalıyor, yani silinmiyor. Bilginiz olsun.

 

[GeoScience]

Tahsin Bey,

Öncelikle yorumunuz için teşekkür ederim.
Klasör içinden ("C:\Users\TNY\Desktop\RECOVERY WELLS\") resimler silindiği zaman excel de görünmüyor. Resimleri toplu olarak excel den word e gönderiyorum, fakat resimler kalsörden silindiğinde yada word dokümanı başka bir bilgisayarda açıldığında da yine görünmüyorlar.

Linkli yada linksiz kopyalama ile ilgili şu tarz kodlar var: "ActiveSheet.Pictures.Paste(Link:=True).Select" ama onlarıda yukarıdaki koduma uygun bir şekilde ekleyemedim.

Saygılarımla.

 

[c_235]

For Each Shape In s1.Shapes
Shape.Delete
Next

Merhaba, shape kısmında hata var mı ?değişken tanımlı değil uyarısı veriyor