Page 1 of 3 1 2 3 LastLast
Results 1 to 10 of 23

Thread: Split to files then to Outlook Macro

  1. #1

    Split to files then to Outlook Macro



    Register for a FREE account, and/
    or Log in to avoid these ads!

    Hi,


    I am new member on this site, and i can say that i have well understanding of excel while i'm a novice on vba programming my knowledge is very basic so i have to search for a code that i preferred. i've been searching for a code that will automate the process of a rawdata to filter a specified column, and split each distinct values into a separate file then save into a specified directory, and then e-mail it using outlook to designated recipient and copyee, however i could not find any code that has this process, i only found split to file code from superuser

    i dont know where to insert the outlook code and how to conditionally set the code for recipient and CC based on the vendor name


    i have attached my file, from the spreadsheet there are 2 tabs


    1st tab (Main)
    -here you can find the list of information of all the vendors (even if its not in the rawdata) and their contact address and copyee.
    -on column D, you can put a customized message option in case you dont want to use the default message embedded in the code or you want to composed a different message to the vendor.
    -on top of header a botton to send the email.




    2nd tab (Rawdata)
    -here are the rawdata, basically its only from vendor code(column A) to Fax date only(column M) because i insert the Vendor Name(column N) where you put the same vendor name even if different vendor code so that it can combine all its data in one file only


    you can check the process TAB on the attached for my preffered process.


    Hope that someone will look into this and i appreciate your help.


    Thanks in advance


    JonathanSplitFiles then e-mail.xlsm

  2. #2
    Acolyte jaslake's Avatar
    Join Date
    Aug 2011
    Location
    mineral city oh usa
    Posts
    81
    Articles
    0
    Excel Version
    2007;2010;MAc2011
    Hi Jonathon

    Welcome to the Forum!!!

    The Code can do this or would you prefer to do it manually?

    i insert the Vendor Name(column N) where you put the same vendor name even if different vendor code so that it can combine all its data in one file only
    What would this be?
    the default message embedded in the code
    John

  3. #3
    Acolyte jaslake's Avatar
    Join Date
    Aug 2011
    Location
    mineral city oh usa
    Posts
    81
    Articles
    0
    Excel Version
    2007;2010;MAc2011
    Hi Jonathon

    This Code is in the attached and appears to do as you require. Please Note...Set a reference to Outlook Object Library.

    The Code does this
    insert the Vendor Name(column N) where you put the same vendor name even if different vendor code so that it can combine all its data in one file only
    Code:
    Option Explicit
    Dim srcWB           As Workbook
    Dim srcWS           As Worksheet
    Dim srcLR           As Long
    Dim srcLC           As Long
    Dim srcRng          As Range
    Dim srcCel          As Range
    Dim tgtWB           As Workbook
    Dim tgtLR           As Long
    Dim myPath          As String
    Dim savePath        As String
    Dim DirFile         As String
    Dim i               As Long
    'Set a reference to Outlook Object Library
    Sub CreateVendorFiles()
       Set srcWB = ThisWorkbook   'Workbook running the Code
       Set srcWS = srcWB.Sheets("Rawdata")
       myPath = srcWB.Path & "\"
       savePath = Environ("USERPROFILE") & "\Desktop\Vendor Email"
       If Dir(savePath + "\Split\", vbDirectory) = "" Then
          MkDir savePath + "\Split\"
       End If
       With srcWS
          If Not .AutoFilterMode Then
             .Rows("9:9").AutoFilter
          End If
          srcLR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious).Row
          srcLC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                              SearchDirection:=xlPrevious).Column
          .Range("N9").Value = "Vendor Name"
          Set srcRng = .Range(.Cells(10, "C"), .Cells(srcLR, "C"))
          For Each srcCel In srcRng
             .Cells(srcCel.Row, "N").Value = Trim(Split(srcCel.Value, "-")(1))
          Next srcCel
          If Not Evaluate("ISREF(Lists!A1)") Then
             Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Lists"
          Else
             Sheets("Lists").Cells.Clear
          End If
          .Range(.Cells(9, "N"), .Cells(srcLR, "N")).AdvancedFilter Action:=xlFilterCopy, _
                                                                    CopyToRange:=Sheets("Lists").Range("A1"), Unique:=True
          ActiveWorkbook.Names.Add Name:="Vend_Name", RefersTo:= _
                                   "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
          For Each srcCel In Sheets("Lists").Range("Vend_Name")
             DirFile = savePath & "\Split\" & srcCel.Value & " - " + Format(Now(), "mm.dd.yyyy") & ".xlsx"
             If Len(Dir(DirFile)) = 0 Then   'File does not exist
                .Range("A9:N" & srcLR).AutoFilter Field:=14, Criteria1:=srcCel.Value
                Application.SheetsInNewWorkbook = 1
                Set tgtWB = Workbooks.Add
                With tgtWB.Sheets("Sheet1")
                   srcWS.Range("A9:N" & srcLR).SpecialCells(xlCellTypeVisible).Copy
                   .Range("A1").PasteSpecial Paste:=8
                   .Range("A1").PasteSpecial (xlPasteFormats)
                   .Range("A1").PasteSpecial (xlPasteValues)
                   tgtLR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                                       SearchDirection:=xlPrevious).Row
                   For i = .Range("A" & .Rows.Count).End(xlUp).Row To 3 Step -1
                      If Not .Cells(i, 1).Value = .Cells(i, 1).Offset(-1, 0).Value Then
                         .Cells(i, 1).EntireRow.Insert
                      End If
                   Next i
                   tgtWB.SaveAs savePath & "\Split\" & srcCel.Value & " - " + Format(Now(), "mm.dd.yyyy") & ".xlsx", fileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                   tgtWB.Close True
                End With
                Call Mail_Book
             Else
             End If
             Application.CutCopyMode = False
             On Error Resume Next
             .ShowAllData
             On Error GoTo 0
          Next srcCel
          Application.DisplayAlerts = False
          Sheets("Lists").Delete
          Application.DisplayAlerts = True
       End With
    End Sub
    
    
    
    Code:
    Sub Mail_Book()
       'Set a reference to Outlook Object Library
       Dim c            As Range
       Dim strTo        As String
       Dim strCC        As String
       Dim strBody      As String
       Dim strSubject   As String
       Dim Attach       As String
       Dim outApp       As Outlook.Application
       Dim outMail      As Outlook.MailItem
       With srcWB.Sheets("Main")
          Set c = .Columns(1).Find(srcCel.Value, , xlValues, xlWhole, xlByRows, xlNext, False)
          strTo = c.Offset(0, 1).Value
          strCC = c.Offset(0, 2).Value
          strSubject = "Make this what you want"
          If Not IsEmpty(c.Offset(0, 3)) Then
             strBody = c.Offset(0, 3).Value
          Else: strBody = "Make this what you want"
          End If
          Attach = savePath & "\Split\" & srcCel.Value & " - " + Format(Now(), "mm.dd.yyyy") & ".xlsx"
          Set outApp = CreateObject("Outlook.Application")
          Set outMail = outApp.CreateItem(0)
          On Error Resume Next
          With outMail
             .To = strTo
             .CC = strCC
             .BCC = ""
             .Subject = strSubject
             .Body = strBody
             .Attachments.Add Attach
             .Display
             '        .Send   'or use .Display
          End With
          On Error GoTo 0
          Set outApp = Nothing
          Set outMail = Nothing
       End With
    End Sub
    Attached Files Attached Files
    John

  4. #4
    Hi jaslake,


    Thank you for looking into my file and have it worked on. i really appreciate it.


    I tested the macro and seems working fine. you are awesome!!

    Please see below answer to your questions.

    The Code can do this or would you prefer to do it manually?


    i insert the Vendor Name(column N) where you put the same vendor name even if different vendor code so that it can combine all its data in one file only


    - Yes please have it manually input so that it can combine all the data of the vendor, i have edited the rawdata VendNumName to have some same products.

    What would this be?

    the default message embedded in the code


    - It's something like the below code, the person name should be coming from Main tab, maybe we can insert a column next to Vendor name labeled "Name of contact".

    strbody = "<span style='font-family:Candara;font-size:14'>"
    strbody = strbody & "Hi " & cell.Offset(0, -1).Value & ",<br><br>"
    strbody = strbody & "Good Day!" & "<br>"
    strbody = strbody & "I am contacting you to request an RMA approval for defective products." & "<br>"
    strbody = strbody & "Please refer the attached file for the list." & "<br><br>"
    strbody = strbody & "If you have any questions, please feel free to contact me." & "<br><br>"
    strbody = strbody & "Thank you,"


    Also i have additional to include on the code.

    - Can we insert another column after customized message and labeled it as "STATUS" and have macro to put word "done email" or if a file you were sending was sent already or file already exist on the path, macro will put "already sent" something like this.

    -How can i show my signature?

    -can we group all the same "BR" per vendor name? please see example on the attached file process TAB,

    Thank you,

    Jonathan
    Attached Files Attached Files

  5. #5
    Acolyte jaslake's Avatar
    Join Date
    Aug 2011
    Location
    mineral city oh usa
    Posts
    81
    Articles
    0
    Excel Version
    2007;2010;MAc2011
    Hi Jonathan

    The Code in the attached appears to address these issues:

    REMEMBER:
    Set a reference to Outlook Object Library

    insert the Vendor Name(column N) where you put the same vendor name even if different vendor code so that it can combine all its data in one file only

    the default message embedded in the code

    Can we insert another column after customized message and labeled it as "STATUS" and have macro to put word "done email" or if a file you were sending was sent already or file already exist on the path, macro will put "already sent" something like this.
    How can i show my signature?
    can we group all the same "BR" per vendor name?
    A column has been added for Contact Name.
    Code:
    Option ExplicitDim srcWB           As Workbook
    Dim srcWS           As Worksheet
    Dim srcLR           As Long
    Dim srcLC           As Long
    Dim srcRng          As Range
    Dim srcCel          As Range
    Dim c               As Range
    Dim tgtWB           As Workbook
    Dim tgtLR           As Long
    Dim myPath          As String
    Dim savePath        As String
    'Dim DirFile         As String
    Dim i               As Long
    
    
    'Set a reference to Outlook Object Library
    
    
    Sub CreateVendorFiles()
       Set srcWB = ThisWorkbook   'Workbook running the Code
       Set srcWS = srcWB.Sheets("Rawdata")
       myPath = srcWB.Path & "\"
       savePath = Environ("USERPROFILE") & "\Desktop\Vendor Email"
       If Dir(savePath + "\Split\", vbDirectory) = "" Then
          MkDir savePath + "\Split\"
       End If
    
    
       With srcWS
          If Not .AutoFilterMode Then
             .Rows("9:9").AutoFilter
          End If
          srcLR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious).Row
          srcLC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                              SearchDirection:=xlPrevious).Column
          .Range("N9").Value = "Vendor Name"
          Set srcRng = .Range(.Cells(10, "C"), .Cells(srcLR, "C"))
          For Each srcCel In srcRng
             .Cells(srcCel.Row, "N").Value = Trim(Split(srcCel.Value, "-")(1))
          Next srcCel
    
    
          If Not Evaluate("ISREF(Lists!A1)") Then
             Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Lists"
          Else
             Sheets("Lists").Cells.Clear
          End If
    
    
          .Range(.Cells(9, "N"), .Cells(srcLR, "N")).AdvancedFilter Action:=xlFilterCopy, _
                                                                    CopyToRange:=Sheets("Lists").Range("A1"), Unique:=True
          ActiveWorkbook.Names.Add Name:="Vend_Name", RefersTo:= _
                                   "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
    
    
          For Each srcCel In Sheets("Lists").Range("Vend_Name")
    
    
             Set c = Sheets("Main").Columns(1).Find(srcCel.Value, , xlValues, xlWhole, xlByRows, xlNext, False)
             If Not c.Offset(0, 5).Value = "Already Sent" Then
                .Range("A9:N" & srcLR).AutoFilter Field:=14, Criteria1:=srcCel.Value
                Application.SheetsInNewWorkbook = 1
                Set tgtWB = Workbooks.Add
                With tgtWB.Sheets("Sheet1")
                   srcWS.Range("A9:N" & srcLR).SpecialCells(xlCellTypeVisible).Copy
                   .Range("A1").PasteSpecial Paste:=8
                   .Range("A1").PasteSpecial (xlPasteFormats)
                   .Range("A1").PasteSpecial (xlPasteValues)
                   tgtLR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                                       SearchDirection:=xlPrevious).Row
                   For i = .Range("B" & .Rows.Count).End(xlUp).Row To 3 Step -1
                      If Not .Cells(i, 2).Value = .Cells(i, 2).Offset(-1, 0).Value Then
                         .Cells(i, 1).EntireRow.Insert
                      End If
                   Next i
                   tgtWB.SaveAs savePath & "\Split\" & srcCel.Value & " - " + Format(Now(), "mm.dd.yyyy") & ".xlsx", fileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                   tgtWB.Close True
                End With
                Call Mail_Book
                c.Offset(0, 5).Value = "Already Sent"
                Application.CutCopyMode = False
                On Error Resume Next
                .ShowAllData
                On Error GoTo 0
             End If
          Next srcCel
          Application.DisplayAlerts = False
          Sheets("Lists").Delete
          Application.DisplayAlerts = True
       End With
    End Sub
    
    
    Sub Mail_Book()
       'Set a reference to Outlook Object Library
       Dim strTo        As String
       Dim strCC        As String
       Dim strBody      As String
       Dim strSubject   As String
       Dim strName      As String
       Dim Attach       As String
       Dim SigString    As String
       Dim Signature    As String
       Dim outApp       As Outlook.Application
       Dim outMail      As Outlook.MailItem
    
    
       With srcWB.Sheets("Main")
          strTo = c.Offset(0, 2).Value
          strCC = c.Offset(0, 3).Value
          strSubject = "Make this what you want"
          strName = c.Offset(0, 1).Value
          If Not IsEmpty(c.Offset(0, 4)) Then
             strBody = "<span style='font-family:Candara;font-size:14'>" & "Hi " & strName & "<br><br>" & c.Offset(0, 4).Value
          Else: strBody = "<span style='font-family:Candara;font-size:14'>"
             strBody = strBody & "Hi " & strName & ",<br><br>"
             strBody = strBody & "Good Day!" & "<br>"
             strBody = strBody & "I am contacting you to request an RMA approval for defective products." & "<br>"
             strBody = strBody & "Please refer the attached file for the list." & "<br><br>"
             strBody = strBody & "If you have any questions, please feel free to contact me." & "<br><br>"
             strBody = strBody & "Thank you,"
          End If
    
    
          'Change only JAS.htm to the name of your signature
          SigString = Environ("appdata") & _
                      "\Microsoft\Signatures\JAS.htm"
    
    
          If Dir(SigString) <> "" Then
             Signature = GetBoiler(SigString)
          Else
             Signature = ""
          End If
          Attach = savePath & "\Split\" & srcCel.Value & " - " + Format(Now(), "mm.dd.yyyy") & ".xlsx"
    
    
          Set outApp = CreateObject("Outlook.Application")
          Set outMail = outApp.CreateItem(0)
    
    
          On Error Resume Next
          With outMail
             .To = strTo
             .CC = strCC
             .BCC = ""
             .Subject = strSubject
             .HTMLBody = strBody & "<br><br>" & Signature
             .Attachments.Add Attach
             .Display
             '        .Send   'or use .Display
          End With
    
    
          On Error GoTo 0
          Set outApp = Nothing
          Set outMail = Nothing
       End With
    End Sub
    
    
    Function GetBoiler(ByVal sFile As String) As String
       'Dick Kusleika
       Dim fso          As Object
       Dim ts           As Object
       Set fso = CreateObject("Scripting.FileSystemObject")
       Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
       GetBoiler = ts.readall
       ts.Close
    End Function

    Attached Files Attached Files
    John

  6. #6
    Hi jayslake,

    You did excellent on the modification, this is somewhat i have in mind of what macro will do to the rawdata, however i changed some of the codes so it will get the data i wanted

    I hope you don't mind if i changed some as i understand how the code works, please see below

    please let me know this can affect some code, but when i test it work great!.

    If Not .AutoFilterMode Then
    .Rows("9:9").AutoFilter
    - changed to .Rows("14:14").AutoFilter - i want the macro get the filtered list on this column only and not coming from column C (vendnumname) then copy it the vendor name

    Set srcRng = .Range(.Cells(10, "C"), .Cells(srcLR, "C"))
    - changed to
    Set srcRng = .Range(.Cells(10, "N"), .Cells(srcLR, "N")) - just like above these is where i want the list of vendor name

    i also put apostrophy on below code to stop functioning since this is not required

    'For Each srcCel In srcRng
    '.Cells(srcCel.Row, "N").Value = Trim(Split(srcCel.Value, "-")(1))
    'Next srcCel

    and also can please have the below to be modified?

    first if there's already a file in the directory path where the excel was saved the macro will show file name exist want to replace?

    then if you choose "Yes" the macro will continue but if "No" the macro will debug and will flagged "run time error 1004 method SaveAs of object workbook failed"

    can you make a notification stating that the file has been sent even if the status in the main tab has "already sent". or anything that will prevent macro to sent the file again.

    second is the image on my signature is not showing is there a way to show this? please see attached file " Signature image.jpeg"

    Thank you,
    Jonathan
    Attached Thumbnails Attached Thumbnails Click image for larger version. 

