Solved

Send email based on values in certain cells - Applicant Status Euro MC Order

Posted on 2013-11-18
22
275 Views
Last Modified: 2013-11-21
This one is very similar to what was done with a previous solution:
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28156647.html

This funciton is for the Applicant Status spreadsheet:

When there is a value Col J and AND a value in Col N:

Create new email addressed to: david@offshorelawcenter.com

Subject: New Euro MC Order for {value in Col C and Col B}

Body:

David,

"Attached are files for new Euro Mastercard order for {value in Col C and Col B}.

Please send card to the following address:
{the value in Col O}"

(If there is no value Col O then:)

"Please send card to the address indicated in the
attached files."

Thank you.

Michael
------------------------
Then attach to the email the documents saved to the hard drive
that are in Cols E, F, G, H

When the email has been sent then put today's date in Col P
0
Comment
Question by:JaseSt
22 Comments
 
LVL 6

Expert Comment

by:Michael
Comment Utility
Hi there,

just a tip: you might want to replace your e-mail address with a dummy one to avoid it being picked up by webcrawlers, which use it for spam.

Joop
0
 
LVL 26

Expert Comment

by:MacroShadow
Comment Utility
Option Explicit

Sub SendEmail(Rng As Range)
    Dim wb As Workbook
    Dim WS As Worksheet


    Dim SendTo As String
    Dim Blindcc As String
    Dim OutlookApp As Object
    Dim MItem As Object
    Dim subject_ As String
    Dim attach_ As String
    Dim fFile
    Dim omail As Outlook.MailItem

    Application.DisplayAlerts = False

    'Create Outlook
    Set OutlookApp = CreateObject("Outlook.Application")

    'Fill in Subject Details'
    subject_ = "New Euro MC Order for (" & Rng.Cells(1, "B") & " " & Rng.Cells(1, "C") & ")"
    SendTo = "david@offshorelawcenter.com"
    Blindcc = "david@offshorelawcenter.com"

    'Create the Email
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
        .To = SendTo
        .BCC = Blindcc
        .Subject = subject_

        '---> Attach files
        For Each fFile In Rng.SpecialCells(xlCellTypeFormulas)
            If InStr(1, fFile.Formula, "HYPERLINK") <> 0 Then
                fpos = InStr(1, fFile.Formula, "HYPERLINK") + 11
                attach_ = Mid(fFile.Formula, fpos, InStr(fpos, fFile.Formula, Chr(34)) - fpos)
                .Attachments.Add (attach_)
            End If
        Next fFile

        .Body = "Hi David," & Chr(10) & Chr(10) _
                & "Attached are files for new Euro Mastercard order for (" & Rng.Cells(1, "B") & " " & Rng.Cells(1, "C") & ")" & Chr(10) _
                & "Please send card to the following address:" & Chr(10) _
                & IIf(Not isnothing(Rng.Cells(1, "O")), Rng.Cells(1, "O"), "Please send card to the address indicated in the attached files.") _
                & Chr(10) & Chr(10) _
                & "Thank you." & Chr(10) & Chr(10) _
                & "Michael"

        'Send the Email
        .Display
    End With

    'Clear Resources
    Set MItem = Nothing
    Set OutlookApp = Nothing
    
    ' Add date to spreadsheet
    Rng.Cells(1, "P").Value = Date

    Application.DisplayAlerts = True
End Sub

Open in new window

0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
JaseSt,
Didn't we had a macro that send email if value is in Col N and Col O ??? or it was an attempt that never saw the light ??? pls refresh my memory as I have couple of code that intercept N and O but fail to see if this saw the light.

Just saw that when value in N and O then
1) Create NewCardLoad file
2) Send Email attaching this new card load file to Nalelli

How does your request here is different from this one ??

gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
Yes, we do so it seems - not sure how we got that - but this function is incorrect in how it operates.

What needs changing in how it currently operates is this:

IF there is a value in Col J AND Col N then send the attachments (as it currently does and is requested above) but do NOT create a New Card load sheet and send it to the email address indicated above (avid@offshorelawcenter.com) with the subject and body as requested above as well.
0
 
LVL 29

Accepted Solution

by:
gowflow earned 500 total points
Comment Utility
here it is

1) Make a copy of your latest file and give it a new name
2) goto VBA and doubleclick on Module1 and after any End sub insert the below code

Sub SendEmailEURO(Rng As Range, sAddress As String, Optional fName As String)
Dim WB As Workbook
Dim WS As Worksheet


Dim SendTo As String
Dim Blindcc As String
Dim OutlookApp As Object
Dim MItem As Object
Dim subject_ As String
Dim attach_ As String
Dim fFile
Dim omail As Outlook.MailItem
Dim sShipto As String

Application.DisplayAlerts = False

'Create Outlook
Set OutlookApp = CreateObject("Outlook.Application")

'Fill in Subject Details'
subject_ = "New Euro MC Order for (" & Rng.Cells(1, "C") & " " & Rng.Cells(1, "B") & ")"
SendTo = "david@offshorelawcenter.com"
'Blindcc = "david@offshorelawcenter.com"

'Create the Email
Set MItem = OutlookApp.CreateItem(0)
With MItem
  .To = SendTo
  '.BCC = Blindcc
  .Subject = subject_
  
  '---> Attach files
  For Each fFile In Rng.SpecialCells(xlCellTypeFormulas)
        If InStr(1, fFile.Formula, "HYPERLINK") <> 0 Then
            fpos = InStr(1, fFile.Formula, "HYPERLINK") + 11
            attach_ = Mid(fFile.Formula, fpos, InStr(fpos, fFile.Formula, Chr(34)) - fpos)
            .Attachments.Add (attach_)
        End If
  Next fFile
  
  '---> Only Attach file when fName is linked ie Col K
  If fName <> "" Then
    .Attachments.Add (fName)
  End If
  
  '---> Determin shipto
  Select Case UCase(sAddress)
    Case "" 'sAddress empty then do as before
        sShipto = "Please send card to the address indicated in the attached files."
    
    Case Else
        sShipto = "Please send card to the following address:" & Chr(10) & sAddress
        
  End Select
  
  .Body = "David," & Chr(10) & Chr(10) _
    & "Attached are files for new Euro Mastercard order for (" & Rng.Cells(1, "C") & " " & Rng.Cells(1, "B") & ")" & Chr(10) & Chr(10) _
    & sShipto & Chr(10) & Chr(10) _
    & "Thank you." & Chr(10) & Chr(10) _
    & "Michael." & Chr(10) _


  'Send the Email
  .Display
End With

'---> Put Today's date in Col P
Rng.Cells(1, "P") = DateValue(Now)

'Clear Resources
Set MItem = Nothing
Set OutlookApp = Nothing

Application.DisplayAlerts = True
End Sub

Open in new window



3) SAVE the workbook
4) doubleclick on Sheet1 in the left pane and choose to view 1 sub at a time by clicking on the bottom left icon
5) Select Worksheet change event and delete the code that is between Private Sub and End Sub
Private Sub Worksheet_Change(ByVal Target As Range)

< delete all the code that is between these 2 lines >

End Sub

6) Insert the below code after
Private Sub Worksheet_Change(ByVal Target As Range)

Dim cCell As Range
Dim fName As String

'---> disable all events while in this procedure to prevent from looping
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False

