excelden resim olarak kopyalama

[ahmet79]

a1:e5 hücre aralığında bulunan görüntüyü makro ile c içerisine resim olarak kaydetmek mümkünmüdür?

 

[ali semerci]

araçlar/özelleştir/komutlar/araçlar/kamera... simgesini alarak seçili alanın fotosunu alabilirsiniz ve siz artık onu painte yapıştırarak nereye isterseniz kaydedersiniz.
macrosu için de arkadaşlar yardımcı olacaklardır sanırım.

 

[ahmet79]

macro konusunda yardımcı olabilecek arkadaş varmı?
:yardim: :yardim:

 

[ahmet79]

:yardim: :yardim: arkadaşlar lütfen yardım edermisiniz? bu istediğim mümkün değilse en azından onu bileyim.

 

[Ecstasy]

Aşağıdaki Kodları Bir modüle Yapıştır

Option Explicit

Private Sub SaveRngAsJPG(Rng As Range, FileName As String)
    Dim Cht As Chart, bScreen As Boolean, Shp As Shape
    bScreen = Application.ScreenUpdating
    Application.ScreenUpdating = False
    Set Cht = Workbooks.Add(xlChart).Charts(1)
    Cht.ChartArea.Clear
    Rng.CopyPicture xlScreen, xlPicture
    Cht.Paste
    With Cht.Shapes(1)
        .Left = 0
        .Top = 0
        .Width = Cht.ChartArea.Width
        .Height = Cht.ChartArea.Height
    End With
    Cht.Export FileName, "JPEG", False
    Cht.Parent.Close False
    Application.ScreenUpdating = bScreen
End Sub

Sub TestIt2()
    Dim Rng As Range, Fn As String
    Set Rng = Range("A1:E5")
    Fn = "C:\resimle.jpg"
    SaveRngAsJPG Rng, Fn
End Sub

 

[ahmet79]

çok teşekkür ederim tam istediğim gibi bir çözüm oldu. :mutlu: :mutlu:

 

[spilavci]

Sayı Ahmet79

Ã?nce Resim olarak kopyalayacağınız alanı seçin.Shift tuşuna basılı olarak Edit(Düzen) bölümüne tıklayın.Açılan menüden resmi kopyalayı tıklayın.
Daha sonra istaedğiniz yere veya dosyaya yapıştırın.
Ekteki örneği inceleyin.

 

[askm]

Aşağıdaki kodlar ile yapabilirsiniz.
Yalnız C içerisine resim diye bir klasör açmanız gerekiyor. (Resmi resim klasörüne alıyor outlook a ekledikten sonra siliyor.)

Sub kod()

Dim S1 As Worksheet: Set S1 = Sheets("Sayfa1")
Dim rng As Range, cht As ChartObject, say As Double, obj As Object
Const strPath As String = "C:\resim\"


With Application
.EnableEvents = False
.ScreenUpdating = False
End With
S1.Select
isim = "mailek_" & Format(Now, "ddmmyyhhmmss")
Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
say = obj.Files.Count + 1
Set rng = S1.Range("A1:E16")

rng.CopyPicture xlScreen, xlPicture
Set cht = ActiveSheet.ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
cht.Chart.Paste
cht.Chart.Export strPath & isim & ".jpg"
cht.Delete
ExitProc:
Set obj = Nothing: Set rng = Nothing: Set cht = Nothing

Dim xlOutlook As Object
Dim xlMail As Object
Set xlOutlook = CreateObject("Outlook.Application")
Set xlMail = xlOutlook.CreateItem(0)
htmlyaz = "<img src=" & strPath & isim & ".jpg" & " alt=''"

With xlMail
.To = ThisWorkbook.Sheets("Sayfa1").Range("h4").Value
.CC = ""
.Subject = Cells(3, "G") & Cells(3, "H")
.HTMLBody = htmlyaz
.Importance = 2
.Save
.Display
'.Send
End With

Set xlMail = Nothing
Set xlOutlook = Nothing
Kill strPath & isim & ".jpg"

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub