Split to files then to Outlook Macro

Jferrer · Jul 21, 2015

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

JonathanView attachment SplitFiles then e-mail.xlsm

jaslake · Jul 23, 2015

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

jaslake · Jul 24, 2015

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

[/CODE]

Jferrer · Jul 27, 2015

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 = ""
strbody = strbody & "Hi " & cell.Offset(0, -1).Value & ", "
strbody = strbody & "Good Day!" & " "
strbody = strbody & "I am contacting you to request an RMA approval for defective products." & " "
strbody = strbody & "Please refer the attached file for the list." & " "
strbody = strbody & "If you have any questions, please feel free to contact me." & " "
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

jaslake · Jul 28, 2015

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

Jferrer · Jul 29, 2015

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

jaslake · Jul 29, 2015

Hi Jonathan

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

What's the Name of your Signature File?

Jferrer · Jul 29, 2015

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,

jaslake · Jul 29, 2015

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

Jferrer · Jul 29, 2015

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

jaslake · Jul 29, 2015

Hi Jonathon

My 74 year old eyes cannot read the Thumbnail...sorry.

Kenneth Hobson · Jul 29, 2015

Maybe this below will help. It is mostly what Ron DeBruin posted but with my tweaks.

Code:

' http://www.rondebruin.nl/win/s1/outlook/signature.htm



 Sub Mail_Outlook_With_Signature_Html_3()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2013
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim SigString As String
    Dim Signature As String
    Dim img As String, s() As String, i As Long


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


    strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
              "Please visit this website to download the new version.<br>" & _
              "Let me know if you have problems.<br>" & _
              "<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
              "<br><br><B>Thank you</B>"


    'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\bcard.htm"


    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
        img = Environ("appdata") & "\Microsoft\Signatures\BCard_files\image001.jpg"
        s() = Split(Signature, vbCrLf)
        MsgBox UBound(s)
        i = IndexInArray("<v:imagedata src=", s())  '-1 = not found. 3rd Parameter is False by default.
        'i = IndexInArray("src=", s(), True) '-1 = not found. True means matched to left side of string.
        If i <> -1 Then
          'Show full array element value in Immediate Window
            'for a found string in the first element matched.
          'Debug.Print s(i)
          'Replace the frist quoted string in the array element.
          
        End If
        Exit Sub
    Else
        Signature = ""
    End If


    On Error Resume Next


    With OutMail
        .to = "ken@gmail.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = strbody & "<br>" & Signature
        .Send    'or use .Display
    End With


    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


'If not found, result is -1. Set cm=vbBinaryCompare for exact string comparison.
Function IndexInArray(aValue As String, anArray() As String, _
  Optional tfMatchLeft As Boolean = False, Optional cm As Integer = vbTextCompare) As Long
  Dim pos As Long, i As Long, ii As Integer
  pos = -1
  For i = LBound(anArray) To UBound(anArray)
    ii = InStr(1, anArray(i), aValue, cm)
    If ii <> 0 Then
      If tfMatchLeft = True Then
         If ii = 1 Then pos = i
         Exit For
        Else
          pos = i
          Exit For
      End If
    End If
  Next i
  IndexInArray = pos
End Function

Kenneth Hobson · Jul 29, 2015

Click the thumbnail image file to open it. In it or most any Window, hold the control key down and zoom to size using your mouses wheel.

Jferrer · Jul 29, 2015

Hi Jaslake,

You can click the image for larger version..

Hi Kenneth,

Thank for the sharing the code i'll try to understand how it works.

Thank you,
Jonathan

jaslake · Jul 29, 2015

Hi Jonathan

This revision is also from Mr. DeBruin's Website. It seems to work...try it...let me know.
http://www.rondebruin.nl/win/s1/outlook/signature.htm

Replace the Mail Book Code with this...

Code:

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
         .Display
         .To = strTo
         .CC = strCC
         .BCC = ""
         .Subject = strSubject
         .HTMLBody = strBody & "<br>" & .HTMLBody
         '         .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

Jferrer · Jul 29, 2015

Hi Jaslake,

Yehey!! that should do the trick, the image is now displayed in my signature.

Thanks so much Sir! you're a big help and thank you for you time and effort i really appreciate it.

If there are new ideas or suggestions to this file i'll just reply to this thread again, and hopefully you can help me out again.

i'll let you know.

thanks you so much,
Jonathan

jaslake · Jul 29, 2015

Hi Jonathan

You're welcome...glad I could help.

I'll look at Mr Hobson's Code...see if I can understand it...adapt it. Thanks Kenneth.

Edit:
This works in a fashion...

Click the thumbnail image file to open it. In it or most any Window, hold the control key down and zoom to size using your mouses wheel

Get dark background...black text...can't read a thing.

Jferrer · Jul 31, 2015

Hi jaslake,

I have a situation, i need to have column H and Column J to be totalled and have macro to autosum these columns.

is this possible?

i have attached the revised file and added a tab (Sample SUM) for the sample output of the macro.

also tried to insert a code for the autosum but i got an error and when debug it stops to
"strTo = c.Offset(0, 2).Value"

below is the code I inserted.

Set Rng = Range("H2:H" & Range("H2").End(xlDown).Row)
Set c = Range("H2").End(xlDown).Offset(1, 0)
c.Formula = "=SUM(" & Rng.Address(False, False) & ")"

Thank you,
Jonathan

jaslake · Jul 31, 2015

Hi Jonathon

You can't use c

Code:

Set c = Range("H2").End(xlDown).Offset(1, 0)

...it's being used elsewhere in the Code. Dim another variable as Range and use it. I've not played with it as yet...try what I suggest...see where you land.

jaslake · Aug 1, 2015

Hi Jonathan

I have a solution for this...will post later today...gotta mow.

Split to files then to Outlook Macro

New member

New member

New member

Attachments

New member

Attachments

New member

Attachments

New member

Attachments

New member

New member

Attachments

New member

Attachments

New member

Attachments

New member

New member

New member

New member

New member

New member

New member

New member

Attachments

New member

New member