Dim InsertCount As Integer
Dim UpdateCount As Integer
    Dim Conn As ADODB.Connection

' Insert the email that was just recieved
Private Sub InsertRecievedEmail(ByVal Item As MailItem, CustID As Integer)
On Error GoTo E
    Dim Conn As ADODB.Connection
    Set Conn = New ADODB.Connection
    MM_MyConn_STRING = "Provider=SQLOLEDB.1;User Id=sa;Initial Catalog=Products;Data Source=glacier2"
    Conn.ConnectionString = MM_MyConn_STRING
    If InStr(Item.Body, "--") <> 0 Then
        strBody = Left(Item.Body, InStr(Item.Body, "--") - 3)
    Else
        strBody = Item.Body
    End If
    If InStr(strBody, "<HR") <> 0 Then
        strBody = Left(strBody, InStr(Item.Body, "<HR") - 1)
    End If
    If InStr(strBody, "__") <> 0 Then
        strBody = Left(strBody, InStr(Item.Body, "__") - 1)
    End If
    Conn.Open
    Dim EmailNum As Integer
    Dim RecEmailNum As ADODB.Recordset
    Set RecEmailNum = New ADODB.Recordset
    RecEmailNum.Open "Select Top 1 CommentID From Comments Order By CommentID desc", Conn
    If RecEmailNum.EOF Then
        EmailNum = 1
    Else
        EmailNum = RecEmailNum("CommentID") + 1
    End If
    strBody = Replace(Replace(strBody, "'", ""), vbCr, "<BR>")
    strFrom = Replace(Item.Reply.Recipients(1).Address, "'", "")
    strSubject = Replace(Item.Subject, "'", "")
    ' The StaffID for mcallahan@sportsmanager.us
    StaffID = 1
    Conn.Execute "Insert Into Comments Values(" & EmailNum & ",'" & strBody & "','From'," & _
                 CustID & ",'" & strFrom & "',-1,-1," & StaffID & ",'" & strSubject & "','" & _
                 Month(Item.CreationTime) & "/" & Day(Item.CreationTime) & "/" & Year(Item.CreationTime) & "','" & Item.CreationTime & "','','" & Item.EntryID & "')"
    MsgBox "Email Inserted" & vbCr & "From :" & strFrom & vbCr & "On :" & Item.CreationTime & vbCr & vbCr & Replace(strBody, "<BR>", vbCr), vbOKOnly
    InsertCount = InsertCount + 1
    Conn.Execute "Update Login Set LastEmailedFromDate='" & Month(Item.CreationTime) & "/" & Day(Item.CreationTime) & "/" & Year(Item.CreationTime) & "' Where Cast(LastEmailedFromDate as datetime)<'" & Month(Item.CreationTime) & "/" & Day(Item.CreationTime) & "/" & Year(Item.CreationTime) & "' And CustID=" & CustID
    RecEmailNum.Close
    Set RecEmailNum = Nothing
    Conn.Close
    Exit Sub
E:
 '   MsgBox ("Error (" & Err.Description & ")... contact Michael")
End Sub

' Check to see if this email is from a customer in the configurator database
Private Function IsConfigCustomer(strEmail As String) As Integer
On Error GoTo E
    Dim Conn As ADODB.Connection
    Set Conn = New ADODB.Connection
    MM_MyConn_STRING = "Provider=SQLOLEDB.1;User Id=sa;Initial Catalog=Products;Data Source=glacier2"
    Conn.ConnectionString = MM_MyConn_STRING
    Conn.Open
    If strEmail = "" Or InStr(UCase(strEmail), "@sportsmanager.us") <> 0 Then
        IsConfigCustomer = 0
        Conn.Close
        Exit Function
    End If
    Dim RecConfigCust As ADODB.Recordset
    Set RecConfigCust = New ADODB.Recordset
    RecConfigCust.Open "Select CustID From Login Where Email='" & strEmail & "' Or SecEmail='" & strEmail & "'", Conn
    If RecConfigCust.EOF Then
        IsConfigCustomer = 0
        RecConfigCust.Close
        Set RecConfigCust = Nothing
        Conn.Close
        Exit Function
    Else
        IsConfigCustomer = RecConfigCust("CustID")
        RecConfigCust.Close
        Set RecConfigCust = Nothing
        Conn.Close
        Exit Function
    End If
    Set RecConfigCust = Nothing
    Conn.Close
    Exit Function
E:
'    MsgBox ("Error (" & Err.Description & ")... contact Michael")
End Function

' Check to see if this email has already been inserted
Public Function EmailInserted(strEntryID As String) As Boolean
On Error GoTo E
    Dim Conn As ADODB.Connection
    Set Conn = New ADODB.Connection
    MM_MyConn_STRING = "Provider=SQLOLEDB.1;User Id=sa;Initial Catalog=Products;Data Source=glacier2"
    Conn.ConnectionString = MM_MyConn_STRING
    Conn.Open
    Dim RecEmail As ADODB.Recordset
    Set RecEmail = New ADODB.Recordset
    RecEmail.Open "Select OutlookEntryID From Comments Where OutlookEntryID='" & strEntryID & "'", Conn
    If RecEmail.EOF Then
        EmailInserted = False
        Set RecEmail = Nothing
        Conn.Close
        Set Conn = Nothing
        Exit Function
    Else
        EmailInserted = True
        Set RecEmail = Nothing
        Conn.Close
        Set Conn = Nothing
        Exit Function
    End If
E:
 '   MsgBox ("Error (" & Err.Description & ")... contact Michael")
End Function

Sub InsertEmails()
On Error Resume Next
    InsertCount = 0
    Dim strAddress As String
    Dim CustID As Integer
    Dim Continue As Boolean
    Dim ofFolder As MAPIFolder
    Set ofFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    For Each mail In ofFolder.Items
        If mail.Attachments(1) = "" Then
        Continue = True
        If EmailInserted(mail.EntryID) = False Then
            strAddress = mail.Reply.Recipients(1).Address
            ' Make Sure the email is not coming directly from our server
            ' and that if copied to more than oner person here the email
            ' is saved only once
            If LCase(mail.Recipients(1).Address) <> "mcallahan@sportsmanager.us" Then
                Continue = False
            End If
            ' Make sure this email is not coming from the configurator
            ' in which case it has already been saved
            If mail.Subject = "NTSI Web Comment/Question" Or mail.Subject = "NTSI Web Quote Comment/Question" Or mail.Subject = "NTSI Web Quote Purchase" Or mail.Subject = "NTSI Corporate/Volume Discount Request" Then
                Continue = False
            End If
            If Continue = True Then
            CustID = IsConfigCustomer(strAddress)
            If CustID > 0 Then
                InsertRecievedEmail mail, CustID
            End If
            End If
        End If
        Else
            a = 1
        End If
    Next
    If InsertCount <> 1 Then
        MsgBox InsertCount & " Emails Inserted", vbOKOnly
    Else
        MsgBox InsertCount & " Email Inserted", vbOKOnly
    End If
    Exit Sub
E:
  '  MsgBox ("Error (" & Err.Description & ")... contact Michael")
End Sub

Sub EbaySearchEmail(ByVal objEmail As Object)
    Dim Conn As ADODB.Connection
    Set Conn = New ADODB.Connection
    MM_MyConn_STRING = "Provider=SQLOLEDB.1;User Id=sa;Initial Catalog=Products;Data Source=glacier2"
    Conn.ConnectionString = MM_MyConn_STRING
    Conn.Open
    Dim RecEbaySearch As ADODB.Recordset
    Set RecEbaySearch = New ADODB.Recordset
    Dim RecEbayListing As ADODB.Recordset
    Set RecEbayListing = New ADODB.Recordset
    Dim RecEbayListingExists As ADODB.Recordset
    Set RecEbayListingExists = New ADODB.Recordset
    RecEbaySearch.Open "Select EbaySearchID From EbaySearches Where ProductSearch='" & Replace(LCase(objEmail.Subject), "ebay favorite search: ", "") & "'", Conn
    esnum = RecEbaySearch("EbaySearchID")
    Dim strEmail As String
    Dim Done As Boolean
    Dim strItemName, strItemLink, strItemNumber, strItemPrice, strBids, strBuyNow, strDate, strTime As String
    Done = False
    strEmail = objEmail.Body
    strEmail = Mid(strEmail, InStr(LCase(strEmail), "end date</font></td>") + 20)
    strEmail = Left(strEmail, InStr(LCase(strEmail), "</table>"))
    strEmail = Replace(Replace(strEmail, vbCr, " "), Chr(10), " ")
    Do Until Done = True
        If InStr(LCase(strEmail), "<a ") = 0 Then
            Done = True
        Else
            strEmail = Mid(strEmail, InStr(LCase(strEmail), "<a ") + 10)
            strItemLink = Left(strEmail, InStr(LCase(strEmail), vbQuote & ">") - 2)
            strItemLink = Replace(Replace(strItemLink, " ", ""), "&amp;", "&")
            strTempEmail = Mid(strEmail, InStr(LCase(strEmail), "item=") + 5)
            strItemNumber = Left(strTempEmail, InStr(strTempEmail, "&") - 1)
            strTempEmail = ""
            strEmail = Mid(strEmail, InStr(strEmail, ">") + 1)
            strItemName = Left(strEmail, InStr(LCase(strEmail), "</a") - 1)
            strEmail = Mid(strEmail, InStr(strEmail, "$") + 1)
            strItemPrice = Left(strEmail, InStr(strEmail, vbQuote & ".") + 2)
            strEmail = Mid(strEmail, InStr(LCase(strEmail), "<font") + 5)
            strEmail = Mid(strEmail, InStr(LCase(strEmail), ">") + 1)
            strBids = Left(strEmail, InStr(LCase(strEmail), ">") - 1)
            strBids = Left(strEmail, InStr(strBids, "<") - 1)
            If InStr(LCase(strEmail), "buyitnow") = 0 Then
                strBuyNow = ""
            Else
                strBuyNow = "T"
            End If
            strEmail = Mid(strEmail, InStr(LCase(strEmail), "<font") + 5)
            strEmail = Mid(strEmail, InStr(LCase(strEmail), ">") + 1)
            strTempDate = Left(strEmail, InStr(LCase(strEmail), "pst") - 1)
            strTempDate = DateAdd("h", 3, strTempDate)
            If Hour(strTempDate) > 12 Then
                strDate = Month(strTempDate) & "/" & Day(strTempDate) & "/" & Year(strTempDate) & _
                          " " & Hour(strTempDate) - 12 & ":" & Minute(strTempDate) & ":" & _
                          Second(strTempDate) & " PM"
            Else
                 If Hour(strTempDate) < 12 Then
                    strDate = Month(strTempDate) & "/" & Day(strTempDate) & "/" & Year(strTempDate) & _
                              " " & Hour(strTempDate) & ":" & Minute(strTempDate) & ":" & _
                              Second(strTempDate) & " AM"
                 Else
                    strDate = Month(strTempDate) & "/" & Day(strTempDate) & "/" & Year(strTempDate) & _
                              " " & Hour(strTempDate) & ":" & Minute(strTempDate) & ":" & _
                              Second(strTempDate) & " PM"
                 End If
            End If
            strTempDate = ""
            strTime = Mid(strDate, InStr(strDate, " ") + 1)
            RecEbayListingExists.Open "Select EbayListingID From EbayListing Where ItemNumber='" & Replace(strItemNumber, "'", "") & "'", Conn
            If RecEbayListingExists.EOF Then
                RecEbayListing.Open "Select Top 1 EbayListingID From EbayListing Order By EbayListingID desc", Conn
                If RecEbayListing.EOF Then
                    elnum = 1
                Else
                    elnum = RecEbayListing("EbayListingID") + 1
                End If
                RecEbayListing.Close
                Conn.Execute "Insert Into EbayListing Values(" & elnum & "," & esnum & ",'" & Replace(strItemName, "'", "") & _
                             "','" & Replace(strItemLink, "'", "") & "','" & Replace(strItemNumber, "'", "") & _
                             "'," & Replace(strItemPrice, "'", "") & ",'" & Replace(strBids, "'", "") & _
                             "','" & Replace(strBuyNow, "'", "") & "','" & Replace(strDate, "'", "") & _
                             "','" & Replace(strTime, "'", "") & "','T','" & Date & " " & Time & "','','','','')"
                InsertCount = InsertCount + 1
            Else
                Conn.Execute "Update EbayListing Set ItemName='" & Replace(strItemName, "'", "") & _
                             "',ItemLink='" & Replace(strItemLink, "'", "") & _
                             "',ItemPrice=" & Replace(strItemPrice, "'", "") & ",ItemBids='" & Replace(strBids, "'", "") & _
                             "',ItemBuyNow='" & Replace(strBuyNow, "'", "") & "',ItemEndDate='" & Replace(strDate, "'", "") & _
                             "',ItemEndTime='" & Replace(strTime, "'", "") & "',Active='T',DateUpdated='" & Date & " " & Time & _
                             "' Where ItemNumber='" & Replace(strItemNumber, "'", "") & "'"
                UpdateCount = UpdateCount + 1
            End If
            RecEbayListingExists.Close
        End If
    Loop
    Conn.Execute "Update EbayListing Set Active='F' Where EbaySearchID=" & esnum & " And DateUpdated<'" & Date & "'"
    Conn.Close
