Page 1 of 1
[vba] send auto mail
Posted: Fri Aug 11, 2017 2:06 pm
by kannaree
สวัสดีคะอาจารย์และทุกๆท่าน
ฉันอยากจะทราบว่าเราสามารถ vlookup จากชื่อไฟล์ในโฟลเดอร์ได้หรือไม่ อย่างไรคะ
คือต้องการให้คลิกปุ่ม auto send mail
แล้วให้ vlookup หา file จาก folder ที่เก็บไว้ ถ้าชื่อไฟล์เหมือน column ให้ส่งเมล์ ตาม column [D]
ไม่ทราบว่า สามารถวนลูปได้ในลักษณะไหนคะ พอดีตอนนี้ fixไว้
folder :
[attachment=2]1.png[/attachment]
vlookup จาก sheets database
[attachment=1]2.png[/attachment]
send e-mail พร้อมแนบไฟล์
[attachment=0]3.png[/attachment]
Code :
[code]'------------------ Send auto e-mail to supplier ---------------------
Private Sub CommandButton5_Click()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim obAttachment As Object, EmbedObject As Object
Dim stSubject As Variant, stAttachment As String, stsupplier As String
Dim vaRecipient As Variant, vaMsg As Variant
Const EMBED_ATTACHMENT As Long = 1454
Const stTitle As String = "Status Active workbook"
Const stMsg As String = "The active workbook must first be saved " & vbCrLf _
& "before it can be sent as an attachment."
'Check if the active workbook is saved or not
'If the active workbook has not been saved at all.
If Len(ActiveWorkbook.Path) = 0 Then
MsgBox stMsg, vbInformation, stTitle
Exit Sub
End If
'If the changes in the active workbook has been saved or not.
If ActiveWorkbook.Saved = False Then
If MsgBox("Do you want to save the changes before sending?", _
vbYesNo + vbInformation, stTitle) = vbYes Then _
ActiveWorkbook.Save
End If
'Get the name of the recipient from the user.
'++++++++++++====== send e-mail To ===============================++++++++++++
'Do
' vaRecipient = Application.InputBox(_
' prompt:="Please add the name of the recipient such as:" & vbCrLf_
' & "excel@microsoft.com or just the name if it's internally.",_
' Title:="Recipient", Type:=2)
' Loop While vaRecipient = ""
vaRecipient = "kannaree@svi.co.th" & "," & "svi.kannaree@gmail.com"
'++++++++++++=========================================================++++++++++++
'If the user has canceled the operation.
If vaRecipient = False Then Exit Sub
'Get the message from the user.
'===== Message Body popup (old) ============================
'Do
' vaMsg = Application.InputBox( _
' Prompt:="Please enter the message such as:" & vbCrLf _
' & "Enclosed please find the weekly report.", _
' Title:="Message", Type:=2)
'Loop While vaMsg = ""
vaMsg = "Dear Supplier," & vbNewLine _
& "Please be reminded to submit the price in SupplyWin." & vbNewLine & "Need your prompt response to complete the project within due date." & vbNewLine _
& "" & vbNewLine & "By the way, you can quote by return email to us." & "" & vbNewLine & vbNewLine & "Please noted that un price or no bidding, please reply with the reason"
'++++++++++++=========================================================++++++++++++
'If the user has canceled the operation.
If vaMsg = False Then Exit Sub
'Add the subject to the outgoing e-mail which also can be retrieved from the users
'in a similar way as above.
stSubject = "RFQunprice"
stsupplier = "3M THAILAND LIMITED"
'Retrieve the path and filename of the active workbook.
'stAttachment = ActiveWorkbook.FullName
stAttachment = "C:\Users\PUR_Kannaree\Desktop\File RFQ\fon\File send mail\3M THAILAND LIMITED.xlsx"
'Instantiate the Lotus Notes COM's Objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'If Lotus Notes is not open then open the mail-part of it.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the e-mail and the attachment.
Set noDocument = noDatabase.CreateDocument
Set obAttachment = noDocument.CreateRichTextItem("stAttachment")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
'Add values to the created e-mail main properties.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject & Format(Date, " mm/dd/yyyy") & "_" & stsupplier
.Body = vaMsg
.SaveMessageOnSend = True
End With
'Send the e-mail.
With noDocument
.PostedDate = Now()
.Send 0, vaRecipient
End With
'Release objects from the memory.
Set EmbedObject = Nothing
Set obAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'Activate Excel for the user.
AppActivate "Microsoft Excel"
MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End Sub
[/code]
ขอบคุณค่ะ
Re: [vba] send auto mail
Posted: Fri Aug 11, 2017 2:08 pm
by kannaree
Re: [vba] send auto mail
Posted: Sat Aug 12, 2017 8:40 pm
by snasui
ช่วยแจ้ง Procedure ที่ติดปัญหา บรรทัดที่ติดปัญหา ขั้นตอนการทดสอบ จะได้เข้าถึงปัญหาโดยเร็วครับ
Re: [vba] send auto mail
Posted: Tue Aug 15, 2017 8:23 am
by kannaree
อยากทราบว่าเราสามารถเอาข้อมูลจาก sheets ไป vlookup กับชื่อไฟล์ได้หรือไม่ อย่างไรคะอาจารย์
ขอบคุณค่ะ
Re: [vba] send auto mail
Posted: Tue Aug 15, 2017 9:50 pm
by snasui
สามารถทำได้ครับ
ลักษณะการทำงานคือ Loop เข้าไปยัง Folder ที่ต้องการหากพบไฟล์ตามที่ต้องการจึงจะส่งอีเมล ลองค้นหา Code สำหรับการ Loop ไฟล์ใน Folder มาปรับใช้ดู ติดตรงไหนค่อยถามกันต่อครับ
Re: [vba] send auto mail
Posted: Fri Aug 18, 2017 3:16 pm
by kannaree
ทำได้แล้วค่ะ อาจารย์แต่ติดปัญหาตรงวนลูป จริง ๆ ตั้งข้อมูลไว้แค่ 3 ลูกค้า
(ตามรูป)
1.png
แต่ข้อมูลส่งเมล์ ติด loop แถมไฟล์ก็ไม่ถูกแนบไป***
2.png
Code: Select all
'------------------ Send auto e-mail to supplier ---------------------
Private Sub CommandButton5_Click()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim obAttachment As Object, EmbedObject As Object, stPath As Object
Dim stSubject As Variant, stAttachment As String, stsupplier As String
Dim vaRecipient As Variant, subMsg, vaMsg, NameMsg, signMsg, posMsg, contMsg, strMsg As Variant
Dim MyObj As Object, MySource As Object, file As Variant
Dim stFile As String
Dim FName As String
Const EMBED_ATTACHMENT As Long = 1454
Const stTitle As String = "Status Active workbook"
Const stMsg As String = "The active workbook must first be saved " & vbCrLf _
& "before it can be sent as an attachment."
Worksheets("tempsheet").Activate
'found file in folder --------------------------------------------------------------------------------------------
file = Dir("C:\Users\PUR_Kannaree\Desktop\File RFQ\fon\File send mail\")
While (file <> "")
Dim i, LastRow As Long
Dim fnst As String
With Sheets("tempsheet")
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
End With
If LastRow > 0 Then
For i = 2 To LastRow
fnst = Range("A" & i).Value
'MsgBox "" & fnst
'MsgBox "" & i
'MsgBox "" & LastRow
FName = fnst
If InStr(file, FName) > 0 Then
'MsgBox "found " & file
stFile = file
'Exit Sub
End If
file = Dir
'Next i
'End If
'Wend
'vlookup send email--------------------------------------------------------------------------------------------------------------------
Dim rng As String
Dim ws1, ws2 As Worksheet
Dim MyStringVar1 As String
Dim r, LastRow1 As Long
Set ws1 = ThisWorkbook.Sheets("Database_supplier")
Set ws2 = ThisWorkbook.Sheets("tempsheet")
With Sheets("tempsheet")
LastRow1 = Cells(Rows.Count, "A").End(xlUp).Row
End With
If LastRow1 > 1 Then
For r = 2 To LastRow
rng = Range("A" & r).Value
'MsgBox "" & rng
stFile = rng
LastRow1 = LastRow1 - 1
MsgBox "" & LastRow1
With ws2
On Error Resume Next 'add this because if value is not found, vlookup fails, you get 1004
MyStringVar1 = Application.WorksheetFunction.VLookup(rng, ws1.Range("C2:D2740").Value, 2, False)
On Error GoTo 0
If MyStringVar1 = "" Then
MsgBox "Item not found"
End If
'MsgBox MyStringVar1
'End With
'Next r
'End If
'--------------------------------------------------------------------------------------------------------------------
'Check if the active workbook is saved or not
'If the active workbook has not been saved at all.
If Len(ActiveWorkbook.Path) = 0 Then
MsgBox stMsg, vbInformation, stTitle
Exit Sub
End If
'If the changes in the active workbook has been saved or not.
If ActiveWorkbook.Saved = False Then
If MsgBox("Do you want to save the changes before sending?", _
vbYesNo + vbInformation, stTitle) = vbYes Then _
ActiveWorkbook.Save
End If
'Get the name of the recipient from the user.
vaRecipient = MyStringVar1
'Array("Joe_Boe@somewhere.com", "kristen_Dean@somewhere.com", "john_doe@somewhereelse.com", "jane.doe@anotherplace.com")
'If the user has canceled the operation.
If vaRecipient = False Then Exit Sub
'Get the message from the user.
subMsg = "Dear Supplier," & vbNewLine
vaMsg = vbNewLine & " " & "Please be reminded to submit the price in SupplyWin." & vbNewLine & " " & "Need your prompt response to complete the project within due date." & vbNewLine _
& "" & vbNewLine & " " & "By the way, you can quote by return email to us." & "" & vbNewLine & vbNewLine & " " & "Please noted that un price or no bidding, please reply with the reason" & vbNewLine
signMsg = vbNewLine & vbNewLine & vbNewLine & "Best regards,"
NameMsg = vbNewLine & vbNewLine & vbNewLine & " " & "Ms.Nuttaya sirisongprakob (Prim) "
posMsg = vbNewLine & " " & " " & " " & "Sourcing Officer"
contMsg = vbNewLine & "SVI PUBLIC COMPANY LIMITED" & vbNewLine & " Tel. : +66 2105 0456 ext. 1323" & vbNewLine & " Fax. : +66 2105 0464-5" & vbNewLine & " E-mail :Nuttaya@svi.co.th" & vbNewLine & "Skype ID :Nuttaya_pp" & vbNewLine & "Website : www.svi.co.th"
strMsg = vbNewLine & "******************************************"
'If the user has canceled the operation.
If vaMsg = False Then Exit Sub
'Add the subject to the outgoing e-mail which also can be retrieved from the users
'in a similar way as above.
stSubject = "RFQunprice"
stsupplier = stFile
'Retrieve the path and filename of the active workbook.
stAttachment = "C:\Users\PUR_Kannaree\Desktop\File RFQ\fon\File send mail\" & stFile
'Instantiate the Lotus Notes COM's Objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'If Lotus Notes is not open then open the mail-part of it.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the e-mail and the attachment.
Set noDocument = noDatabase.CreateDocument
Set obAttachment = noDocument.CreateRichTextItem("stAttachment")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
'Add values to the created e-mail main properties.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.copyTo = ""
.Subject = stSubject & Format(Date, " mm/dd/yyyy") & "_" & stsupplier
.Body = subMsg & vaMsg & signMsg & NameMsg & posMsg & strMsg & contMsg & strMsg
.SaveMessageOnSend = True
End With
'Send the e-mail.
With noDocument
.PostedDate = Now()
.Send 0, vaRecipient
End With
'Release objects from the memory.
Set EmbedObject = Nothing
Set obAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'Activate Excel for the user.
AppActivate "Microsoft Excel"
'MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End With
Next r
End If
Next i
End If
Wend
MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End Sub
* รบกวนขอคำแนะนำจากอาจารย์และผู้มึความรู้ทุกท่านด้วยค่ะ
Re: [vba] send auto mail
Posted: Fri Aug 18, 2017 3:22 pm
by kannaree
แนบไฟล์งานเพื่อทดสอบ
Test.xlsm
1. Click
3.png
2. ระบุ pathfile ที่จะแตกไฟล์แยกตามลูกค้า
4.png
Re: [vba] send auto mail
Posted: Fri Aug 18, 2017 3:24 pm
by kannaree
ต่อ
3.ตัวอย่าง Result ที่ได้ทำการแตกไฟล์
5.png
4. Click ปุ่มเพื่อส่งอีเมล์ อัตโนมัติ *ฟังก์ชั่นที่เกิดปัญหา
6.png
ขอบคุณมากค่ะ
Re: [vba] send auto mail
Posted: Sat Aug 19, 2017 8:12 am
by snasui
เท่าที่ดูโค้ดจะเป็นการส่งอีเมลผ่าน Lotus Note ซึ่งผมไม่สามารถจะทดสอบให้ได้เนื่องจากไม่ได้ใช้ Lotus Note ครับ
นอกจากนั้นการจะตรวจสอบว่ามีไฟล์ใน Folder นั้นหรือไม่จำเป็นต้องใช้โค้ดเข้าไปตรวจสอบใน Folder เป้าหมายเสียก่อนว่ามีไฟล์ที่ต้องการหรือไม่ หากมีค่อยแนบเข้าไปกับอีเมล เช่นใช้ Function เข้ามาช่วยตรวจสอบ หากเจอให้คืนค่าเป็น True หากไม่เจอให้คืนค่าเป็น False เพื่อที่จะนำค่า True หรือ False นี้ไปใช้กับการตัดสินใจในขั้นตอนการส่งอีเมล เช่นนี้เป็นต้นครับ
Re: [vba] send auto mail
Posted: Mon Aug 21, 2017 8:53 am
by kannaree
ขอบคุณมากค่ะ อาจารย์ หนูสามารถแนบไฟล์ไปได้แล้ว แต่หนูคิดว่า หนูน่าจะวน Loop ผิด
จึงอยากให้อาจารย์ช่วยตรวจสอบโค้ดให้หน่อยได้ไหมค่ะเพราะว่า กดส่งเมล์แล้ว มัน วน loop ไม่รู้จบ ค่ะ
Code: Select all
'------------------ Send auto e-mail to supplier ---------------------
Private Sub CommandButton5_Click()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim obAttachment As Object, EmbedObject As Object, stPath As Object
Dim stSubject As Variant, stAttachment As String, stsupplier As String
Dim vaRecipient As Variant, subMsg, vaMsg, NameMsg, signMsg, posMsg, contMsg, strMsg As Variant
Dim MyObj As Object, MySource As Object, file As Variant
Dim stFile As String
Dim FName As String
Const EMBED_ATTACHMENT As Long = 1454
Const stTitle As String = "Status Active workbook"
Const stMsg As String = "The active workbook must first be saved " & vbCrLf _
& "before it can be sent as an attachment."
Worksheets("tempsheet").Activate
'found file in folder --------------------------------------------------------------------------------------------
file = Dir("C:\Users\PUR_Kannaree\Desktop\File RFQ\fon\File send mail\")
While (file <> "")
Dim i, LastRow As Long
Dim fnst As String
With Sheets("tempsheet")
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
End With
If LastRow > 0 Then
For i = 2 To LastRow
fnst = Range("A" & i).Value
'MsgBox "" & fnst
'MsgBox "" & i
'MsgBox "" & LastRow
FName = fnst
If InStr(file, FName) > 0 Then
'MsgBox "found " & file
stFile = file
'Exit Sub
End If
file = Dir
'Next i
'End If
'Wend
'vlookup send email--------------------------------------------------------------------------------------------------------------------
Dim rng As String
Dim ws1, ws2 As Worksheet
Dim MyStringVar1 As String
Dim r, LastRow1 As Long
Set ws1 = ThisWorkbook.Sheets("Database_supplier")
Set ws2 = ThisWorkbook.Sheets("tempsheet")
With Sheets("tempsheet")
LastRow1 = Cells(Rows.Count, "A").End(xlUp).Row
End With
If LastRow1 > 1 Then
For r = 2 To LastRow
rng = Range("A" & r).Value
'MsgBox "" & rng
stFile = rng
LastRow1 = LastRow1 - 1
MsgBox "" & LastRow1
With ws2
On Error Resume Next 'add this because if value is not found, vlookup fails, you get 1004
MyStringVar1 = Application.WorksheetFunction.VLookup(rng, ws1.Range("C2:D2740").Value, 2, False)
On Error GoTo 0
If MyStringVar1 = "" Then
MsgBox "Item not found"
End If
'MsgBox MyStringVar1
'End With
'Next r
'End If
'--------------------------------------------------------------------------------------------------------------------
'Check if the active workbook is saved or not
'If the active workbook has not been saved at all.
If Len(ActiveWorkbook.Path) = 0 Then
MsgBox stMsg, vbInformation, stTitle
Exit Sub
End If
'If the changes in the active workbook has been saved or not.
If ActiveWorkbook.Saved = False Then
If MsgBox("Do you want to save the changes before sending?", _
vbYesNo + vbInformation, stTitle) = vbYes Then _
ActiveWorkbook.Save
End If
'Get the name of the recipient from the user.
vaRecipient = MyStringVar1
'Array("Joe_Boe@somewhere.com", "kristen_Dean@somewhere.com", "john_doe@somewhereelse.com", "jane.doe@anotherplace.com")
'If the user has canceled the operation.
If vaRecipient = False Then Exit Sub
'Get the message from the user.
subMsg = "Dear Supplier," & vbNewLine
vaMsg = vbNewLine & " " & "Please be reminded to submit the price in SupplyWin." & vbNewLine & " " & "Need your prompt response to complete the project within due date." & vbNewLine _
& "" & vbNewLine & " " & "By the way, you can quote by return email to us." & "" & vbNewLine & vbNewLine & " " & "Please noted that un price or no bidding, please reply with the reason" & vbNewLine
signMsg = vbNewLine & vbNewLine & vbNewLine & "Best regards,"
NameMsg = vbNewLine & vbNewLine & vbNewLine & " " & "Ms.Nuttaya sirisongprakob (Prim) "
posMsg = vbNewLine & " " & " " & " " & "Sourcing Officer"
contMsg = vbNewLine & "SVI PUBLIC COMPANY LIMITED" & vbNewLine & " Tel. : +66 2105 0456 ext. 1323" & vbNewLine & " Fax. : +66 2105 0464-5" & vbNewLine & " E-mail :Nuttaya@svi.co.th" & vbNewLine & "Skype ID :Nuttaya_pp" & vbNewLine & "Website : www.svi.co.th"
strMsg = vbNewLine & "******************************************"
'If the user has canceled the operation.
If vaMsg = False Then Exit Sub
'Add the subject to the outgoing e-mail which also can be retrieved from the users
'in a similar way as above.
stSubject = "RFQunprice"
stsupplier = stFile
'Retrieve the path and filename of the active workbook.
stAttachment = "C:\Users\PUR_Kannaree\Desktop\File RFQ\fon\File send mail\" & stFile & ".xlsx"
'Instantiate the Lotus Notes COM's Objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'If Lotus Notes is not open then open the mail-part of it.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the e-mail and the attachment.
Set noDocument = noDatabase.CreateDocument
Set obAttachment = noDocument.CreateRichTextItem("stAttachment")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
'Add values to the created e-mail main properties.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.copyTo = ""
.Subject = stSubject & Format(Date, " mm/dd/yyyy") & "_" & stsupplier
.Body = subMsg & vaMsg & signMsg & NameMsg & posMsg & strMsg & contMsg & strMsg
.SaveMessageOnSend = True
End With
'Send the e-mail.
With noDocument
.PostedDate = Now()
.Send 0, vaRecipient
End With
'Release objects from the memory.
Set EmbedObject = Nothing
Set obAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'Activate Excel for the user.
AppActivate "Microsoft Excel"
'MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End With
Next r
End If
Next i
End If
Wend
MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End Sub
1.png
Re: [vba] send auto mail
Posted: Tue Aug 22, 2017 5:07 am
by snasui
เกิดจากการใช้
While...Wend ครับ
จาก Code ด้านล่างนี้
Code: Select all
file = Dir("C:\Users\PUR_Kannaree\Desktop\File RFQ\fon\File send mail\")
While (file <> "")
'Other code ...
Wend
จะเกิด Loop ไม่สิ้นสุด หากมี Folder
C:\Users\PUR_Kannaree\Desktop\File RFQ\fon\File send mail\ อยู่จริง เพราะเป็นการตรวจสอบค่าว่า File ไม่เป็นค่าว่าง
ลักษณะ Code ควรจะเป็นเช่นที่ผมแจ้งไปแล้ว คือ ให้ตรวจสอบไฟล์ใน Folder ว่ามีอยู่จริงหรือไม่ มีจริงแล้วค่อยแนบไฟล์ เช่นตาม Link นี้
http://www.snasui.com/viewtopic.php?t=4645 แล้วปรับใช้ดูติดตรงไหนค่อยถามกันต่อครับ
Re: [vba] send auto mail
Posted: Wed Aug 23, 2017 9:31 am
by kannaree
สามารถทำได้แล้วคะอาจารย์ พอดีว่าหนูทำ loop for ซ้อนกัน ตอนนี้สามารถแก้ปัญหาการส่งเมล์ได้แล้วค่ะ
ขอถามอีกคำถามนะคะอาจารย์ พอดีว่า จากโค้ดหนู Vloopup ไปหา sheets database เมื่อได้ Name ตรง และส่งเมล์ตาม column D
1.png
จะเห็นว่าถ้ามีหลายอีเมล์เราจะส่งไปได้อย่างไรค่ะ MyStringVar1 เราจะเขียนรับค่า array จาก vba ในลักษณะนี้ได้อย่างไรค่ะ เพราะความยาวอีเมล์ไม่สามารถกำหนดได้
3.png
Code: Select all
'------------------ Send auto e-mail to supplier ---------------------
Private Sub CommandButton5_Click()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim obAttachment As Object, EmbedObject As Object, stPath As Object
Dim stSubject As Variant, stAttachment As String, stsupplier As String
Dim vaRecipient As Variant, subMsg, vaMsg, NameMsg, signMsg, posMsg, contMsg, strMsg As Variant
Dim MyObj As Object, MySource As Object, file As Variant
Dim stFile As String
Dim FName As String
Const EMBED_ATTACHMENT As Long = 1454
Const stTitle As String = "Status Active workbook"
Const stMsg As String = "The active workbook must first be saved " & vbCrLf _
& "before it can be sent as an attachment."
Worksheets("tempsheet").Activate
'found file in folder --------------------------------------------------------------------------------------------
file = Dir("C:\Users\PUR_Kannaree\Desktop\File RFQ\fon\File send mail\")
While (file <> "")
Dim i, LastRow As Long
Dim fnst As String
With Sheets("tempsheet")
LastRow = Cells(Rows.count, "A").End(xlUp).Row
End With
If LastRow > 0 Then
For i = 2 To LastRow
fnst = Range("A" & i).Value
FName = fnst
If InStr(file, FName) > 0 Then
stFile = file
End If
file = Dir
'vlookup send email--------------------------------------------------------------------------------------------------------------------
Dim rng As String
Dim ws1, ws2 As Worksheet
Dim MyStringVar1 As String
Dim r, LastRow1 As Long
Set ws1 = ThisWorkbook.Sheets("Database_supplier")
Set ws2 = ThisWorkbook.Sheets("tempsheet")
With Sheets("tempsheet")
LastRow1 = Cells(Rows.count, "A").End(xlUp).Row
End With
If LastRow1 > 0 Then
rng = Range("A" & i).Value
stFile = rng
With ws2
On Error Resume Next 'add this because if value is not found, vlookup fails, you get 1004
MyStringVar1 = Application.WorksheetFunction.VLookup(rng, ws1.Range("C2:D2740").Value, 2, False)
On Error GoTo 0
If MyStringVar1 = "" Then
'MsgBox "" & MyStringVar1
'MsgBox "Item not found"
End If
'--------------------------------------------------------------------------------------------------------------------
'Check if the active workbook is saved or not
'If the active workbook has not been saved at all.
If Len(ActiveWorkbook.Path) = 0 Then
MsgBox stMsg, vbInformation, stTitle
Exit Sub
End If
'If the changes in the active workbook has been saved or not.
If ActiveWorkbook.Saved = False Then
If MsgBox("Do you want to save the changes before sending?", _
vbYesNo + vbInformation, stTitle) = vbYes Then _
ActiveWorkbook.Save
End If
'Get the name of the recipient from the user.
vaRecipient = MyStringVar1
'Array("Joe_Boe@somewhere.com", "kristen_Dean@somewhere.com", "john_doe@somewhereelse.com", "jane.doe@anotherplace.com")
'If the user has canceled the operation.
If vaRecipient = False Then Exit Sub
'Get the message from the user.
subMsg = "Dear Supplier," & vbNewLine
vaMsg = vbNewLine & " " & "Please be reminded to submit the price in SupplyWin." & vbNewLine & " " & "Need your prompt response to complete the project within due date." & vbNewLine _
& "" & vbNewLine & " " & "By the way, you can quote by return email to us." & "" & vbNewLine & vbNewLine & " " & "Please noted that un price or no bidding, please reply with the reason" & vbNewLine
signMsg = vbNewLine & vbNewLine & vbNewLine & "Best regards,"
NameMsg = vbNewLine & vbNewLine & vbNewLine & " " & "Ms.Nuttaya sirisongprakob (Prim) "
posMsg = vbNewLine & " " & " " & " " & "Sourcing Officer"
contMsg = vbNewLine & "SVI PUBLIC COMPANY LIMITED" & vbNewLine & " Tel. : +66 2105 0456 ext. 1323" & vbNewLine & " Fax. : +66 2105 0464-5" & vbNewLine & " E-mail :Nuttaya@svi.co.th" & vbNewLine & "Skype ID :Nuttaya_pp" & vbNewLine & "Website : www.svi.co.th"
strMsg = vbNewLine & "******************************************"
'If the user has canceled the operation.
If vaMsg = False Then Exit Sub
'Add the subject to the outgoing e-mail which also can be retrieved from the users
'in a similar way as above.
stSubject = "RFQunprice"
stsupplier = stFile
'Retrieve the path and filename of the active workbook.
stAttachment = "C:\Users\PUR_Kannaree\Desktop\File RFQ\fon\File send mail\" & stFile & ".xlsx"
'Instantiate the Lotus Notes COM's Objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'If Lotus Notes is not open then open the mail-part of it.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the e-mail and the attachment.
Set noDocument = noDatabase.CreateDocument
Set obAttachment = noDocument.CreateRichTextItem("stAttachment")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
'Add values to the created e-mail main properties.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.copyTo = ""
.Subject = stSubject & Format(Date, " mm/dd/yyyy") & "_" & stsupplier
.Body = subMsg & vaMsg & signMsg & NameMsg & posMsg & strMsg & contMsg & strMsg
.SaveMessageOnSend = True
End With
'Send the e-mail.
With noDocument
.PostedDate = Now()
.Send 0, vaRecipient
End With
'Release objects from the memory.
Set EmbedObject = Nothing
Set obAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'Activate Excel for the user.
AppActivate "Microsoft Excel"
'MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End With
End If
Next i
End If
MsgBox "The e-mail has successfully been created and distributed.", vbInformation
Exit Sub
Wend
End Sub
Re: [vba] send auto mail
Posted: Wed Aug 23, 2017 9:32 am
by kannaree
Re: [vba] send auto mail
Posted: Wed Aug 23, 2017 6:52 pm
by snasui
หากหมายถึงตามที่ลูกศรชี้ในภาพซึ่งเป็นอีเมลหลายอีเมลในข้อความเดียว ปกติถ้าส่งด้วย Outlook มันจะแปลงเครื่องหมาย , ให้เป็น ; เพื่อแยกระหว่างอีเมลได้ ส่วนของ Lotus Note หากว่าไม่สามารถแปลงได้อัตโนมัติจะต้องแปลงด้วย Code ครับ
เช่นหลังจากรับค่าจาก Vlookup มาแล้วก็นำ MyStringVar1 มาแปลงอีกทีเป็น
Replace(MyStringVar1,",",";")
หรือหากไม่ใช่ที่ต้องการ กรุณาอธิบายมาอีกรอบครับ
Re: [vba] send auto mail
Posted: Thu Aug 24, 2017 9:02 am
by kannaree
ขอบคุณค่ะอาจารย์ ต้องการแบบนี้ถูกแล้วค่ะ แต่ว่า Lotus notes ไม่สามารถส่งเมล์ไปได้หลายเมล์ หนูลอง ทำตามที่อาจารย์บอก
อีเมล์จะอยู่ในลักษณะนี้
svi.kannaree@gmail.com;
kannaree@svi.co.th, ซึ่งไม่สามารถส่งได้
หนูเลยลองทดสอบ โดยการ copy อีเมล์และส่ง manual เพื่อตรวจสอบ string
(ตามรูป1) สามารถส่งออกไป 2 เมล์ได้
1.png
svi.kannaree@gmail.com,
kannaree@svi.co.th,
หนูเลยลองไปเปรียบเทียบ string ให้อยู่ในรูปแบบที่ถูกต้อง
จึงเปลี่ยน code เป็นลักษณะนี้
Code: Select all
Dim LResult As String
LResult = Replace(MyStringVar1, ",", ", ")
ซึ่ง string ที่ถูกส่งออกไปในตัวแปร LResult เมื่อเปรียบเทียบกับ String ด้านบน อักขระเท่ากันทุกประการ
svi.kannaree@gmail.com,
kannaree@svi.co.th,
2.png
จะทำอย่างไรดีค่ะ