excel dosyasını jpg olarak kaydetmek

[susuzyaz]

merhaba arkadaslar excel cizelgesini buyuk baskı makinasında basacagız..çizelge cok ayrıntılı..makina resim olarak basabiliyor..excel dosyasını nasıl jpg dosyası yapabilirim..teşekkürler...

 

[security]

merhaba arkadaslar excel cizelgesini buyuk baskı makinasında basacagız..çizelge cok ayrıntılı..makina resim olarak basabiliyor..excel dosyasını nasıl jpg dosyası yapabilirim..teşekkürler...

Merhaba dediğiniz sey basit bir makro yardımı ile mümkün

Sub security()
Dim objTemp As Object
Dim chtMyChart As Chart
Dim rngImg As Range
Dim No As Long
Dim TempName As String
No = Range("AA1") + 1
Range("AA1") = No
Range("AA1").NumberFormat = "000"
Set rngImg = Range("A1:M30")
rngImg.Copy
Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
objTemp.Select
ActiveSheet.Paste
objTemp.Delete
TempName = "C:\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
MsgBox "Resim, " & TempName & " olarak kaydedildi...",," Security"
Set rngImg = Nothing
Set objTemp = Nothing
End Sub

bu makro ile Excel dosyanızdaki A1 ile M30 Arasındaki yazıları ve resimleri jpg uzantılı bir şekilde C. ye kayıt edebilirsiniz.Tabi sizin dosyanızdaki aralıklara göre düzenlemeniz gerekli.

size örnek bir dosya gönderiyorum.

 

[muygun]

Güzel çözüm.
Teşekkürler Syn. security
İyi çalışmalar.

 

[security]

Güzel çözüm.
Teşekkürler Syn. security
İyi çalışmalar.

Ben tşk. ederim syn: uzmanım.

 

[3641]

Sayın security,
Acaba çalışmanızı A1 Hücresindeki değeri dosya adı olarak al ve kaydet diyebilirmiyiz.

 

[security]

Sayın security,
Acaba çalışmanızı A1 Hücresindeki değeri dosya adı olarak al ve kaydet diyebilirmiyiz.

sn: 3641 anladıgım a1 hücresindeki başlık resimin adı olsun sanırım demek istediğiniz bu ise tabi bu mümkün. örnek dosyayı ekliyorum.
olay su a1 hücresinde deneme yazıyor ve C ye deneme.jpg olarak kayıt ediyoruz. umarım sorunuz budur. kolay gelsin

 

[3641]

Sn. security,
İlginiz ve yardımlarınız için çek teşekkür ederim.
Sn. halit3 arkadaşımın yardımlarıyla "Seç Aktar Yazdır Yardım" http://www.excel.web.tr/showthread.php?t=73310 konu içindeki çalışmaya ekliycem.

Tekrar Teşekkür ederim.

Saygılarımla,

 

[Orion1]

Sayın securty , güzel bir çalışma olmuş.Teşekkür ederim.

 

[security]

Sayın securty , güzel bir çalışma olmuş.Teşekkür ederim.

Ben tşk. ederim syn: uzmanım

 

[istanbulcahan]

Ekteki dosyada yapamadım. Yardımcı olurmusunuz.

 

[HALILİBRAHIM]

Merhaba Hocalar,

Yukarıdaki örnekler gibi benimde bir yardıma ihtiyacım var,

Hocalar aşağıdaki kodlar "C" nin altına resimleri belirttiğimiz yere ".gif" olarak kaydediyor fakat ben bu resimleri excel dosyasında belirteceğim kodlarla .jpg olarak kaydedebilrmiyim.
Örnek olarak;
"B1:B500" hücrelerinde resim "C1:C500" hücrelerinde resimin adı olsun ve böyle kaydetsin mümkün müdür hocalar.

Option Explicit
Sub Resim_Olarak_Aktar()
Dim oRsm As Shape
Dim oGrf As ChartObject
Dim sDzn As String
sDzn = "c:\"
For Each oRsm In ActiveSheet.Shapes
    If oRsm.Type = msoPicture Then
        oRsm.Copy
        Set oGrf = ActiveSheet.ChartObjects.Add(0, 0, oRsm.Width, oRsm.Height)
        With oGrf
            With .Chart
                .Paste
                .Export sDzn & oRsm.Name & ".gif"
            End With
            .Delete
        End With
    End If
Next
End Sub

Örnek dosyamın boyutu 13 Mb. olduğundan link veriyorum Hocalar yardımcı olursanız çok memnun olurum.

http://www.dosya.tc/server6/mvkBza/C_SEZON_KATALOG.rar.html

Saygılarımla

 

[muygun]

Merhaba;
1-sayfa görüntüsünü %100 yapın.
2-B sütunundaki kenar çizgilerini kaldırın.
3-C sürücüsünde resimlerim adlı bir klasör oluşturun (yada kodlardaki "C:\resimlerim\" kısmını isteğinize göre düzenleyin.)

vba sayfasında bir modül açarak;

Sub resimleri_kaydet()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("Ckod")
Dim objTemp As Object
Dim chtMyChart As Chart
Dim rngImg As Range
For i = 2 To s1.Range("c65536").End(xlUp).Row
Set rngImg = Range("B" & i & ":B" & i) 'resimlerin bulunduğu sütun
rngImg.Copy
Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
objTemp.Select
ActiveSheet.Paste
objTemp.Delete
With Selection
.CopyPicture 1, 2
Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
With chtMyChart
.Paste
.Export "C:\resimlerim\" & Range("c" & i & ":c" & i) & ".jpg" 'kayıt edilecek yol ve kayıt isimleri
.Parent.Delete
End With
.Delete
End With
Set rngImg = Nothing
Set objTemp = Nothing
Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

Kodlarını ekleyerek deneyin.

İyi çalışmalar.

Not: Kodlar alıntıdır.

Syn.HALILİBRAHIM;
Dosyanızı daha çok kimsenin inceleyip çözümü hızlandırmak istiyorsanız örneklerinizin uzunluklarını daha kısa tutun. (örneğinizdeki 2. verinden sonrakiler dosya boyutunu artırarak kota yemekten başka birşey yapmıyor)

 

[HALILİBRAHIM]

Hocam sizden Allah razı olsun ne güzel bilgiler bunlar, ne kadar kolaylıklar bıkmadan üşenmeden bizimle paylaştığınız için çok teşekkür ederim çok uğraşacaktım.

Allah işlerinizi kolaylaştırsın Muygun hocam çok teşekkür ederim söylediklerinizide dikkate alacağım.

Saygılarımla İyi çalışmalar hocam.

 

[HALILİBRAHIM]

Hocam linkini gönderdiğim dosyayı yapıyorum dediğiniz gibi fakat ekte gönderdiğim dosya bir türlü kaydetmiyor sebebi nedir acaba?

 

[muygun]

Merhaba;
Kodlarda 4.satırı ;
Set s1 = ThisWorkbook.Worksheets("Sayfa1")
şeklinde düzenleyin.
İyi çalışmalar.

 

[posetcat]

Muygun harika bir bilgi bu, yarın bunu uygulayacağım kataloglara direkt jpg resim olarak aktarma fikri de çok hoş. Hatun evde sorun çıkarmasa uzun uzun inceleyeceğimde,

elinize sağlık.

 

[HALILİBRAHIM]

Çok teşekkür ederim Muygun Hocam emeğinize sağlık,

Saygılarımla Hocam,