Send email based on values in certain cells - Applicant Status Euro MC Order
This one is very similar to what was done with a previous solution:
https://www.experts-exchange.com/questions/28156647/Part-7-to-Import-more-data-into-spreadsheet.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.co
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
https://www.experts-exchange.com/questions/28156647/Part-7-to-Import-more-data-into-spreadsheet.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.co
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
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
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
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
ASKER
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.co
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.co
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
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.
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 SubASKER
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
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
4) SAVE and Exit the workbook.
5) Open it and test all the functions.
gowflow
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 Function4) SAVE and Exit the workbook.
5) Open it and test all the functions.
gowflow
ASKER
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?
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?
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
gowflow
ASKER
how about a screenshot of the attachments?
Attachements not relevant but I think the problem lies with the subject. You said:
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
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
ASKER
1. popup 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.
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.
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
gowflow
ASKER
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.
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.
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.
4) SAVE and Exit the workbook
5) Open it and try it with different emails including the culprit one.
gowflow
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 Sub4) SAVE and Exit the workbook
5) Open it and try it with different emails including the culprit one.
gowflow
ASKER
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
Thank you, gowflow
ASKER
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
gowflow
ASKER
ok, deleted. I do have another that is additional functionality to a solution already given.
ok no problem will attend in 2 hours when I will buzz again if you can wait no problem or else go ahead
gowflow
gowflow
ASKER
Ok, here it is whenever you can get to it. Thank you!
https://www.experts-exchange.com/questions/28300422/Send-another-email-additional-function-requested-to-a-previous-solution.html
https://www.experts-exchange.com/questions/28300422/Send-another-email-additional-function-requested-to-a-previous-solution.html
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