• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Excelden harddiske fotoğraf kaydı

M

mesuttasar

Katılım
21 Ağustos 2005
Mesajlar
625
Excel Vers. ve Dili
Office 365 - İngilizce
Arkadaşlar merhaba, benzer konular mevcut ama örnek dosyalar silindiği için kodları görme şansım olmadığı için yeni konu açıyorum.Çalışma kitabımızda bulunan picture1,picture2 ... gibi resimleri D dizini altında oluşturduğum örneğin ABC isimli klasörün altına picture1.jpg , picture2.jpg ... gibi kopyalamak istiyorum.Hangi kod veya hangi açılmış konulardan faydalanabilirim.Şimdiden selam ve saygılarımla ,
 

Ekli dosyalar

aşağıdaki adreste yer alan eklentiyi addin (üstteki 1.si add-in 2003 için, bu 2007 için) yazısını tıklayarak indirin.

winzip ile eklentilerin bulunduğu veya istediğinizi bir klasöre açın. excel'e yükleyin.

resim içeren dosyanızı açın. eklentiler sekmesine yüklenen Graphic Export'a tıklayın. Resminizi seçin. Kopyalanacak klasörü seçin. Export. Tamam.

http://www.andypope.info/vba/gex.htm


not: denenmiştir.
 
Selamlar,

Bundan kısa bir zaman önce banada böyle bir kod lazım olmuştu. Daha önce Levent beyin aşağıdaki linkte önerdiği kodu kullanıyordum. Fakat kod sistemle alakalı olarak bazen çalışmıyor.

Hücre açıklamasına resim ekleme

Bu sebeple farklı çözüm ararken Ferhat bey ekteki dosyayı önerdi. API kullanılarak hazırlanmış bir dosyadır.

Sizin istediğiniz bölümleri uyarladım. D klasörü altında ABC isimli klasöre Picture1.jpg ismiyle artan numara vererek kayıt eder.
 

Ekli dosyalar

Sn. Korhan hocam, sayfadaki bütün resimleri tek tıklama ile belirtilen klasöre kopyalama imkanı olabilir mi? cevabınız için şimdiden teşekkürler.
 
Selamlar,

Tahsin bey,

Module2 deki kodların yerine aşağıdaki kodu uygulayıp denermisiniz.

Kod: 
Sub Bitmap_Exporteren2()
    Dim Dosya_Sistemi As Object, Kayıt_Yeri As Variant, Dosya_Adı As String
    Dim Say As Long, sFilter As String, lPicType As Long, oPic As IPictureDisp
    Dim Resim As Object
    
    sFilter = IIf(obMetafile, "Windows Metafile (*.emf),*.emf", "Windows Bitmap (*.bmp),*.bmp")
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    
    Kayıt_Yeri = "D:\ABC\"
    
    If Not Dosya_Sistemi.FolderExists(Kayıt_Yeri) Then
        Dosya_Sistemi.CreateFolder (Kayıt_Yeri)
    End If
    
    For Each Resim In ActiveSheet.Shapes
        If Resim.Type <> 8 And Resim.Type <> 12 Then
            Say = Dosya_Sistemi.GetFolder(Kayıt_Yeri).Files.Count + 1
            Dosya_Adı = Kayıt_Yeri & "Picture " & Format(Say, "0000") & ".jpg"
            
            If Kayıt_Yeri <> "" Then
                lPicType = IIf(obMetafile, xlPicture, xlBitmap)
                Resim.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
                Set oPic = PastePicture(lPicType)
                SavePicture oPic, Dosya_Adı
            End If
        End If
    Next
End Sub
 
Sn. hocam tek kelime ile harika, eliniz kolunuz dert görmesin. Çok teşekkür ediyorum. Eminim çok arkadaşın işine yarayacaktır. Saygılar Tahsin.
 
Hata mesajı alıyorum

Sn. Korhan hocam; Kendi dosyama uyardığım zaman ekli resimde gördüğüm hata mesajını alıyorum, neden olabilir. Teşekkürler.

Hatamı gördüm, modül1 deki kodları da yazmam gerekiyormuş. :)
 

Ekli dosyalar

  • 23.05.jpg
    23.05.jpg
    75.8 KB · Görüntüleme: 12
Son düzenleme:
Selamlar,

Benim eklediğim dosyadaki Module1 de bulunan API kodlarınıda kendi dosyanıza aktarmanız gerekiyor. Bundan dolayı hata mesajı alıyorsunuz.
 
Cevaplarınız için çok teşekkür ederim arkadaşlar.
 
Korhan Bey , ekte yazılı olan kodlar , printscreen tuşu görevi görüp masa üstünde çalışan programların ekran görüntüsünü alıp sayfada üst üste kopyalıyor.Ancak ben sayfa yerine D dizini altındaki ABC klasörüne fotoğraf olarak almak istiyorum.Ferhat bey'in api kodlarından faydalanayım dedim başaramadım , her iki kodu nasıl birleştirebiliriz acaba?
Kod: 
Sub autocad_video()
Application.WindowState = xlMinimized
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.BuildPath("D:\", "\deneme")
Dim i As Integer
Application.Wait Now + TimeValue("00:00:05")
For i = 1 To 3
keybd_event VK_MENU, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
' d dizinine  foto kaydetme kodları gelecek
ActiveSheet.Paste
Application.Wait Now + TimeValue("00:00:05")
Next i
Application.WindowState = xlNormal
 
 
End Sub
 
Değerli üstadlarım , kodları , forumda yer alan kodları kullanarak biraz daha geliştirdim ama hala 30 ve 40 numaralı satırlar arasına tam olarak hangi kod gelecek bulamadım.Şöyleki ekran görüntüsünü yakalayıp sayfaya yapıştırabiliyorum ama istediğim , D dizini altındaki ABC klasörüne Picture_1,2,3,,,, diye jpg formatında kayıt etmek. Son kodlar şu şekilde ;

Dosyanın son hali ektedir.

Kod: 
Option Explicit
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'----------------------------------------------------------------
[B]Sub autocad_video()[/B]
Dim a As Integer
Dim i As Integer
'1- D klasörü altında ABC klasörü yoksa ABC klasörü oluştur
Call Klasor
On Error Resume Next
'5- Kaç döngü yapılacağını sor
 a = inputbox("Kaç döngü yapılsın ?")
'8- Ekranı minimize et
Application.Visible = False
'10- 2 saniye bekle
For i = 1 To a
Application.Wait Now + TimeValue("00:00:02")
'20- printscreen yap
Call keybd_event(vbKeySnapshot, 0, 0, 0) ' Hali hazırda bulunan ekranın fotoğrafını yakaladı
DoEvents ' Clipboarda Çekilen Resmin Kopyalanması için Bilgisayarı beklet
ActiveSheet.Paste 'Sayfaya kopyaladı
'30- ABC Klasörü altına picture_sayı diye kaydet
[COLOR=red]'####################[/COLOR]
[COLOR=red]'####################[/COLOR]
[COLOR=red]'####################[/COLOR]
[COLOR=red]'####################[/COLOR]
'40- 10 nolu satıra git
Next i
'50- Döngü bittiyse Ekranı eski haline getir
Application.Visible = True
'60- Bitti
[B]End Sub[/B]
'------------------------------------------------
[B]Sub Klasor()[/B]
Dim ds
Set ds = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
ds.CreateFolder "D:\" & "ABC"
On Error Resume Next
[B]End Sub[/B]

Saygılarımla,
 

Ekli dosyalar

Değerli üstadlarım 5 Temmuz da sunum yapacağız , o yüzden bunu yapabilmem lazım, yardımlarınızı bekliyor iyi çalışmalar diliyorum.
 
Aşağıda yazılı olan kodlar işimi bir nebzede olsun çözmeme yardımcı oldu.Emeği geçen herkese teşekkür ederim.
Kod: 
Option Explicit
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'_______________________________________________________
Sub autocad2_video()
Dim a As Integer
Dim i As Integer
Dim TempName As String
Dim objTemp As Object
Dim chtMyChart As Chart
Call Klasor
On Error Resume Next
a = InputBox("Kaç döngü yapılsın ?")
For i = 1 To a
Range("aa1") = Range("aa1") + 1
Application.Wait Now + TimeValue("00:00:01")
Application.Visible = False
Application.Wait Now + TimeValue("00:00:05")
Call keybd_event(vbKeySnapshot, 0, 0, 0)
Application.Visible = True
Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
  objTemp.Select
  ActiveSheet.Paste
  TempName = "d:\abc\security_" & Range("AA1").Text & ".jpg"
  With Selection
      .CopyPicture 1, 2
      Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
  With chtMyChart
      .Paste
      .Export TempName
      .Parent.Delete
  End With
  .Delete
  End With
  Application.Visible = False
Next i
Application.Visible = True
End Sub
'------------------------------------------------
Sub Klasor()
Dim ds
Set ds = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
ds.CreateFolder "D:\" & "ABC"
On Error Resume Next
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst