Kod Birleştirme

[hamza02]

Arkadaşlar merhaba,

Kodlarını sizlerden aldığım "Günlük İcmal" isimli çalışma dosyamda masaüstüne ve sayfa içine resim kaydetme ve mail gönderme butonları var.

Masaüstüne kaydedilen resim ile sayfa içine kaydedilen resmi kıyasladığımda netlik farkı var. Sayfa içindeki daha net. Masaüstüne kaydedilen resminde net olmasını nasıl sağlarız.

Birde aynı buton ile hem resim kaydetme ve mail gönderme yapabilir miyiz.

 

[hamza02]

İndir Günlük İcmal deneme xlsm

Dosyayı indir Günlük İcmal deneme xlsm

dosya.co

 

[Korhan Ayhan]

Bu konu faydalı olabilir..

Thread 'Userforma belirli alanın resmini yapıştırmak'

7 Nisan 2020

Arkadaşlar merhaba,

Userform'a kayıtlı resim ekleme ile ilgili çalışmalar buldum. Ama benim istediğim bu değil.

Düğmeye tıkladığımızda Userform açılacak ve B2:G16 (satır sayısı değişken) aralığının resmini Userform'a yapıştıracak. Dosyada nasıl görünmesi ile ilgili görsel paylaştım.
Userform yüksekliği ve genişliği resim boyutuna göre değişken olmalı.

• Muhammet Okumuş
• Cevaplar: 115
• Forum: Makro-VBA Soruları

 

[hamza02]

Sayın Korhan Ayhan hocam konunun tüm mesajlarını okudum, ne yazık ki çözemedim.
Sizlerin yardımı olmadan makro kodlardan bir şey yapamıyorum. Çok afedersiniz.

 

[Biolightant]

Merhaba,

Sub GunlukIcmalMail()

    Dim ResimAlani As Range
    Dim ResimFormati As String
    Dim Grafik As ChartObject
    Dim Mail As Object
    Dim Dosya As String
    
    Set ResimAlani = ActiveSheet.Range("B1:H29")
    
    ResimFormati = "PNG"  'GIF < JPG < PNG < BMP
    
    Dosya = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
            "\Günlük_İcmal." & LCase(ResimFormati)
    
    'Hücre aralığını resim olarak kopyala
    ResimAlani.CopyPicture xlScreen, xlBitmap
    
    'Geçici grafik oluştur
    Set Grafik = ActiveSheet.ChartObjects.Add( _
                 0, 0, ResimAlani.Width, ResimAlani.Height)
    
    Grafik.Activate
    Grafik.Chart.Paste
    
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")
    
    Grafik.Chart.Export Dosya, ResimFormati
    Grafik.Delete
    
    'E-posta oluştur
    Set Mail = CreateObject("Outlook.Application").CreateItem(0)
    
    With Mail
        .To = Range("O2").Value
        .CC = ""
        .BCC = ""
        .Subject = "Günlük İcmal"
        .Body = "Bu bir deneme mesajıdır."
        .Attachments.Add Dosya
        .Display
        '.Send
    End With

End Sub

Resim kalitesi ve dosya boyutu sıralaması:
ResimFormati = "GIF" 'Düşük kalite, en fazla 256 renk
ResimFormati = "JPG" 'Orta kalite, küçük dosya, kayıplı sıkıştırma
ResimFormati = "PNG" 'Yüksek kalite, Excel görüntüleri için en uygun
ResimFormati = "BMP" 'Kayıpsız fakat dosya boyutu çok büyük

 

[hamza02]

Sayın Biolightant hocam elinize emeğinize sağlık, çok teşekkür ederim. Çok güzel olmuş.