End Sub

Private Sub CheckSeller(strLink, strItem)
On Error Resume Next
    Dim IE As SHDocVw.InternetExplorer
    Set IE = CreateObject("InternetExplorer.Application")
    Dim strPage As String
    Dim strSeller As String
    IE.AddressBar = False
    IE.Visible = False
    IE.Navigate (strLink)
    Do While IE.Busy
    Loop
    strPage = Left(IE.Document.Body.innerText, 5000)
    Do While strPage = ""
        strPage = Left(IE.Document.Body.innerText, 5000)
    Loop
   ' If strPage = "" Then
    If Len(strPage) < 50 Then Stop
    IE.Quit
    Set IE = Nothing
    strPage = Replace(Replace(Replace(strPage, vbCr, ""), Chr(10), ""), vbTab, " ")
    strPage = Mid(strPage, InStr(LCase(strPage), "seller information") + 18)
    If InStr(strPage, "(") > 1 Then strSeller = Left(strPage, InStr(strPage, "(") - 1)
    If Len(strSeller) < 25 Then
        Conn.Execute "Update EbayListing Set SellerName='" & Replace(strSeller, "'", "") & "' Where ItemNumber='" & strItem & "'"
    Else
        Conn.Execute "Update EbayListing Set SellerName='***Unknown***' Where ItemNumber='" & strItem & "'"
    
    End If
    Static i
    i = i + 1
    If i > 500 Then Stop
    Debug.Print i & ") - " & strSeller
End Sub

Sub UpdateEbaySellers()
 '   Dim Conn As ADODB.Connection
  '  Set Conn = New ADODB.Connection
   ' MM_MyConn_STRING = "Provider=SQLOLEDB.1;User Id=sa;Initial Catalog=Products;Data Source=glacier2"
    'Conn.ConnectionString = MM_MyConn_STRING
   ' Conn.Open
       Set Conn = New ADODB.Connection
    MM_MyConn_STRING = "Provider=SQLOLEDB.1;User Id=sa;Initial Catalog=Products;Data Source=glacier2"
    Conn.ConnectionString = MM_MyConn_STRING
    Conn.Open
    Dim RecEbayListing As ADODB.Recordset
    Set RecEbayListing = New ADODB.Recordset
    RecEbayListing.Open "Select * From EbayListing Where SellerName='' Or SellerName Is Null Order By EbayListingID desc", Conn
    Do Until RecEbayListing.EOF
        CheckSeller RecEbayListing("ItemLink"), RecEbayListing("ItemNumber")
        RecEbayListing.MoveNext
    Loop
End Sub

Sub EbayListing()
'On Error Resume Next
    InsertCount = 0
    Dim strAddress As String
    Dim CustID As Integer
    Dim Continue As Boolean
    Dim ofFolder As MAPIFolder
    Dim objNewMail As MailItem
    Set ofFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    If DateDiff("s", ofFolder.Items.GetLast.CreationTime, ofFolder.Items.GetFirst.CreationTime) > 0 Then
        Set objNewMail = ofFolder.Items.GetFirst
        Move = "next"
    Else
        Set objNewMail = ofFolder.Items.GetLast
        Move = "prev"
    End If
    Continue = True
    For Each mail In ofFolder.Items
     '   If DateDiff("d", objNewMail.CreationTime, Date) > 1 Then exit for
  '      If mail.Attachments(1) = "" Then
        If InStr(LCase(mail), "undeliverable:") <> 1 Then
        'If LCase(mail.Reply.Recipients(1).Address) = "savedsearches@ebay.com" Then
            EbaySearchEmail mail
        'End If
        End If
   '     If Move = "next" Then
    '        Set mail = ofFolder.Items.GetNext
     '   Else
      '      Set mail = ofFolder.Items.GetNext
       ' End If
   '     End If
    Next
    If InsertCount <> 1 Then
        MsgBox InsertCount & " Ebay Listings Inserted", vbOKOnly
    Else
        MsgBox InsertCount & " Ebay Listings Inserted", vbOKOnly
    End If
    If UpdateCount <> 1 Then
        MsgBox UpdateCount & " Ebay Listings Updated", vbOKOnly
    Else
        MsgBox UpdateCount & " Ebay Listings Updated", vbOKOnly
    End If
    Exit Sub
E:
  '  MsgBox ("Error (" & Err.Description & ")... contact Michael")
End Sub