Name:	Signature image.JPG 
Views:	1 
Size:	11.7 KB 
ID:	3767  

  7. #7
    Acolyte jaslake's Avatar
    Join Date
    Aug 2011
    Location
    mineral city oh usa
    Posts
    81
    Articles
    0
    Excel Version
    2007;2010;MAc2011
    Hi Jonathan

    If you've revised the Code please post a Workbook with the revised Code.

    What's the Name of your Signature File?
    John

  8. #8
    Hi Jaslake,

    Sorry i for not attaching the revised workbook, please see attached.

    the name of my signature file is ASUS.htm which i also include as attachment

    additional modification on below code

    srcWS.Range("A9:N" & srcLR).SpecialCells(xlCellTypeVisible).Copy

    -changed to srcWS.Range("A9:N" & srcLR).SpecialCells(xlCellTypeVisible).Copy
    - the required file to be copied is from column A to L only.

    Thank you,
    Attached Files Attached Files

  9. #9
    Acolyte jaslake's Avatar
    Join Date
    Aug 2011
    Location
    mineral city oh usa
    Posts
    81
    Articles
    0
    Excel Version
    2007;2010;MAc2011
    Hi Jonathan

    This should not be happening unless you intentionally cleared "Already Sent" from Column F without deleting the File. However, I've added the Code back in to check for the File existence. If the File exists the User will get a message that an Email was already sent. You can comment out the Message if you wish.
    if there's already a file in the directory path where the excel was saved the macro will show file name exist want to replace
    If it works for you it works for me
    hope you don't mind if i changed some as i understand how the code works, please see below
    please let me know this can affect some code, but when i test it work great!.
    Regarding this, if your Signature is not being placed in the Email, you'll need to find the Path to your Signature File.
    my signature is not showing
    This line of Code should find the Signature File
    Code:
    SigString = Environ("appdata") & _
                      "\Microsoft\Signatures\ASUS.htm"
    Place a break point at this line of Code then step though the line (F8). Place the cursor over SigString and see what it evaluates to. My Path evaluates to "C:\Users\John\AppData\Roaming\Microsoft\Signatures"

    If yours evaluates to "" then do a search for ASUS.htm...see what the Path is. Let me know.

    Here's the revised Code.
    Code:
    Option Explicit
    Dim srcWB           As Workbook
    Dim srcWS           As Worksheet
    Dim srcLR           As Long
    Dim srcLC           As Long
    Dim srcRng          As Range
    Dim srcCel          As Range
    Dim c               As Range
    Dim tgtWB           As Workbook
    Dim tgtLR           As Long
    Dim myPath          As String
    Dim savePath        As String
    Dim DirFile         As String
    Dim i               As Long
    'Set a reference to Outlook Object Library
    Sub CreateVendorFiles()
       Set srcWB = ThisWorkbook   'Workbook running the Code
       Set srcWS = srcWB.Sheets("Rawdata")
       myPath = srcWB.Path & "\"
       savePath = Environ("USERPROFILE") & "\Desktop\Vendor Email"
       If Dir(savePath + "\Split\", vbDirectory) = "" Then
          MkDir savePath + "\Split\"
       End If
       With srcWS
          If Not .AutoFilterMode Then
             .Rows("14:14").AutoFilter
             '.Rows("9:9").AutoFilter
          End If
          srcLR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious).Row
          srcLC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                              SearchDirection:=xlPrevious).Column
          .Range("N9").Value = "Vendor Name"
          'Set srcRng = .Range(.Cells(10, "C"), .Cells(srcLR, "C"))
          Set srcRng = .Range(.Cells(10, "N"), .Cells(srcLR, "N"))
          'For Each srcCel In srcRng
          '   .Cells(srcCel.Row, "N").Value = Trim(Split(srcCel.Value, "-")(1))
          'Next srcCel
          If Not Evaluate("ISREF(Lists!A1)") Then
             Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Lists"
          Else
             Sheets("Lists").Cells.Clear
          End If
          .Range(.Cells(9, "N"), .Cells(srcLR, "N")).AdvancedFilter Action:=xlFilterCopy, _
                                                                    CopyToRange:=Sheets("Lists").Range("A1"), Unique:=True
          ActiveWorkbook.Names.Add Name:="Vend_Name", RefersTo:= _
                                   "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
          For Each srcCel In Sheets("Lists").Range("Vend_Name")
             DirFile = savePath & "\Split\" & srcCel.Value & " - " + Format(Now(), "mm.dd.yyyy") & ".xlsx"
             If Len(Dir(DirFile)) = 0 Then   'File does not exist
                Set c = Sheets("Main").Columns(1).Find(srcCel.Value, , xlValues, xlWhole, xlByRows, xlNext, False)
                If Not c.Offset(0, 5).Value = "Already Sent" Then
                   .Range("A9:N" & srcLR).AutoFilter Field:=14, Criteria1:=srcCel.Value
                   Application.SheetsInNewWorkbook = 1
                   Set tgtWB = Workbooks.Add
                   With tgtWB.Sheets("Sheet1")
                      'srcWS.Range("A9:N" & srcLR).SpecialCells(xlCellTypeVisible).Copy
                      srcWS.Range("A9:L" & srcLR).SpecialCells(xlCellTypeVisible).Copy
                      .Range("A1").PasteSpecial Paste:=8
                      .Range("A1").PasteSpecial (xlPasteFormats)
                      .Range("A1").PasteSpecial (xlPasteValues)
                      tgtLR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                                          SearchDirection:=xlPrevious).Row
                      For i = .Range("B" & .Rows.Count).End(xlUp).Row To 3 Step -1
                         If Not .Cells(i, 2).Value = .Cells(i, 2).Offset(-1, 0).Value Then
                            .Cells(i, 1).EntireRow.Insert
                         End If
                      Next i
                      tgtWB.SaveAs savePath & "\Split\" & srcCel.Value & " - " + Format(Now(), "mm.dd.yyyy") & ".xlsx", fileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                      tgtWB.Close True
                   End With
                   Call Mail_Book
                   c.Offset(0, 5).Value = "Already Sent"
                End If
                Application.CutCopyMode = False
                On Error Resume Next
                .ShowAllData
                On Error GoTo 0
             Else
                Set c = Sheets("Main").Columns(1).Find(srcCel.Value, , xlValues, xlWhole, xlByRows, xlNext, False)
                c.Offset(0, 5).Value = "Already Sent"
                Set c = Nothing
                MsgBox "Mail was already sent to " & srcCel
             End If
          Next srcCel
          Application.DisplayAlerts = False
          Sheets("Lists").Delete
          Application.DisplayAlerts = True
       End With
    End Sub
    Sub Mail_Book()
       'Set a reference to Outlook Object Library
       Dim strTo        As String
       Dim strCC        As String
       Dim strBody      As String
       Dim strSubject   As String
       Dim strName      As String
       Dim Attach       As String
       Dim SigString    As String
       Dim Signature    As String
       Dim outApp       As Outlook.Application
       Dim outMail      As Outlook.MailItem
       With srcWB.Sheets("Main")
          strTo = c.Offset(0, 2).Value
          strCC = c.Offset(0, 3).Value
          strSubject = "Make this what you want"
          strName = c.Offset(0, 1).Value
          If Not IsEmpty(c.Offset(0, 4)) Then
             strBody = "<span style='font-family:Candara;font-size:14'>" & "Hi " & strName & "<br><br>" & c.Offset(0, 4).Value
          Else: strBody = "<span style='font-family:Candara;font-size:14'>"
             strBody = strBody & "Hi " & strName & ",<br><br>"
             strBody = strBody & "Good Day!" & "<br>"
             strBody = strBody & "I am contacting you to request an RMA approval for defective products." & "<br>"
             strBody = strBody & "Please refer the attached file for the list." & "<br><br>"
             strBody = strBody & "If you have any questions, please feel free to contact me." & "<br><br>"
             strBody = strBody & "Thank you,"
          End If
          '      Change only JAS.htm to the name of your signature
          '            SigString = Environ("appdata") & _
                       '                               "\Microsoft\Signatures\JAS.htm"
          SigString = Environ("appdata") & _
                      "\Microsoft\Signatures\ASUS.htm"
          If Dir(SigString) <> "" Then
             Signature = GetBoiler(SigString)
          Else
             Signature = ""
          End If
          Attach = savePath & "\Split\" & srcCel.Value & " - " + Format(Now(), "mm.dd.yyyy") & ".xlsx"
          Set outApp = CreateObject("Outlook.Application")
          Set outMail = outApp.CreateItem(0)
          On Error Resume Next
          With outMail
             .To = strTo
             .CC = strCC
             .BCC = ""
             .Subject = strSubject
             .HTMLBody = strBody & "<br><br>" & Signature
             .Attachments.Add Attach
             .Display
             '        .Send   'or use .Display
          End With
          On Error GoTo 0
          Set outApp = Nothing
          Set outMail = Nothing
       End With
    End Sub
    
    Function GetBoiler(ByVal sFile As String) As String
       'Dick Kusleika
       Dim fso          As Object
       Dim ts           As Object
       Set fso = CreateObject("Scripting.FileSystemObject")
       Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
       GetBoiler = ts.readall
       ts.Close
    End Function
    Attached Files Attached Files
    John

  10. #10
    Hi Jaslake,


    Thank you for the Revision!,
    Yes if for some reason that the "Already Sent" from Column F was deleted there should be file check on the path, the message is fine with me..

    The signature is being place on the Email, only the company logo in not displayed is there a way to display the logo? please see attached.

    my path to my signature file is like yours
    "C:\Users\Jonathan\AppData\Roaming\Microsoft\Signatures"


    Thanks,
    Jonathan
    Attached Thumbnails Attached Thumbnails Click image for larger version. 

Name:	Email.JPG 
Views:	4 
Size:	71.2 KB 
ID:	3772  

Page 1 of 3 1 2 3 LastLast

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •