Çalışma Sayfasındaki Resimleri Kaydetme

[apostraf]

Merhaba,

günlük olarak takibinin yapıldığı 3 sayfadan oluşan bir Excel dosyası var ve 01.03.2013 - 31.03.2013 gibi her ay tüm günlere ait farklı farklı kaydediliyor. günlük rapor gibi bu rapor dosyasında 3 sayfa var 3. sayfada resimler bulunuyor 4 - 5 tane, bu resimleri pratik bir şekilde günlük raporun dosya ismi ile yani 01.03.2013 gibi açılacak bir klasöre kaydetmemiz mümkün müdür?

Notlar:

-Her dosyada farklı farklı resimler bulunuyor. Ve resim yerleşimi raslantısal gerçekleşiyor.
-Raporları Ben hazırlamıyorum arşivleyip kontrolünü yapıyorum.


Verilecek cevaplar için şimdiden teşekkür ederim.

 

[Murat OSMA]

Şu kodları bir deneyiniz;

Dim Rky As Shape
Dim a As Integer
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private DispatchGuid As GUID
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private PictureDescription As uPicDesc
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private IPic As IPicture
Private hPtr As Long

Sub Create_xlScreenxlBitmap_Picture()
On Error Resume Next
a = 1
For Each Rky In ActiveSheet.Shapes
RangeSaveAsPicture Rky, ThisWorkbook.Path & "\Evn" & a & ".jpg"
a = a + 1
Next Rky
End Sub
Private Sub RangeSaveAsPicture(evn As Shape, FilePathName As String)
evn.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
OpenClipboard 0
hPtr = GetClipboardData(2)
CloseClipboard
With DispatchGuid

.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB

End With
With PictureDescription

.Size = Len(PictureDescription)
.Type = 1
.hPic = hPtr
.hPal = 0

End With
OleCreatePictureIndirect PictureDescription, DispatchGuid, True, IPic
stdole.SavePicture IPic, FilePathName
End Sub

 

[apostraf]

Sayın Murat OZMA,

verdiğiniz cevap için teşekkür ederim. Yazdığınız Kod resmi dosyanın bulunduğu yere attı ancak o resmi dosya ismi ile (Günlük Faaliyet Raporu 09.03.2013) açtığı klasörün içine atabilirse birde benim bu kodu her gün yeni güne ait rapor dosyasında uygulayıp çalıştırmam gerekecek bu yüzden pek pratik değil benim geçmişe dönük tüm dosyalara bunu uygulamam gerekiyor. Tek bir dosyada belirteceğim klasördeki tüm excel dosyalarının, RESİMLER isimli çalışma sayfasındaki tüm resimleri, ilgili excel dosyasının adı ile açacağı klasöre atsın.

Tekrar teşekkür ederim.

 

[Murat OSMA]

Murat OZMA değil Murat OSMA dikkat edin lütfen.

Makronun ilgili kısmını şu şekilde değiştirip deneyiniz;

Sub Create_xlScreenxlBitmap_Picture()
    Dim klasor As Variant
    On Error Resume Next
    klasor = ThisWorkbook.Path & "\Günlük Faaliyet Raporu - " & _
    Format(VBA.Date, "dd.mm.yyyy")
    MkDir klasor
    On Error GoTo 0
    a = 1
    For Each Rky In ActiveSheet.Shapes
        RangeSaveAsPicture Rky, klasor & "\" & a & ".jpg"
        a = a + 1
    Next Rky
End Sub