Sub AllCompanies()
On Error Resume Next
Dim db As Database
Dim rst As Recordset ' TodayEBlast records from qryEmailBlast
Dim mSV As Recordset ' ShipVerification
Dim mSQL As String
Dim mFName As String
Dim mMName As String
Dim mLName As String
Dim mName As String
Set db = OpenDatabase("V:\Main\ManiEmail\FileConsolidation.mdb")
Set mSV = db.OpenRecordset("ShipVerification")
Set rst = db.OpenRecordset("TodayEBlast")
If Not rst.BOF Then
rst.MoveLast
rst.MoveFirst
Else
MsgBox "No records for EmailBlast", 48, "No Data"
Exit Sub
End If
Do While Not rst.EOF
' procdure to make "LastName, FirstName, Initial"
If rst!CustomerName <> rst!ShiptoName Then
If InStr(1, rst!ShiptoName, "&") <> 0 Or _
InStr(1, rst!ShiptoName, ",") <> 0 Then
GoTo NextRSTrecord ' unable to reposition to lastname, firstname
End If
mName = rst!ShiptoName
mFName = Left(mName, (InStr(1, mName, " ") - 1))
mName = Mid(mName, (InStr(1, mName, " ") + 1), Len(mName))
If InStr(1, mName, " ") <> 0 Then 'there is a middle initial
If Len(Left(mName, InStr(1, mName, " ") - 1)) = 1 Then
' example "David L Green"
mFName = mFName & " " & Left(mName, 1)
mLName = Mid(mName, 3, Len(mName))
Else
If InStr(1, mName, "JR") <> 0 Or InStr(1, mName, "II") <> 0 Or _
InStr(1, mName, "III") <> 0 Or InStr(1, mName, "Jr") <> 0 Then
mLName = mName
Else
' example name "L David Green" or "David Larry Green"
mFName = mFName & " " & Left(mName, InStr(1, mName, " ") - 1) 'Left(mName, 1)
mLName = Mid(mName, (InStr(1, mName, " ") + 1), Len(mName)) '3, Len(mName))
End If
End If
Else
' example "David Green"
mLName = mName
End If
rst.Edit
rst!ShiptoName = mLName & ", " & mFName
rst.Update
End If
NextRSTrecord:
If Not rst.EOF Then
rst.MoveNext
Else
Exit Do
End If
Loop
Set rst = db.OpenRecordset("qryEmailBlast")
If Not rst.BOF Then
rst.MoveLast
rst.MoveFirst
Else
MsgBox "No data, coding error.", 48, "No Data"
Exit Sub
End If
Do While Not rst.EOF
'' records are sorted by customer number, ship to name ascending
'Build HTML file header
mEnd = ""
mCt = 0
mCustomerName = Trim(rst!CustomerName)
mCustomerID = Trim(rst!CustomerID)
mEmailAddress = Trim(rst!EmailAddress)
mDate = Format(rst!sDate, "yyyy") & "-" & Format(rst!sDate, "mm") _
& "-" & Format(rst!sDate, "dd")
frmTracking.InformationTextBox.Text = mCustomerName & " " & mCustomerID & " for " & mDate
htmlHeader = "<html>" & "<head>" & "<style type=""text/css"">"
htmlHeader = htmlHeader & ".style1" & "{" & "font-family: Calibri;"
htmlHeader = htmlHeader & "font-size: x-small;" & "font-weight: bold;"
htmlHeader = htmlHeader & "text-align: left;" & "}" & ".style2" & "{"
htmlHeader = htmlHeader & "font-family: Calibri;" & "font-size: x-small;"
htmlHeader = htmlHeader & "font-weight: bold;" & "text-align: center;"
htmlHeader = htmlHeader & "}" & "</style>" & "</head>" & "<body>"
htmlHeader = htmlHeader & "<p class=""style1"" height: 20px"">" & "Account: "
htmlHeader = htmlHeader & UCase(mCustomerName) & ", " & UCase(mCustomerID)
htmlHeader = htmlHeader & "<br />" & "Orders Shipped on: " & mDate
htmlHeader = htmlHeader & "</p>" & "<table class=""style2"" align=""left"" cellpadding=""5"" cellspacing=""0"" >"
htmlHeader = htmlHeader & "<tr>" & "<td><u>Customer Name</u></td>"
htmlHeader = htmlHeader & "<td><u>Patient ID</u></td>"
htmlHeader = htmlHeader & "<td><u>Zip Code</u></td>"
htmlHeader = htmlHeader & "<td><u>PO #</td></u>"
htmlHeader = htmlHeader & "<td><u>Order #</u></td>"
htmlHeader = htmlHeader & "<td><u> Tracking #</u></td>"
'Packages will be NA for USPS items
'htmlHeader = htmlHeader & "<td><u>Packages</u></td></tr>"
htmlHeader = htmlHeader & "<td><u>Carrier</u></td></tr>"
'Create HTML body
htmlBodyFull = ""
htmlBody = ""
Do While mCustomerID = rst!CustomerID
mShipToName = Trim(rst!ShiptoName)
If IsNull(rst!PatientID) Then
mPatientID = ""
Else
mPatientID = Trim(rst!PatientID)
End If
mZipCode = Trim(rst!ZipCode)
If Trim(rst!CustomerID) = "3TF6723" Then
If IsNull(rst!ExtCustPONo) Then
mCustPoNo = ""
Else
mCustPoNo = Trim(rst!ExtCustPONo)
End If
Else
If IsNull(rst!CustPONo) Then
mCustPoNo = ""
Else
mCustPoNo = Trim(rst!CustPONo)
End If
End If
mABCOrderNo = Trim(rst!ABCOrderNo)
mTrackingNo = Trim(rst!TrackingNo)
If InStr(1, mTrackingNo, "1Z") <> 0 Then
mPackages = "UPS" 'Trim(rst!packages)
Else
mPackages = "USPS"
End If
htmlBody = "<tr>" & "<td>" & mShipToName & "</td>"
htmlBody = htmlBody & "<td>" & mPatientID & "</td>"
htmlBody = htmlBody & "<td>" & mZipCode & "</td>"
htmlBody = htmlBody & "<td>" & mCustPoNo & "</td>"
htmlBody = htmlBody & "<td>" & mDDPOrderNo & "</td>"
If InStr(1, mTrackingNo, "1Z") Then
htmlBody = htmlBody & "<td><a HREF=""http://wwwapps.ups.com/WebTracking/processRequest?"
htmlBody = htmlBody & "HTMLVersion=5.0&Requester=NES&AgreeToTermsAndConditions=yes&loc=en_US&tracknum="
htmlBody = htmlBody & "" & mTrackingNo & """>" & mTrackingNo & "</a></td>"
Else
htmlBody = htmlBody & "<td><a HREF=""http://trkcnfrm1.smi.usps.com/PTSInternetWeb/InterLabelInquiry.do?CAMEFROM=OK&strOrigTrackNum="
htmlBody = htmlBody & "" & mTrackingNo & """>" & mTrackingNo & "</a></td>"
End If
htmlBody = htmlBody & "<td>" & mPackages & "</td></tr>"
mCt = mCt + 1
'&& CDate(mDate), mCustomerID, mABCOrderNo -- add to ShipVerification
If mCt < 5 Then
mEnd = mEnd & "<br />"
Else
mEnd = mEnd & "<br /><br />"
'Print rst!CustomerID & " " & mEnd
End If
If Not rst.EOF Then
NextRecord:
rst.MoveNext
'Compile table rows for email
htmlBodyFull = htmlBodyFull & vbCrLf & htmlBody & vbCrLf
If rst.EOF Then
Exit Do
End If
Else
'Compile table rows for email
htmlBodyFull = htmlBodyFull & vbCrLf & htmlBody & vbCrLf
Exit Do
End If
Loop
'&& CDate(mDate), mCustomerID, mCt -- add to ShipVerification
mSV.AddNew
mSV!sDate = CDate(mDate)
mSV!CustNo = mCustomerID
mSV!EM = mCt
mSV.Update
' reduce size of mEnd
If mCt > 20 And mCt < 100 Then
Do While mCt <> 20
mEnd = Right(mEnd, Len(mEnd) - 6)
mCt = mCt - 1
Loop
End If
If mCt >= 100 Then
Do While mCt <> 20
mEnd = Right(mEnd, Len(mEnd) - 12)
mCt = mCt - 1
Loop
End If
'Close HTML tags
htmlEnd = "</table>" & _
"<br /><br /><br /><br />" & _
"</body>" & _
"</html>" & mEnd
'Note
htmlNote = "<html>" & "<head>" & "<title></title>" & "<style type=""text/css"">"
htmlNote = htmlNote & "p.MsoNormal" & "{margin:0in;" & "margin-bottom:.0001pt;"
htmlNote = htmlNote & "font-size:11.0pt;" & "font-family:""Calibri"",""sans-serif"";}"
htmlNote = htmlNote & "}" & "</style>" & "</head>" & "<body>"
htmlNote = htmlNote & "<p class=""MsoNormal"">"
htmlNote = htmlNote & "<span style=""FONT-SIZE: 10pt; FONT-FAMILY: 'Segoe UI','sans-serif'""><o:p></o:p>"
htmlNote = htmlNote & "<p><b>NOTE:</b><br/>"
htmlNote = htmlNote & "The information listed is for both USPS and UPS shipments.<br/>"
htmlNote = htmlNote & "Clicking on a tracking number will take you directly to the Carrier's<br/>"
htmlNote = htmlNote & "website so you can print out the delivery information.</p>"
htmlNote = htmlNote & "<p>The information is stored by the Carrier for no more than Ninety (90) days.<br/>"
htmlNote = htmlNote & " " & "If you have any questions please contact your<br/>"
htmlNote = htmlNote & "ABC Customer Service Representative at 1-800-555-1212.</p>"
htmlNote = htmlNote & "</body>" & "</html>"
'Signature
htmlSignature = "<html>" & "<head>" & "<title></title>" & "<style type=""text/css"">"
htmlSignature = htmlSignature & "p.MsoNormal" & "{margin:0in;" & "margin-bottom:.0001pt;"
htmlSignature = htmlSignature & "font-size:11.0pt;" & "font-family:""Calibri"",""sans-serif"";}"
htmlSignature = htmlSignature & "a:link" & "{color:blue;" & "text-decoration:underline;"
htmlSignature = htmlSignature & "}" & "</style>" & "</head>" & "<body>"
htmlSignature = htmlSignature & "<p class=""MsoNormal"">" & "<b><span style=""FONT-SIZE: 10pt; FONT-FAMILY: 'Lucida Handwriting'"">"
htmlSignature = htmlSignature & "<img id=""Picture_x0020_1"" alt=""ABC Supply Logo"" height=""29"""
htmlSignature = htmlSignature & "src=""E:\ABCManifestEmail\ABCLogo.bmp"" width=""137"" /></span><u><span"
htmlSignature = htmlSignature & "style=""FONT-SIZE: 10pt; COLOR: blue; FONT-FAMILY: 'Segoe UI','sans-serif'""><o:p></o:p></span></u></b></p>"
htmlSignature = htmlSignature & "<p class=""MsoNormal"">" & "<b><span style=""FONT-SIZE: 12pt; FONT-FAMILY: 'Lucida Handwriting'"">Customer "
htmlSignature = htmlSignature & "Service<o:p></o:p></span></b></p>" & "<p class=""MsoNormal"">"
htmlSignature = htmlSignature & "<span style=""FONT-SIZE: 10pt; FONT-FAMILY: 'Segoe UI','sans-serif'"">85851 10th Street North <o:p></o:p>"
htmlSignature = htmlSignature & "</span>" & "</p>" & "<p class=""MsoNormal"">" & "<span style=""FONT-SIZE: 10pt; FONT-FAMILY: 'Segoe UI','sans-serif'"">St. "
htmlSignature = htmlSignature & "Marcus, MN 99999<o:p></o:p></span></p>" & "<p class=""MsoNormal"">"
htmlSignature = htmlSignature & "<span style=""FONT-SIZE: 10pt; FONT-FAMILY: 'Segoe UI','sans-serif'"">P: "
htmlSignature = htmlSignature & "800.555.1212 F: 800.555.1212 <o:p></o:p></span>" & "</p>" & "<p class=""MsoNormal"">"
htmlSignature = htmlSignature & "<b><u>" & "<span style=""FONT-SIZE: 10pt; COLOR: blue; FONT-FAMILY: 'Segoe UI','sans-serif'"">"
htmlSignature = htmlSignature & "<a href=""mailto:abc@abcsupply.com""" & "title=""blocked::mailto:abc@abcsupply.com"">abc@abcsupply.com</a><o:p></o:p></span></u></b></p>"
htmlSignature = htmlSignature & "</body>" & "</html>"
'Compile full email
'htmlEmail = htmlHeader & vbCrLf & htmlBodyFull & vbCrLf & htmlEnd & vbCrLf & htmlSignature & "<br />" & "<br />"
htmlEmail = htmlHeader & vbCrLf & htmlBodyFull & htmlEnd & vbCrLf & htmlNote & vbCrLf & htmlSignature
'Send Email
subSendEmail
htmlBodyFull = ""
htmlBody = ""
Loop
End Sub
Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.
”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.
Our community of experts have been thoroughly vetted for their expertise and industry experience.