'---> Update Date in Col O,P,Q,R,S when x is inputed.
For Each cCell In Target
    If (Not Intersect(cCell, Columns("O")) Is Nothing Or _
        Not Intersect(cCell, Columns("P")) Is Nothing Or _
        Not Intersect(cCell, Columns("Q")) Is Nothing Or _
        Not Intersect(cCell, Columns("R")) Is Nothing Or _
        Not Intersect(cCell, Columns("S")) Is Nothing) _
        And LCase(cCell.Value) = "x" Then
        cCell = Format(Now, "mm/dd/yyyy")
    End If
Next cCell


'---> Send Email if Cell in Col N has a value and Cell in Col K or Col J has value
If Not Intersect(Target, Columns("N")) Is Nothing Or Not Intersect(Target, Columns("K")) Is Nothing Or Not Intersect(Target, Columns("J")) Is Nothing Then
    
    '---> USD Subfolder - Col K
    If Range("N" & Target.Row) <> "" And _
        Range("K" & Target.Row) <> "" Then
        If MsgBox("Reply Mail for " & Cells(Target.Row, "C") & ", " & Cells(Target.Row, "B") & " as USD amount entered ?", vbQuestion + vbYesNo, "Send Email") = vbYes Then
            fName = CreateNewCardLoad(Range(Cells(Target.Row, "A"), Cells(Target.Row, "T")))
            SendEmail Range(Cells(Target.Row, "A"), Cells(Target.Row, "T")), Cells(Target.Row, "O"), fName
            Exit Sub
        End If
    End If
    
    '---> EUR Subfolder - Col J
    If Range("N" & Target.Row) <> "" And _
        Range("J" & Target.Row) <> "" Then
        If MsgBox("Reply Mail sending Card Load for " & Cells(Target.Row, "C") & ", " & Cells(Target.Row, "B") & " as EURO amount entered ?", vbQuestion + vbYesNo, "Send Email") = vbYes Then
            fName = CreateNewCardLoad(Range(Cells(Target.Row, "A"), Cells(Target.Row, "T")))
            SendEmail Range(Cells(Target.Row, "A"), Cells(Target.Row, "T")), Cells(Target.Row, "O"), fName
            Exit Sub
        Else
            If MsgBox("Send Mail withought Card Load for " & Cells(Target.Row, "C") & ", " & Cells(Target.Row, "B") & " as EURO amount entered ?", vbQuestion + vbYesNo, "Send Email") = vbYes Then
                SendEmailEURO Range(Cells(Target.Row, "A"), Cells(Target.Row, "T")), Cells(Target.Row, "O")
                Exit Sub
            End If
        End If
    End If


Else
    
    If Not Intersect(Target, Columns("Q")) Is Nothing And InStr(1, Cells(Target.Row, "T"), "5116") <> 0 And Range("Q" & Target.Row) <> "" Then
        Range("W" & Target.Row).NumberFormat = "@"
        Cells(Target.Row, "W") = GetProxy(Cells(Target.Row, "T"))
        If Cells(Target.Row, "W") <> "" Then
            SendActivationEmail Range(Cells(Target.Row, "A"), Cells(Target.Row, "T"))
        End If
    Else
        If Not Intersect(Target, Columns("Q")) Is Nothing And InStr(1, Cells(Target.Row, "T"), "5116") = 0 And Cells(Target.Row, "T") <> "Not Yet Assigned" And Range("Q" & Target.Row) <> "" Then
            MsgBox ("It seems that the credit card number entered " & Cells(Target.Row, "T") & " does not start with '5116' ")
        End If
    End If
    
End If

'---> Re-activate all events prior exit
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Open in new window



7) SAVE and Exit the workbook
8) Open it and take any row and add value in Col K then add value in Col N and see the results.


NOTE: You will be asked the first question if you want to reply and send the Card Load file here you should answer NO and then it will ask an other question if you want to send the mail without card load here you answer yes. Until we see what you want to do with CardLoad I kept that part active.


gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
This worked great, gowflow!

However, not sure if it is related or not, but I'm now getting an error when I click the Save Links button of Applicant Status spreadsheet under the  Public Sub SaveAttachments() function with this highlighted in yellow:

sOrder = Mid(objMsg.Subject, lOrder, InStr(lOrder, LCase(objMsg.Subject), " ") - lOrder)

Below is all the code for this page if it helps. The email had eight attachments so I don't know if that was the issue or not.

Option Explicit
Private Const MAX_PATH = 255

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long




Public Function GetTempDir() As String
    Dim sRet As String, lngLen As Long
    'create buffer
    sRet = String(MAX_PATH, 0)
    lngLen = GetTempPath(MAX_PATH, sRet)
    If lngLen = 0 Then Err.Raise Err.LastDllError
    GetTempDir = Left$(sRet, lngLen)
End Function


                                            


Private Sub CommandButton1_Click()
SaveAttachments
End Sub


       Public Sub SaveAttachments()
