Snasui Excel Forum

#15

ขอบคุณค่ะอาจารย์ ต้องการแบบนี้ถูกแล้วค่ะ แต่ว่า Lotus notes ไม่สามารถส่งเมล์ไปได้หลายเมล์ หนูลอง ทำตามที่อาจารย์บอก
อีเมล์จะอยู่ในลักษณะนี้ svi.kannaree@gmail.com;kannaree@svi.co.th, ซึ่งไม่สามารถส่งได้

หนูเลยลองทดสอบ โดยการ copy อีเมล์และส่ง manual เพื่อตรวจสอบ string
(ตามรูป1) สามารถส่งออกไป 2 เมล์ได้

: 1.png (7.1 KiB) Viewed 174 times

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 (10.53 KiB) Viewed 174 times

จะทำอย่างไรดีค่ะ

#14

หากหมายถึงตามที่ลูกศรชี้ในภาพซึ่งเป็นอีเมลหลายอีเมลในข้อความเดียว ปกติถ้าส่งด้วย Outlook มันจะแปลงเครื่องหมาย , ให้เป็น ; เพื่อแยกระหว่างอีเมลได้ ส่วนของ Lotus Note หากว่าไม่สามารถแปลงได้อัตโนมัติจะต้องแปลงด้วย Code ครับ

เช่นหลังจากรับค่าจาก Vlookup มาแล้วก็นำ MyStringVar1 มาแปลงอีกทีเป็น

Replace(MyStringVar1,",",";")

หรือหากไม่ใช่ที่ต้องการ กรุณาอธิบายมาอีกรอบครับ

#13

*แนบรูปแรกผิดค่ะ

: 1.png (88.71 KiB) Viewed 185 times

#12

สามารถทำได้แล้วคะอาจารย์ พอดีว่าหนูทำ loop for ซ้อนกัน ตอนนี้สามารถแก้ปัญหาการส่งเมล์ได้แล้วค่ะ

ขอถามอีกคำถามนะคะอาจารย์ พอดีว่า จากโค้ดหนู Vloopup ไปหา sheets database เมื่อได้ Name ตรง และส่งเมล์ตาม column D

: 3.png (67.25 KiB) Viewed 186 times

จะเห็นว่าถ้ามีหลายอีเมล์เราจะส่งไปได้อย่างไรค่ะ MyStringVar1 เราจะเขียนรับค่า array จาก vba ในลักษณะนี้ได้อย่างไรค่ะ เพราะความยาวอีเมล์ไม่สามารถกำหนดได้

: 3.png (67.25 KiB) Viewed 186 times

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

#11

เกิดจากการใช้ 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 แล้วปรับใช้ดูติดตรงไหนค่อยถามกันต่อครับ

#10

ขอบคุณมากค่ะ อาจารย์ หนูสามารถแนบไฟล์ไปได้แล้ว แต่หนูคิดว่า หนูน่าจะวน 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 (87.7 KiB) Viewed 205 times

#9

เท่าที่ดูโค้ดจะเป็นการส่งอีเมลผ่าน Lotus Note ซึ่งผมไม่สามารถจะทดสอบให้ได้เนื่องจากไม่ได้ใช้ Lotus Note ครับ

นอกจากนั้นการจะตรวจสอบว่ามีไฟล์ใน Folder นั้นหรือไม่จำเป็นต้องใช้โค้ดเข้าไปตรวจสอบใน Folder เป้าหมายเสียก่อนว่ามีไฟล์ที่ต้องการหรือไม่ หากมีค่อยแนบเข้าไปกับอีเมล เช่นใช้ Function เข้ามาช่วยตรวจสอบ หากเจอให้คืนค่าเป็น True หากไม่เจอให้คืนค่าเป็น False เพื่อที่จะนำค่า True หรือ False นี้ไปใช้กับการตัดสินใจในขั้นตอนการส่งอีเมล เช่นนี้เป็นต้นครับ

#8

ต่อ

3.ตัวอย่าง Result ที่ได้ทำการแตกไฟล์

: 5.png (106.65 KiB) Viewed 218 times

4. Click ปุ่มเพื่อส่งอีเมล์ อัตโนมัติ *ฟังก์ชั่นที่เกิดปัญหา

: 6.png (39.97 KiB) Viewed 218 times

ขอบคุณมากค่ะ

#7

แนบไฟล์งานเพื่อทดสอบ

Test.xlsm: (399.32 KiB) Downloaded 17 times

1. Click

: 3.png (2.14 KiB) Viewed 219 times

2. ระบุ pathfile ที่จะแตกไฟล์แยกตามลูกค้า

: 4.png (32.09 KiB) Viewed 219 times

#6

ทำได้แล้วค่ะ อาจารย์แต่ติดปัญหาตรงวนลูป จริง ๆ ตั้งข้อมูลไว้แค่ 3 ลูกค้า
(ตามรูป)

: 1.png (10.91 KiB) Viewed 220 times

แต่ข้อมูลส่งเมล์ ติด loop แถมไฟล์ก็ไม่ถูกแนบไป***

: 2.png (161.36 KiB) Viewed 220 times

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

* รบกวนขอคำแนะนำจากอาจารย์และผู้มึความรู้ทุกท่านด้วยค่ะ

#5

สามารถทำได้ครับ

ลักษณะการทำงานคือ Loop เข้าไปยัง Folder ที่ต้องการหากพบไฟล์ตามที่ต้องการจึงจะส่งอีเมล ลองค้นหา Code สำหรับการ Loop ไฟล์ใน Folder มาปรับใช้ดู ติดตรงไหนค่อยถามกันต่อครับ

#4

อยากทราบว่าเราสามารถเอาข้อมูลจาก sheets ไป vlookup กับชื่อไฟล์ได้หรือไม่ อย่างไรคะอาจารย์

ขอบคุณค่ะ

#3

ช่วยแจ้ง Procedure ที่ติดปัญหา บรรทัดที่ติดปัญหา ขั้นตอนการทดสอบ จะได้เข้าถึงปัญหาโดยเร็วครับ

#2

file for test :

Test.rar: (483.67 KiB) Downloaded 15 times

#1

สวัสดีคะอาจารย์และทุกๆท่าน

ฉันอยากจะทราบว่าเราสามารถ 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]



ขอบคุณค่ะ

Snasui Excel Forum

[vba] send auto mail

Post a reply

Expand view Topic review: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

Re: [vba] send auto mail

[vba] send auto mail