Screen shoot and send email outlook

  1. 2 tahun lalu

    Hai sepuh"
    Mau nanya dong bagaimana cara nge screenshoot pakai vba macro dan memasukkan data screen shoot tersebut ke dalam email outlook

    Berikut saya berikan beberapa foto code modules saya
    Hehehehe

    Coba Paka ini dh

    Versi 1 (modif dari ente punya+ sedikit Api unggun) :

    'Declare Windows API Functions
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
      bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
     
    'Declare Virtual Key Codes
    Private Const VK_SNAPSHOT = &H2C
    Private Const VK_KEYUP = &H2
    Private Const VK_MENU = &H12
    Public Const VK_TAB = &H9
    Public Const VK_ENTER = &HD
     
    Sub CaptureMe()
    Application.ScreenUpdating = False
        'Press Alt + TAB Keys -- Step1
        Alt_Tab
     
        'Press Print Screen key using Windows API -- Step2.
        keybd_event VK_SNAPSHOT, 1, 0, 0 'Print Screen key down
        keybd_event VK_SNAPSHOT, 1, VK_KEYUP, 0 'Print key Up - Screenshot to Clipboard
     
        'Paste Image in Chart and Export it to Image file. -- Step3
        Charts.Add
        ThisWorkbook.Charts(1).AutoScaling = True
        ThisWorkbook.Charts(1).Paste
        ThisWorkbook.Charts(1).Export Filename:="C:\Temp\ClipBoardToPic.jpg", Filtername:="jpg" 
     
    End Sub
     
    Sub Alt_Tab()
        DoEvents
        keybd_event VK_MENU, 1, 0, 0 'Alt key down
        DoEvents
        keybd_event VK_TAB, 0, 0, 0 'Tab key down
        DoEvents
        keybd_event VK_TAB, 1, VK_KEYUP, 0 'Tab key up
        DoEvents
        keybd_event VK_ENTER, 1, 0, 0 'Tab key down
        DoEvents
        keybd_event VK_ENTER, 1, VK_KEYUP, 0 'Tab key up
        DoEvents
        keybd_event VK_MENU, 1, VK_KEYUP, 0 'Alt key up
        DoEvents
    End Sub
    
    Sub SendEmail()
    On Error Resume Next
    Application.ScreenUpdating = False
    Call CaptureMe
    Dim olApp As Object '/Outlook.Application
    Set olApp = CreateObject("outlook.application")
    Dim olMail As Object '/Outlook.mailitem
    Set olMail = olApp.CreateItem(olmailitem)
    olMail.To = "YourMail@Gmail.com"
    olMail.Subject = "IST End of Day snapshots as of 21 April 2017 " ' or use this : & Format(Now - 1, "dd Mmm YYYY")
    'olMail.body = "Good Morning, This Is Detail Dashboard for Today"
    olMail.HTMLBody = "<br>Good Morning, This Is Detail Dashboard for Today<br>" _
                    & "<img src='C:\Temp\ClipBoardToPic.jpg'" & "width='500' height='200'><br>" _
                    & "<br>Best Regards, <br>YourNameHere</font></span>"
    olMail.send
    
    OutApp.Session.Logoff
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    End Sub
    

    Versi 2 yg lebih simple dengan Sendkeys methode :

    Sub SendEmailV2()
    
    'Version : 2
    'simle way : using sendkeys mode + wait 
    Dim OutApp As Object
    Dim OutMail As Object
    
    'Shift-Print Screen
    Application.SendKeys "(%{1068})"
    On Error Resume Next
    
    'Prepare the email
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
    With OutMail
    .To = "Fujiansyah.achmad@dhl.com"
    .Subject = "IST End of Day snapshots as of 21 April 2017 " ' or use this : & Format(Now - 1, "dd Mmm YYYY")
    .Display
    
    Application.Wait Now + TimeValue("00:00:01")
    Application.SendKeys ("Good Morning, This Is Detail Dashboard for Today")
    Application.SendKeys ("{ENTER}")
    Application.Wait Now + TimeValue("00:00:01")
    Application.SendKeys "(^v)"
    Application.Wait Now + TimeValue("00:00:01")
    Application.SendKeys "(%S)"
    
    End With
    On Error GoTo 0
    
    OutApp.Session.Logoff
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    End Sub
    

    semoga sedikit membantu

    [attachment:590153bf7cd55]

  2. Fujiansyah92

    27 Apr 2017 Terverifikasi Jawaban Terpilih + 4.126 Poin
    Di sunting 2 tahun lalu oleh Fujiansyah92

    Coba Paka ini dh

    Versi 1 (modif dari ente punya+ sedikit Api unggun) :

    'Declare Windows API Functions
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
      bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
     
    'Declare Virtual Key Codes
    Private Const VK_SNAPSHOT = &H2C
    Private Const VK_KEYUP = &H2
    Private Const VK_MENU = &H12
    Public Const VK_TAB = &H9
    Public Const VK_ENTER = &HD
     
    Sub CaptureMe()
    Application.ScreenUpdating = False
        'Press Alt + TAB Keys -- Step1
        Alt_Tab
     
        'Press Print Screen key using Windows API -- Step2.
        keybd_event VK_SNAPSHOT, 1, 0, 0 'Print Screen key down
        keybd_event VK_SNAPSHOT, 1, VK_KEYUP, 0 'Print key Up - Screenshot to Clipboard
     
        'Paste Image in Chart and Export it to Image file. -- Step3
        Charts.Add
        ThisWorkbook.Charts(1).AutoScaling = True
        ThisWorkbook.Charts(1).Paste
        ThisWorkbook.Charts(1).Export Filename:="C:\Temp\ClipBoardToPic.jpg", Filtername:="jpg" 
     
    End Sub
     
    Sub Alt_Tab()
        DoEvents
        keybd_event VK_MENU, 1, 0, 0 'Alt key down
        DoEvents
        keybd_event VK_TAB, 0, 0, 0 'Tab key down
        DoEvents
        keybd_event VK_TAB, 1, VK_KEYUP, 0 'Tab key up
        DoEvents
        keybd_event VK_ENTER, 1, 0, 0 'Tab key down
        DoEvents
        keybd_event VK_ENTER, 1, VK_KEYUP, 0 'Tab key up
        DoEvents
        keybd_event VK_MENU, 1, VK_KEYUP, 0 'Alt key up
        DoEvents
    End Sub
    
    Sub SendEmail()
    On Error Resume Next
    Application.ScreenUpdating = False
    Call CaptureMe
    Dim olApp As Object '/Outlook.Application
    Set olApp = CreateObject("outlook.application")
    Dim olMail As Object '/Outlook.mailitem
    Set olMail = olApp.CreateItem(olmailitem)
    olMail.To = "YourMail@Gmail.com"
    olMail.Subject = "IST End of Day snapshots as of 21 April 2017 " ' or use this : & Format(Now - 1, "dd Mmm YYYY")
    'olMail.body = "Good Morning, This Is Detail Dashboard for Today"
    olMail.HTMLBody = "<br>Good Morning, This Is Detail Dashboard for Today<br>" _
                    & "<img src='C:\Temp\ClipBoardToPic.jpg'" & "width='500' height='200'><br>" _
                    & "<br>Best Regards, <br>YourNameHere</font></span>"
    olMail.send
    
    OutApp.Session.Logoff
    Set OutMail = Nothing
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    End Sub
    

    Versi 2 yg lebih simple dengan Sendkeys methode :

    Sub SendEmailV2()
    
    'Version : 2
    'simle way : using sendkeys mode + wait 
    Dim OutApp As Object
    Dim OutMail As Object
    
    'Shift-Print Screen
    Application.SendKeys "(%{1068})"
    On Error Resume Next
    
    'Prepare the email
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
    With OutMail
    .To = "Fujiansyah.achmad@dhl.com"
    .Subject = "IST End of Day snapshots as of 21 April 2017 " ' or use this : & Format(Now - 1, "dd Mmm YYYY")
    .Display
    
    Application.Wait Now + TimeValue("00:00:01")
    Application.SendKeys ("Good Morning, This Is Detail Dashboard for Today")
    Application.SendKeys ("{ENTER}")
    Application.Wait Now + TimeValue("00:00:01")
    Application.SendKeys "(^v)"
    Application.Wait Now + TimeValue("00:00:01")
    Application.SendKeys "(%S)"
    
    End With
    On Error GoTo 0
    
    OutApp.Session.Logoff
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    End Sub
    

    semoga sedikit membantu

    Send Email VBA.xlsm

  3. tahun lalu

    Thanks sepuh sunggu membantu hihihihi

 

atau Mendaftar untuk ikut berdiskusi!