ขอวิธีสร้าง Object แทน String ที่จะส่งใน Outlook

[หิรัญ ชัยกุล]

Test Sentemail.xlsm

เรียนอาจารย์/ ผู้รู้ครับ
ผมออกแบบการส่งเมล์เพื่อขออนุมัติการลาโดยได้ลอกโค้ดมาจากมีผู้ให้ความรู้ไว้ทำตามโค้ดนี้ ( ตาม Module1 )ครับ

Code: Select all

Sub SendEmail_Outlook()
Dim OutlookApp As Object
Dim MItem As Object
Dim email_ As String
Dim subject_ As String
Dim body_ As String
Dim CCemail_ As String

Set OutlookApp = CreateObject("Outlook.Application")
email_ = Range("F5").Value
subject_ = Range("B2").Value
body_ = Range("G11").Value
CCemail_ = Range("I5").Value

Set MItem = OutlookApp.CreateItem(0)
With MItem
.To = email_
.CC = CCemail_
.Subject = subject_
.Body = body_ & Chr(13) & Chr(13) & Range("D2") & Chr(13) & Range("E2") & Chr(13) & Range("F2") & Chr(13) & Range("G2") & Chr(13) & Range("H2")
.send
End With
End Sub

แต่สิ่งที่ต้องการคือผมต้องการที่จะส่งแบบฟอร์มใบลานั้นเข้าไปในตัว Body ของ Outlook โดยการสร้างให้เป็น Object (ตาม Module2 ) ครับ

Code: Select all

Sub Object()
'
' Object Macro
'
' Keyboard Shortcut: Ctrl+Shift+E
'
    Range("A1:J37").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Range("K1").Select
    ActiveSheet.Paste
End Sub

นี่ล่ะครับที่เป็นปัญหา ผมพยายามเอา Code ของ Module ที่ 2 ไปว่าในตำแหน่ง Body ของแต่ละบรรทัด ใน Moduleที่1 ไม่สามารถทำได้ครับ จึงอยากขอความรู้ว่าจะสามารถแก้ไขได้อย่างไร
และขอเพิ่มเติม จะแก้ไข Code ของ Module1 ให้ Break การส่งอัตโนมัติ โดยให้ Open Outlook ไว้ก่อนไม่ให้ทำการส่งเมื่อ Run Macro ครับ
พร้อมส่งไฟล์ตัวอย่างมาให้ลองทดสอบครับ
ขอบคุณครับผม

[bank9597]

ลองปรับโค๊ดตามนี้ครับ

Code: Select all

Sub SendEmail_Outlook()

        Dim oOutlook As Object
        Dim OutlookApp As Object
        Dim MItem As Object
        Dim email_ As String
        Dim subject_ As String
        Dim body_ As String
        Dim CCemail_ As String
        Dim objRange As Range
        Dim WshShell As Object
        
        On Error Resume Next
        Set oOutlook = GetObject(, "Outlook.Application")
        On Error GoTo 0
        
        If oOutlook Is Nothing Then
            MsgBox "Outlook is not open, open Outlook and try again"
        Else
            Set objRange = Sheets("Sheet1").Range("J1:A31")
            objRange.Copy
            Set OutlookApp = CreateObject("Outlook.Application")
            
            
            email_ = Range("F5").Value
            subject_ = Range("B2").Value
            body_ = Range("G11").Value
            CCemail_ = Range("I5").Value
            
            Set MItem = OutlookApp.CreateItem(0)
            MItem.Display
    
            With MItem
                
                .To = email_
                .CC = CCemail_
                .Subject = subject_
                Set WshShell = CreateObject("WScript.Shell")
                WshShell.AppActivate MItem
                Call SendKey
    
            End With
        End If
        
Set oOutlook = Nothing
Set OutlookApp = Nothing
Set WshShell = Nothing
Set objRange = Nothing

End Sub

Sub SendKey()
                SendKeys "{TAB}"
                SendKeys "{TAB}"
                SendKeys "{TAB}"
                SendKeys "^v"
End Sub