On Error GoTo ErrHandler

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim I As Long, J As Long, K As Long, L As Long, lTo As Long, KK As Long
Dim lngCount As Long
Dim LastRow As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim cCell As Range
Dim WS As Worksheet
Dim FileExt As String
Dim AttachRange As Range
Dim WB As Workbook
Dim WSAttach As Worksheet
Dim X, sFields, sLine
Dim ValidFile As Boolean
Dim sFile As String
Dim lOrder As Long
Dim sOrder As String

    Set WS = ActiveSheet
        
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    'On Error Resume Next
 
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
 
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    'Set objSelection = objOL.GetNamespace("MAPI").Folders("CM Template")
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
 
    ' Set the Attachment folder to be this specific path as per Jaset request on Apr 29, 2013
    strFolderpath = strFolderpath & "\OLAttachments"
    'strFolderpath = "C:\Users\Michael\Sovereign Archives"
    
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
 
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
         
        '---> Choose the color of the row
        Set cCell = ActiveCell
        LastRow = cCell.Row + 1
        Do
            '---> Locate the cell color of the last row above the current one
            LastRow = LastRow - 1
            LastRow = WS.Range("A" & LastRow).End(xlUp).Row
            
        Loop Until WS.Range("A" & LastRow).Interior.Color <> 16777215 Or LastRow = 1
        
        '---> Color the new row based on the results
        If WS.Range("A" & LastRow).Interior.Color = 14545386 Then
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 10147522
        Else
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 14545386
        End If
         
        If lngCount > 0 Then
            ' Use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            K = 0
            For I = lngCount To 1 Step -1
             
                ' Get the file name.
                strFile = objAttachments.Item(I).Filename
                 
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & "\" & strFile
                 
                ' Save the attachment as a file.
                Application.DisplayAlerts = False
                
                On Error Resume Next
                Do
                    objAttachments.Item(I).SaveAsFile strFile
                    
                    If Err <> 0 Then
                        MkDir (Left(strFile, InStrRev(strFile, "\")))
                    Else
                        On Error GoTo 0
                    End If
                Loop Until Err = 0
                
                        
                '---> Insert data in coresponding cells
                Do Until WS.Cells(cCell.Row, K + 5) = ""
                    If K + 6 = 9 Then
                        '---> Copy Insert the new row and contine in Cell E
                        WS.Cells(cCell.Row, K + 5).EntireRow.Copy
                        WS.Cells(cCell.Row, K + 5).EntireRow.Insert
                        WS.Range("E" & cCell.Row & ":H" & cCell.Row).ClearContents
                        K = -1
                    End If
                    K = K + 1
                Loop
                WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
                WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
                
                '---> Insert Order Number
                If InStr(1, LCase(objMsg.Subject), "order") <> 0 Then
                    lOrder = InStr(1, LCase(objMsg.Subject), "order") + 6
                    sOrder = Mid(objMsg.Subject, lOrder, InStr(lOrder, LCase(objMsg.Subject), " ") - lOrder)
                    WS.Range("I" & cCell.Row) = "WO " & sOrder
                Else
                    WS.Range("I" & cCell.Row) = objMsg.SenderEmailAddress
                End If
                
                '---> Insert Hyperlink
                WS.Range(WS.Cells(cCell.Row, K + 5), WS.Cells(cCell.Row, K + 5)).Formula = "=hyperlink(" & Chr(34) & strFile & Chr(34) & "," & Chr(34) & Right(strFile, Len(strFile) - InStrRev(strFile, "\")) & Chr(34) & ")"
                
                '---> Check to See if Valid Excel File
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                If InStr(1, LCase(FileExt), "xls") <> 0 Or InStr(1, LCase(FileExt), "xlsm") <> 0 Or InStr(1, LCase(FileExt), "xltx") <> 0 Or InStr(1, LCase(FileExt), "xlsx") <> 0 Then
                    '---> Open Workbook
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                    Set WB = Workbooks.Open(strFile)
                    Set WSAttach = WB.ActiveSheet
                                
                    '---> Test to see if Valid CC File
                    'If WSAttach.Range("P1") <> "" Then
                    If InStr(1, LCase(WSAttach.Range("A1")), "first name") <> 0 And InStr(1, LCase(WSAttach.Range("B1")), "last name") <> 0 And InStr(1, LCase(WSAttach.Range("O1")), "email address") <> 0 Then
                        '---> We are Dealing with Horizontal Spreadsheet
                        '     Assign Col A to Col C as First Name
                        '     Assign Col B to Col B as Last Name
                        WS.Range("C" & cCell.Row) = WSAttach.Range("A2")
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("O2") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("O2")
                        End If
                        
                        '---> Depending on Value of Col P affect Col T
                        If InStr(1, LCase(WSAttach.Range("P1")), "card number") <> 0 Then
                            WS.Range("T" & cCell.Row).NumberFormat = "@"
                            WS.Range("T" & cCell.Row) = ProcessCC(WSAttach.Range("P2"))
                        Else
                            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        End If
                    Else
                        '---> We are Dealing with Vertical Spreadsheet
                        '     Assign B1 to Col C as First Name
                        '     Assign B2 to Col B as Last Name
                        '     Col T = 'Not Yet Assigned'
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        WS.Range("C" & cCell.Row) = WSAttach.Range("B1")
                        WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("B15") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("B15")
                        End If
                        
                    End If
                
                    '---> Close Workbook
                    WB.Close savechanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
        
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                
                Else
                
                    '---> Check to see if Valid .csv file
                    If InStr(1, FileExt, "csv") <> 0 Then
                        '---> Open Workbook
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
            
                        Open strFile For Input As #1
                        KK = 99
                        
                        '---> Read the Header
                        Do While Not EOF(1)
                            Line Input #1, sFile
                            
                            '---> Split the File by Line
                            sLine = Split(sFile, Chr(10))
                                
                            If UBound(sLine) = 0 Then
                                lTo = 0
                            Else
                                lTo = 1
                            End If
                            
                            For L = 0 To UBound(sLine) - lTo
                                sFields = Split(sLine(L), ",")
                                
                                '---> Look for Email Address position
                                If L = 0 And KK = 99 Then
                                    For KK = 0 To UBound(sFields)
                                        If InStr(1, sFields(KK), "Email Address") <> 0 Then Exit For
                                    Next KK
                                Else
                                    If InStr(1, sFields(KK), "@") = 0 Then
                                        For KK = 0 To UBound(sFields)
                                            If InStr(1, sFields(KK), "@") <> 0 Then Exit For
                                        Next KK
                                    End If
                                End If
                                
                                '---> Test to see if Valid File
                                If L = 0 And InStr(1, sFields(0), "First Name") <> 0 And InStr(1, sFields(1), "Last Name") <> 0 And InStr(1, sFields(KK), "Email Address") <> 0 Then
                                    
                                Else
                                    'Line Input #1, sLine
                                    sFields = Split(sLine(L), ",")
                                    
                                    '---> Strip quotes prior affecting
                                    X = ""
                                    For J = 1 To Len(sFields(0))
                                        If Mid(sFields(0), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(0), J, 1)
                                        End If
                                    Next J
                                    sFields(0) = X
                                    
                                    X = ""
                                    For J = 1 To Len(sFields(1))
                                        If Mid(sFields(1), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(1), J, 1)
                                        End If
                                    Next J
                                    sFields(1) = X
                                    
                                    WS.Range("C" & cCell.Row) = sFields(0)
                                    WS.Range("B" & cCell.Row) = sFields(1)
                                    
                                    '---> Check if Same Email or Diffrent
                                    If WS.Range("D" & cCell.Row) <> sFields(KK) Then
                                        WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & sFields(KK)
                                    End If
                                End If
                                
                            Next L
                        Loop
                        
                        '---> Close the File
                        Close #1
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
                    End If
                    
                End If
                
                
            Next I
            
            '---> Check after all Attachements if Still Col T Empty
            '     then update with Not Yet Assigned.
            '     to ensure Col T always Updated with value
            If WS.Range("T" & cCell.Row) = "" Then
                WS.Range("T" & cCell.Row) = "Not Yet Assigned"
            End If
            
        Else
            '---> Update Email, Date, CC Even if no attachements
            WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
            WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
        End If
        
        '---> Move ActiveCell 1 row
        WS.Cells(cCell.Row + 1, 1).Select
        
    Next objMsg

Application.DisplayAlerts = True
Application.ScreenUpdating = True
DoEvents
MsgBox (lngCount & " Attachments were saved on C drive")


ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Exit Sub

ErrHandler:
X = MsgBox("This Routine will Exit due to following Error:" & Chr(10) & Chr(10) & Error(Err), vbCritical)
GoTo ExitSub


End Sub
                                                                                 
                                                                                       
Private Sub Worksheet_Change(ByVal Target As Range)

  Dim cCell As Range
Dim fName As String

'---> disable all events while in this procedure to prevent from looping
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False

'---> Update Date in Col O,P,Q,R,S when x is inputed.
For Each cCell In Target
    If (Not Intersect(cCell, Columns("O")) Is Nothing Or _
        Not Intersect(cCell, Columns("P")) Is Nothing Or _
        Not Intersect(cCell, Columns("Q")) Is Nothing Or _
        Not Intersect(cCell, Columns("R")) Is Nothing Or _
        Not Intersect(cCell, Columns("S")) Is Nothing) _
        And LCase(cCell.Value) = "x" Then
        cCell = Format(Now, "mm/dd/yyyy")
    End If
Next cCell


'---> Send Email if Cell in Col N has a value and Cell in Col K or Col J has value
If Not Intersect(Target, Columns("N")) Is Nothing Or Not Intersect(Target, Columns("K")) Is Nothing Or Not Intersect(Target, Columns("J")) Is Nothing Then
    
    '---> USD Subfolder - Col K
    If Range("N" & Target.Row) <> "" And _
        Range("K" & Target.Row) <> "" Then
        If MsgBox("Reply Mail for " & Cells(Target.Row, "C") & ", " & Cells(Target.Row, "B") & " as USD amount entered ?", vbQuestion + vbYesNo, "Send Email") = vbYes Then
            fName = CreateNewCardLoad(Range(Cells(Target.Row, "A"), Cells(Target.Row, "T")))
            SendEmail Range(Cells(Target.Row, "A"), Cells(Target.Row, "T")), Cells(Target.Row, "O"), fName
            Exit Sub
        End If
    End If
    
    '---> EUR Subfolder - Col J
    If Range("N" & Target.Row) <> "" And _
        Range("J" & Target.Row) <> "" Then
        If MsgBox("Reply Mail sending Card Load for " & Cells(Target.Row, "C") & ", " & Cells(Target.Row, "B") & " as EURO amount entered ?", vbQuestion + vbYesNo, "Send Email") = vbYes Then
            fName = CreateNewCardLoad(Range(Cells(Target.Row, "A"), Cells(Target.Row, "T")))
            SendEmail Range(Cells(Target.Row, "A"), Cells(Target.Row, "T")), Cells(Target.Row, "O"), fName
            Exit Sub
        Else
            If MsgBox("Send Mail withought Card Load for " & Cells(Target.Row, "C") & ", " & Cells(Target.Row, "B") & " as EURO amount entered ?", vbQuestion + vbYesNo, "Send Email") = vbYes Then
                SendEmailEURO Range(Cells(Target.Row, "A"), Cells(Target.Row, "T")), Cells(Target.Row, "O")
                Exit Sub
            End If
        End If
    End If


Else
    
    If Not Intersect(Target, Columns("Q")) Is Nothing And InStr(1, Cells(Target.Row, "T"), "5116") <> 0 And Range("Q" & Target.Row) <> "" Then
        Range("W" & Target.Row).NumberFormat = "@"
        Cells(Target.Row, "W") = GetProxy(Cells(Target.Row, "T"))
        If Cells(Target.Row, "W") <> "" Then
            SendActivationEmail Range(Cells(Target.Row, "A"), Cells(Target.Row, "T"))
        End If
    Else
        If Not Intersect(Target, Columns("Q")) Is Nothing And InStr(1, Cells(Target.Row, "T"), "5116") = 0 And Cells(Target.Row, "T") <> "Not Yet Assigned" And Range("Q" & Target.Row) <> "" Then
            MsgBox ("It seems that the credit card number entered " & Cells(Target.Row, "T") & " does not start with '5116' ")
        End If
    End If
    
End If

'---> Re-activate all events prior exit
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
                                                                                      
                                            
  End Sub

Private Sub Worksheet_Deactivate()

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

Open in new window

0
 

Author Comment

by:JaseSt
Comment Utility
And this is the all the code under Module 1 of Applicant Status:

Sub SendActivationEmail(Rng As Range)
Dim SendTo As String
Dim sTo
Dim OutlookApp As Object
Dim MItem As Object
Dim subject_ As String
Dim attach_ As String
Dim omail As Outlook.MailItem


'---> Create Outlook
Set OutlookApp = CreateObject("Outlook.Application")

'---> Fill in Subject Details'
subject_ = "Proxy Number for Sovereign USD Mastercard" ' (" & Rng.Cells(1, "B") & " " & Rng.Cells(1, "C") & ")"

'---> Fill in email addresses
sTo = Split(Rng.Cells(1, "D"), "/")

For I = 0 To UBound(sTo)
    If SendTo <> "" Then SendTo = SendTo & "; "
    SendTo = SendTo & LTrim(RTrim(sTo(I)))
Next I


'---> Create the Email
Set MItem = OutlookApp.CreateItem(0)
With MItem
  .To = SendTo
  .Subject = subject_
  
  .Body = "Dear " & Rng.Cells(1, "B") & Chr(10) & Chr(10) _
    & "Your card must be activated first before you can access your online account." & Chr(10) _
    & "To activate it I must first tell the bank to do so  which I have just done.  However," & Chr(10) _
    & "it often takes them till the end of the day to activate your account." & Chr(10) & Chr(10) _
    & "If after you follow the below instructions and you still can't access your account," & Chr(10) _
    & "please try again later in the day." & Chr(10) & Chr(10) _
    & "Below are the instructions for setting up your online Mastercard bank account." & Chr(10) & Chr(10) _
    & "Please click on the following link: https://www.pcbmyaccount.com/index.cfm." & Chr(10) & Chr(10) _
    & "When there for the first time please click 'Sign Up' for establishing your online account" & Chr(10) _
    & "management. You will then be taken to a screen and asked for a 4 digit number. " & Chr(10) & Chr(10) _
    & "First try 4524. If that doesn’t work use the last 4 telephone digits you provided. " & Chr(10) & Chr(10) _
    & "Then enter your proxy number which is: " & Rng.Cells(1, "W") & Chr(10) & Chr(10) _
    & "You are then ready to choose your username, password and security questions." & Chr(10) & Chr(10) _
    & "If you have any problems setting up your online account please feel free to contact me." & Chr(10) & Chr(10) _
    & "In a subsequent email I will send you card loading instructions." & Chr(10) & Chr(10) _
    & "Michael" & Chr(10) _
    & "Sovereign Gold Card Support Services"
  'Send the Email
  .Display
End With

'Clear Resources
Set MItem = Nothing
Set OutlookApp = Nothing

End Sub

Sub SendEmail(Rng As Range, sAddress As String, Optional fName As String)
Dim WB As Workbook
Dim WS As Worksheet


Dim SendTo As String
Dim Blindcc As String
Dim OutlookApp As Object
Dim MItem As Object
Dim subject_ As String
Dim attach_ As String
Dim fFile
Dim omail As Outlook.MailItem
Dim sShipto As String

Application.DisplayAlerts = False

'Create Outlook
Set OutlookApp = CreateObject("Outlook.Application")

'Fill in Subject Details'
subject_ = "New Mastercard Application for (" & Rng.Cells(1, "B") & " " & Rng.Cells(1, "C") & ")"
SendTo = "nmai@banking.bz"
Blindcc = "david@offshorelawcenter.com"

'Create the Email
Set MItem = OutlookApp.CreateItem(0)
With MItem
  .To = SendTo
  .BCC = Blindcc
  .Subject = subject_
  
  '---> Attach files
  For Each fFile In Rng.SpecialCells(xlCellTypeFormulas)
        If InStr(1, fFile.Formula, "HYPERLINK") <> 0 Then
            fpos = InStr(1, fFile.Formula, "HYPERLINK") + 11
            attach_ = Mid(fFile.Formula, fpos, InStr(fpos, fFile.Formula, Chr(34)) - fpos)
            .Attachments.Add (attach_)
        End If
  Next fFile
  
  '---> Only Attach file when fName is linked ie Col K
  If fName <> "" Then
    .Attachments.Add (fName)
  End If
  
  '---> Determin shipto
  Select Case UCase(sAddress)
    Case "" 'sAddress empty then do as before
        sShipto = "Please have his card shipped to address indicated on spreadsheet."
    
    Case "RESELLER"
        sShipto = "No need to have card shipped."
    
    Case Else
        sShipto = "Please have the card shipped to below address:" & Chr(10) & sAddress

        
  End Select
  
  .Body = "Hi Nalleli," & Chr(10) & Chr(10) _
    & "Attached are the documents and load request for (" & Rng.Cells(1, "B") & " " & Rng.Cells(1, "C") & ")" & Chr(10) _
    & sShipto & Chr(10) _
    & "PIC:99554Freedom" & Chr(10) & Chr(10) _
    & "Please let me know you received this email." & Chr(10) & Chr(10) _
    & "Thank you." & Chr(10) & Chr(10) _
    & "Michael" & Chr(10) _
    & "Sovereign Gold Card Support" & Chr(10) _
    & "www.sovereigngoldcard.com"

  'Send the Email
  .Display
End With

'Clear Resources
Set MItem = Nothing
Set OutlookApp = Nothing

Application.DisplayAlerts = True
End Sub
                                            


Function CreateNewCardLoad(Rng As Range) As String
Dim sPathName As String
Dim sFileName As String
Dim sBlankCardLoad As String
Dim MaxRow As Long
Dim WS As Worksheet
Dim WB As Workbook

sBlankCardLoad = "C:\Users\Michael\Dropbox\Sovereign\MasterCard\MasterCardLoadRequests\Blank - New Card Load.xls"
sPathName = "C:\Users\Michael\Dropbox\Sovereign\MasterCard\MasterCardLoadRequests\"

'sBlankCardLoad = ActiveWorkbook.Path & "\Blank - New Card Load.xls"
'sPathName = ActiveWorkbook.Path & "\"

Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set WB = Workbooks.Open(Filename:=sBlankCardLoad)
Set WS = ActiveSheet
MaxRow = WS.UsedRange.Rows.Count

sFileName = sPathName & Rng.Cells(1, "B") & " " & Rng.Cells(1, "C") & " - New Card Load.xls"

'---> Affect Values to Card Load.xls
WS.Range("D" & MaxRow) = Rng.Cells(1, "T")
WS.Range("H" & MaxRow) = Rng.Cells(1, "B")
WS.Range("I" & MaxRow) = Rng.Cells(1, "C")
WB.SaveAs Filename:=sFileName
CreateNewCardLoad = sFileName
WB.Close savechanges:=True

'---> Clean Variables
Set WB = Nothing
Set WS = Nothing

Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
DoEvents


End Function

Function GetProxy(CC As String) As String
Dim sProxyFile As String
Dim WS As Worksheet
Dim WB As Workbook
Dim cCell As Range

sProxyFile = "C:\Users\Michael\Dropbox\Sovereign\MasterCard\Proxy_Numbers.xls"
'sProxyFile = ActiveWorkbook.Path & "\Proxy_Numbers.xls"

Set WB = Workbooks.Open(Filename:=sProxyFile)
Set WS = ActiveSheet

Set cCell = WS.UsedRange.Find(what:=CC, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not cCell Is Nothing Then
    GetProxy = cCell.Offset(, -1)
Else
    MsgBox ("This Card Number " & CC & " was not found in Proxy_Numbers.xls")
End If

WB.Close savechanges:=False

'---> Clean Variables
Set WB = Nothing
Set WS = Nothing

DoEvents

End Function



Function ProcessCC(CC As String) As String
   
Dim ILength As Integer, I As Integer
Dim CCFormat As String
   

ILength = Len(CC)
For I = 1 To ILength
    If IsNumeric(Mid(CC, I, 1)) And Mid(CC, I, 1) <> " " Then
        CCFormat = CCFormat & Mid(CC, I, 1)
    End If
Next I

ProcessCC = CCFormat

End Function
                                            

Sub SendEmailEURO(Rng As Range, sAddress As String, Optional fName As String)
Dim WB As Workbook
Dim WS As Worksheet


Dim SendTo As String
Dim Blindcc As String
Dim OutlookApp As Object
Dim MItem As Object
Dim subject_ As String
Dim attach_ As String
Dim fFile
Dim omail As Outlook.MailItem
Dim sShipto As String

Application.DisplayAlerts = False

'Create Outlook
Set OutlookApp = CreateObject("Outlook.Application")

'Fill in Subject Details'
subject_ = "New Euro MC Order for (" & Rng.Cells(1, "C") & " " & Rng.Cells(1, "B") & ")"
SendTo = "david@offshorelawcenter.com"
'Blindcc = "david@offshorelawcenter.com"

'Create the Email
Set MItem = OutlookApp.CreateItem(0)
With MItem
  .To = SendTo
  '.BCC = Blindcc
  .Subject = subject_
  
  '---> Attach files
  For Each fFile In Rng.SpecialCells(xlCellTypeFormulas)
        If InStr(1, fFile.Formula, "HYPERLINK") <> 0 Then
            fpos = InStr(1, fFile.Formula, "HYPERLINK") + 11
            attach_ = Mid(fFile.Formula, fpos, InStr(fpos, fFile.Formula, Chr(34)) - fpos)
            .Attachments.Add (attach_)
        End If
  Next fFile
  
  '---> Only Attach file when fName is linked ie Col K
  If fName <> "" Then
    .Attachments.Add (fName)
  End If
  
  '---> Determin shipto
  Select Case UCase(sAddress)
    Case "" 'sAddress empty then do as before
        sShipto = "Please send card to the address indicated in the attached files."
    
    Case Else
        sShipto = "Please send card to the following address:" & Chr(10) & sAddress
        
  End Select
  
  .Body = "David," & Chr(10) & Chr(10) _
    & "Attached are files for new Euro Mastercard order for (" & Rng.Cells(1, "C") & " " & Rng.Cells(1, "B") & ")" & Chr(10) & Chr(10) _
    & sShipto & Chr(10) & Chr(10) _
    & "Thank you." & Chr(10) & Chr(10) _
    & "Michael." & Chr(10) _


  'Send the Email
  .Display
End With

'---> Put Today's date in Col P
Rng.Cells(1, "P") = DateValue(Now)

'Clear Resources
Set MItem = Nothing
Set OutlookApp = Nothing

Application.DisplayAlerts = True
End Sub
                                            

Open in new window

0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Don't know what happened your end but it works here good. I suggest you revamp your code.

1) Take a copy of your latest Applicant Status file and give it a new name.
2) Open VBA and doubleclick on module1 and DELETE ALL the CODE THAT IS THERE.
3) Paste the below code in Module1

Sub SendActivationEmail(Rng As Range)
Dim SendTo As String
Dim sTo
Dim OutlookApp As Object
Dim MItem As Object
Dim subject_ As String
Dim attach_ As String
Dim omail As Outlook.MailItem


'---> Create Outlook
Set OutlookApp = CreateObject("Outlook.Application")

'---> Fill in Subject Details'
subject_ = "Proxy Number for Sovereign USD Mastercard" ' (" & Rng.Cells(1, "B") & " " & Rng.Cells(1, "C") & ")"

'---> Fill in email addresses
sTo = Split(Rng.Cells(1, "D"), "/")

For I = 0 To UBound(sTo)
    If SendTo <> "" Then SendTo = SendTo & "; "
    SendTo = SendTo & LTrim(RTrim(sTo(I)))
Next I


'---> Create the Email
Set MItem = OutlookApp.CreateItem(0)
With MItem
  .To = SendTo
  .Subject = subject_
  
  .Body = "Dear " & Rng.Cells(1, "B") & Chr(10) & Chr(10) _
    & "Your card must be activated first before you can access your online account." & Chr(10) _
    & "To activate it I must first tell the bank to do so  which I have just done.  However," & Chr(10) _
    & "it often takes them till the end of the day to activate your account." & Chr(10) & Chr(10) _
    & "If after you follow the below instructions and you still can't access your account," & Chr(10) _
    & "please try again later in the day." & Chr(10) & Chr(10) _
    & "Below are the instructions for setting up your online Mastercard bank account." & Chr(10) & Chr(10) _
    & "Please click on the following link: https://www.pcbmyaccount.com/index.cfm." & Chr(10) & Chr(10) _
    & "When there for the first time please click 'Sign Up' for establishing your online account" & Chr(10) _
    & "management. You will then be taken to a screen and asked for a 4 digit number. " & Chr(10) & Chr(10) _
    & "First try 4524. If that doesn’t work use the last 4 telephone digits you provided. " & Chr(10) & Chr(10) _
    & "Then enter your proxy number which is: " & Rng.Cells(1, "W") & Chr(10) & Chr(10) _
    & "You are then ready to choose your username, password and security questions." & Chr(10) & Chr(10) _
    & "If you have any problems setting up your online account please feel free to contact me." & Chr(10) & Chr(10) _
    & "In a subsequent email I will send you card loading instructions." & Chr(10) & Chr(10) _
    & "Michael" & Chr(10) _
    & "Sovereign Gold Card Support Services"
  'Send the Email
  .Display
End With

'Clear Resources
Set MItem = Nothing
Set OutlookApp = Nothing

End Sub

Sub SendEmailEURO(Rng As Range, sAddress As String, Optional fName As String)
Dim WB As Workbook
Dim WS As Worksheet


Dim SendTo As String
Dim Blindcc As String
Dim OutlookApp As Object
Dim MItem As Object
Dim subject_ As String
Dim attach_ As String
Dim fFile
Dim omail As Outlook.MailItem
Dim sShipto As String

Application.DisplayAlerts = False

'Create Outlook
Set OutlookApp = CreateObject("Outlook.Application")

'Fill in Subject Details'
subject_ = "New Euro MC Order for (" & Rng.Cells(1, "C") & " " & Rng.Cells(1, "B") & ")"
SendTo = "david@offshorelawcenter.com"
'Blindcc = "david@offshorelawcenter.com"

'Create the Email
Set MItem = OutlookApp.CreateItem(0)
With MItem
  .To = SendTo
  '.BCC = Blindcc
  .Subject = subject_
  
  '---> Attach files
  For Each fFile In Rng.SpecialCells(xlCellTypeFormulas)
        If InStr(1, fFile.Formula, "HYPERLINK") <> 0 Then
            fpos = InStr(1, fFile.Formula, "HYPERLINK") + 11
            attach_ = Mid(fFile.Formula, fpos, InStr(fpos, fFile.Formula, Chr(34)) - fpos)
            .Attachments.Add (attach_)
        End If
  Next fFile
  
  '---> Only Attach file when fName is linked ie Col K
  If fName <> "" Then
    .Attachments.Add (fName)
  End If
  
  '---> Determin shipto
  Select Case UCase(sAddress)
    Case "" 'sAddress empty then do as before
        sShipto = "Please send card to the address indicated in the attached files."
    
    Case Else
        sShipto = "Please send card to the following address:" & Chr(10) & sAddress
        
  End Select
  
  .Body = "David," & Chr(10) & Chr(10) _
    & "Attached are files for new Euro Mastercard order for (" & Rng.Cells(1, "C") & " " & Rng.Cells(1, "B") & ")" & Chr(10) & Chr(10) _
    & sShipto & Chr(10) & Chr(10) _
    & "Thank you." & Chr(10) & Chr(10) _
    & "Michael." & Chr(10) _


  'Send the Email
  .Display
End With

'---> Put Today's date in Col P
Rng.Cells(1, "P") = DateValue(Now)

'Clear Resources
Set MItem = Nothing
Set OutlookApp = Nothing

Application.DisplayAlerts = True
End Sub

Sub SendEmail(Rng As Range, sAddress As String, Optional fName As String)
Dim WB As Workbook
Dim WS As Worksheet


Dim SendTo As String
Dim Blindcc As String
Dim OutlookApp As Object
Dim MItem As Object
Dim subject_ As String
Dim attach_ As String
Dim fFile
Dim omail As Outlook.MailItem
Dim sShipto As String

Application.DisplayAlerts = False

'Create Outlook
Set OutlookApp = CreateObject("Outlook.Application")

'Fill in Subject Details'
subject_ = "New Mastercard Application for (" & Rng.Cells(1, "B") & " " & Rng.Cells(1, "C") & ")"
SendTo = "nmai@banking.bz"
Blindcc = "david@offshorelawcenter.com"

'Create the Email
Set MItem = OutlookApp.CreateItem(0)
With MItem
  .To = SendTo
  .BCC = Blindcc
  .Subject = subject_
  
  '---> Attach files
  For Each fFile In Rng.SpecialCells(xlCellTypeFormulas)
        If InStr(1, fFile.Formula, "HYPERLINK") <> 0 Then
            fpos = InStr(1, fFile.Formula, "HYPERLINK") + 11
            attach_ = Mid(fFile.Formula, fpos, InStr(fpos, fFile.Formula, Chr(34)) - fpos)
            .Attachments.Add (attach_)
        End If
  Next fFile
  
  '---> Only Attach file when fName is linked ie Col K
  If fName <> "" Then
    .Attachments.Add (fName)
  End If
  
  '---> Determin shipto
  Select Case UCase(sAddress)
    Case "" 'sAddress empty then do as before
        sShipto = "Please have his card shipped to address indicated on spreadsheet."
    
    Case "RESELLER"
        sShipto = "No need to have card shipped."
    
    Case Else
        sShipto = "Please have the card shipped to below address:" & Chr(10) & sAddress
        
  End Select
  
  .Body = "Hi Nalleli," & Chr(10) & Chr(10) _
    & "Attached are the documents and load request for (" & Rng.Cells(1, "B") & " " & Rng.Cells(1, "C") & ")" & Chr(10) _
    & sShipto & Chr(10) _
    & "PIC:99554Freedom" & Chr(10) & Chr(10) _
    & "Please let me know you received this email." & Chr(10) & Chr(10) _
    & "Thank you." & Chr(10) & Chr(10) _
    & "Michael" & Chr(10) _
    & "Sovereign Gold Card Support" & Chr(10) _
    & "www.sovereigngoldcard.com"

  'Send the Email
  .Display
End With

'Clear Resources
Set MItem = Nothing
Set OutlookApp = Nothing

Application.DisplayAlerts = True
End Sub



Function CreateNewCardLoad(Rng As Range) As String
Dim sPathName As String
Dim sFileName As String
Dim sBlankCardLoad As String
Dim MaxRow As Long
Dim WS As Worksheet
Dim WB As Workbook

sBlankCardLoad = "C:\Users\Michael\Dropbox\Sovereign\MasterCard\MasterCardLoadRequests\Blank - New Card Load.xls"
sPathName = "C:\Users\Michael\Dropbox\Sovereign\MasterCard\MasterCardLoadRequests\"

'sBlankCardLoad = ActiveWorkbook.Path & "\Blank - New Card Load.xls"
'sPathName = ActiveWorkbook.Path & "\"

Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set WB = Workbooks.Open(Filename:=sBlankCardLoad)
Set WS = ActiveSheet
MaxRow = WS.UsedRange.Rows.Count

sFileName = sPathName & Rng.Cells(1, "C") & Rng.Cells(1, "B") & " " & " - New Card.xls"

'---> Affect Values to Card Load.xls
WS.Range("D" & MaxRow) = Rng.Cells(1, "T")
WS.Range("H" & MaxRow) = Rng.Cells(1, "B")
WS.Range("I" & MaxRow) = Rng.Cells(1, "C")
WB.SaveAs Filename:=sFileName
CreateNewCardLoad = sFileName
WB.Close savechanges:=True

'---> Clean Variables
Set WB = Nothing
Set WS = Nothing

Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
DoEvents


End Function

Function GetProxy(CC As String) As String
Dim sProxyFile As String
Dim WS As Worksheet
Dim WB As Workbook
Dim cCell As Range

sProxyFile = "C:\Users\Michael\Dropbox\Sovereign\MasterCard\Proxy_Numbers.xls"
'sProxyFile = ActiveWorkbook.Path & "\Proxy_Numbers.xls"

Set WB = Workbooks.Open(Filename:=sProxyFile)
Set WS = ActiveSheet

Set cCell = WS.UsedRange.Find(what:=CC, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not cCell Is Nothing Then
    GetProxy = cCell.Offset(, -1)
Else
    MsgBox ("This Card Number " & CC & " was not found in Proxy_Numbers.xls")
End If

WB.Close savechanges:=False

'---> Clean Variables
Set WB = Nothing
Set WS = Nothing

DoEvents

End Function



Function ProcessCC(CC As String) As String
   
Dim ILength As Integer, I As Integer
Dim CCFormat As String
   

ILength = Len(CC)
For I = 1 To ILength
    If IsNumeric(Mid(CC, I, 1)) And Mid(CC, I, 1) <> " " Then
        CCFormat = CCFormat & Mid(CC, I, 1)
    End If
Next I

ProcessCC = CCFormat

End Function

Open in new window



4) SAVE and Exit the workbook.
5) Open it and test all the functions.

gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
Did as you asked and still getting same error. Then tried it on another email and it worked. Must be something in the email.

Maybe you want a copy of the offending email? Problem is that I don't want to send you all the original attachments (8 of them) that came with it as there is confidential stuff.

What do you recommend?
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
just copy the name of the attachments and post the names here must be something with the name of the attachment. Not the whole file just the names and extentsions.
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
how about a screenshot of the attachments?

attachments
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Attachements not relevant but I think the problem lies with the subject. You said:


However, not sure if it is related or not, but I'm now getting an error when I click the Save Links button of Applicant Status spreadsheet under the  Public Sub SaveAttachments() function with this highlighted in yellow:

sOrder = Mid(objMsg.Subject, lOrder, InStr(lOrder, LCase(objMsg.Subject), " ") - lOrder)

1) What is the error at this level what does it say ?
2) Is the format of the subject the same as always or something is changed ?
3) I suspect you need to have in the Subject the word 'order' and maybe this one does not. Correct ?

gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
1. popup error message:error message
2. Didn't know their had to be a specific subject. The subject could say anything.

3. Same as #2. I don't think I required that the subject be in any format or wording.
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
Not a specific subject but seems the order number is in the subject can you pls paste the subject of this email here and paste a subject of an email that works so I see the difference ?
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
subject on email that doesn't work:
Vedr: Mastercard EUR new order


subjects on emails that do work:
Sovereign Gold Card - Order 562 has recently been made
Re: FW: New reseller card applications for SkyVenture
Re: Sovereign Gold Card - Order 567 has recently been made
Sovereign Gold Card - Order 570 has recently been made

Basically every one I've received has processed with out error except the one at the top.
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
ok tks for the examples it is clear that the error is due to finding the word 'order' but no number there reason why it hits this error. I fixed it by the following:

1) Make a copy of your latest file and give it a new name
2) goto VBA and doubleclick on Sheet1 and click on the bottom left icon to view 1 sub at a time.
3) Select the Sub SaveAttachments and delete all its code and paste the below code after any End sub.


Public Sub SaveAttachments()
On Error GoTo ErrHandler

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim I As Long, J As Long, K As Long, L As Long, lTo As Long, KK As Long
Dim lngCount As Long
Dim LastRow As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim cCell As Range
Dim WS As Worksheet
Dim FileExt As String
Dim AttachRange As Range
Dim WB As Workbook
Dim WSAttach As Worksheet
Dim X, sFields, sLine
Dim ValidFile As Boolean
Dim sFile As String
Dim lOrder As Long
Dim sOrder As String

    Set WS = ActiveSheet
        
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    'On Error Resume Next
 
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
 
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    'Set objSelection = objOL.GetNamespace("MAPI").Folders("CM Template")
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
 
    ' Set the Attachment folder to be this specific path as per Jaset request on Apr 29, 2013
    strFolderpath = strFolderpath & "\OLAttachments"
    'strFolderpath = "C:\Users\Michael\Sovereign Archives"
    
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
 
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
         
        '---> Choose the color of the row
        Set cCell = ActiveCell
        LastRow = cCell.Row + 1
        Do
            '---> Locate the cell color of the last row above the current one
            LastRow = LastRow - 1
            LastRow = WS.Range("A" & LastRow).End(xlUp).Row
            
        Loop Until WS.Range("A" & LastRow).Interior.Color <> 16777215 Or LastRow = 1
        
        '---> Color the new row based on the results
        If WS.Range("A" & LastRow).Interior.Color = 14545386 Then
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 10147522
        Else
            WS.Range("A" & cCell.Row & ":AB" & cCell.Row).Interior.Color = 14545386
        End If
         
        If lngCount > 0 Then
            ' Use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            K = 0
            For I = lngCount To 1 Step -1
             
                ' Get the file name.
                strFile = objAttachments.Item(I).Filename
                 
                ' Combine with the path to the Temp folder.
                strFile = strFolderpath & "\" & strFile
                 
                ' Save the attachment as a file.
                Application.DisplayAlerts = False
                
                On Error Resume Next
                Do
                    objAttachments.Item(I).SaveAsFile strFile
                    
                    If Err <> 0 Then
                        MkDir (Left(strFile, InStrRev(strFile, "\")))
                    Else
                        On Error GoTo 0
                    End If
                Loop Until Err = 0
                
                        
                '---> Insert data in coresponding cells
                Do Until WS.Cells(cCell.Row, K + 5) = ""
                    If K + 6 = 9 Then
                        '---> Copy Insert the new row and contine in Cell E
                        WS.Cells(cCell.Row, K + 5).EntireRow.Copy
                        WS.Cells(cCell.Row, K + 5).EntireRow.Insert
                        WS.Range("E" & cCell.Row & ":H" & cCell.Row).ClearContents
                        K = -1
                    End If
                    K = K + 1
                Loop
                WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
                WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
                
                '---> Insert Order Number
                If InStr(1, LCase(objMsg.Subject), "order") <> 0 Then
                    On Error Resume Next
                    lOrder = InStr(1, LCase(objMsg.Subject), "order") + 6
                    sOrder = Mid(objMsg.Subject, lOrder, InStr(lOrder, LCase(objMsg.Subject), " ") - lOrder)
                    If Err <> 0 Then
                        On Error GoTo 0
                        WS.Range("I" & cCell.Row) = objMsg.SenderEmailAddress
                    Else
                        WS.Range("I" & cCell.Row) = "WO " & sOrder
                    End If
                Else
                    WS.Range("I" & cCell.Row) = objMsg.SenderEmailAddress
                End If
                
                '---> Insert Hyperlink
                WS.Range(WS.Cells(cCell.Row, K + 5), WS.Cells(cCell.Row, K + 5)).Formula = "=hyperlink(" & Chr(34) & strFile & Chr(34) & "," & Chr(34) & Right(strFile, Len(strFile) - InStrRev(strFile, "\")) & Chr(34) & ")"
                
                '---> Check to See if Valid Excel File
                FileExt = LCase(Right(strFile, Len(strFile) - InStrRev(LCase(strFile), ".", Len(strFile))))
                If InStr(1, LCase(FileExt), "xls") <> 0 Or InStr(1, LCase(FileExt), "xlsm") <> 0 Or InStr(1, LCase(FileExt), "xltx") <> 0 Or InStr(1, LCase(FileExt), "xlsx") <> 0 Then
                    '---> Open Workbook
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                    Set WB = Workbooks.Open(strFile)
                    Set WSAttach = WB.ActiveSheet
                                
                    '---> Test to see if Valid CC File
                    'If WSAttach.Range("P1") <> "" Then
                    If InStr(1, LCase(WSAttach.Range("A1")), "first name") <> 0 And InStr(1, LCase(WSAttach.Range("B1")), "last name") <> 0 And InStr(1, LCase(WSAttach.Range("O1")), "email address") <> 0 Then
                        '---> We are Dealing with Horizontal Spreadsheet
                        '     Assign Col A to Col C as First Name
                        '     Assign Col B to Col B as Last Name
                        WS.Range("C" & cCell.Row) = WSAttach.Range("A2")
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("O2") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("O2")
                        End If
                        
                        '---> Depending on Value of Col P affect Col T
                        If InStr(1, LCase(WSAttach.Range("P1")), "card number") <> 0 Then
                            WS.Range("T" & cCell.Row).NumberFormat = "@"
                            WS.Range("T" & cCell.Row) = ProcessCC(WSAttach.Range("P2"))
                        Else
                            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        End If
                    Else
                        '---> We are Dealing with Vertical Spreadsheet
                        '     Assign B1 to Col C as First Name
                        '     Assign B2 to Col B as Last Name
                        '     Col T = 'Not Yet Assigned'
                        WS.Range("B" & cCell.Row) = WSAttach.Range("B2")
                        WS.Range("C" & cCell.Row) = WSAttach.Range("B1")
                        WS.Range("T" & cCell.Row) = "Not Yet Assigned"
                        
                        '---> Check if Same Email or Diffrent
                        If WS.Range("D" & cCell.Row) <> WSAttach.Range("B15") Then
                            WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & WSAttach.Range("B15")
                        End If
                        
                    End If
                
                    '---> Close Workbook
                    WB.Close savechanges:=False
                    Set WSAttach = Nothing
                    Set WB = Nothing
        
                    Application.DisplayAlerts = False
                    Application.ScreenUpdating = False
        
                
                Else
                
                    '---> Check to see if Valid .csv file
                    If InStr(1, FileExt, "csv") <> 0 Then
                        '---> Open Workbook
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
            
                        Open strFile For Input As #1
                        KK = 99
                        
                        '---> Read the Header
                        Do While Not EOF(1)
                            Line Input #1, sFile
                            
                            '---> Split the File by Line
                            sLine = Split(sFile, Chr(10))
                                
                            If UBound(sLine) = 0 Then
                                lTo = 0
                            Else
                                lTo = 1
                            End If
                            
                            For L = 0 To UBound(sLine) - lTo
                                sFields = Split(sLine(L), ",")
                                
                                '---> Look for Email Address position
                                If L = 0 And KK = 99 Then
                                    For KK = 0 To UBound(sFields)
                                        If InStr(1, sFields(KK), "Email Address") <> 0 Then Exit For
                                    Next KK
                                Else
                                    If InStr(1, sFields(KK), "@") = 0 Then
                                        For KK = 0 To UBound(sFields)
                                            If InStr(1, sFields(KK), "@") <> 0 Then Exit For
                                        Next KK
                                    End If
                                End If
                                
                                '---> Test to see if Valid File
                                If L = 0 And InStr(1, sFields(0), "First Name") <> 0 And InStr(1, sFields(1), "Last Name") <> 0 And InStr(1, sFields(KK), "Email Address") <> 0 Then
                                    
                                Else
                                    'Line Input #1, sLine
                                    sFields = Split(sLine(L), ",")
                                    
                                    '---> Strip quotes prior affecting
                                    X = ""
                                    For J = 1 To Len(sFields(0))
                                        If Mid(sFields(0), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(0), J, 1)
                                        End If
                                    Next J
                                    sFields(0) = X
                                    
                                    X = ""
                                    For J = 1 To Len(sFields(1))
                                        If Mid(sFields(1), J, 1) <> Chr(34) Then
                                            X = X & Mid(sFields(1), J, 1)
                                        End If
                                    Next J
                                    sFields(1) = X
                                    
                                    WS.Range("C" & cCell.Row) = sFields(0)
                                    WS.Range("B" & cCell.Row) = sFields(1)
                                    
                                    '---> Check if Same Email or Diffrent
                                    If WS.Range("D" & cCell.Row) <> sFields(KK) Then
                                        WS.Range("D" & cCell.Row) = WS.Range("D" & cCell.Row) & " / " & sFields(KK)
                                    End If
                                End If
                                
                            Next L
                        Loop
                        
                        '---> Close the File
                        Close #1
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
                    End If
                    
                End If
                
                
            Next I
            
            '---> Check after all Attachements if Still Col T Empty
            '     then update with Not Yet Assigned.
            '     to ensure Col T always Updated with value
            If WS.Range("T" & cCell.Row) = "" Then
                WS.Range("T" & cCell.Row) = "Not Yet Assigned"
            End If
            
        Else
            '---> Update Email, Date, CC Even if no attachements
            WS.Range("A" & cCell.Row) = objMsg.ReceivedTime
            WS.Range("D" & cCell.Row) = objMsg.SenderEmailAddress
            WS.Range("T" & cCell.Row) = "Not Yet Assigned"
        End If
        
        '---> Move ActiveCell 1 row
        WS.Cells(cCell.Row + 1, 1).Select
        
    Next objMsg

Application.DisplayAlerts = True
Application.ScreenUpdating = True
DoEvents
MsgBox (lngCount & " Attachments were saved on C drive")


ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Exit Sub

ErrHandler:
X = MsgBox("This Routine will Exit due to following Error:" & Chr(10) & Chr(10) & Error(Err), vbCritical)
GoTo ExitSub


End Sub

Open in new window



4) SAVE and Exit the workbook
5) Open it and try it with different emails including the culprit one.

gowflow
0
 

Author Closing Comment

by:JaseSt
Comment Utility
Guess you gave two solutions to one question. I will submit the lower question for you to give your solution to and award you the points for that as well.

Thank you, gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
No sorry this is called point passing and is against policy. I am glad that the solution provided suits you. Pls go ahead and delete the new question.
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
ok, deleted. I do have another that is additional functionality to a solution already given.
0
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
ok no problem will attend in 2 hours when I will buzz again if you can wait no problem or else go ahead
gowflow
0
 

Author Comment

by:JaseSt
Comment Utility
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Learn more about how the humble email signature can be used as more than just an electronic business card. When used correctly, a signature can easily be tailored for different purposes by different departments within an organization.
Granting full access permission allows users to access mailboxes present in their database. By giving full access permission one can open and read the content of any mailbox but cannot send emails from that mailbox.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

763 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now