Reading SMS in Outllok with VBA (1 Viewer)

[Reflex_ht]

Hello,

Out transport company wants to have a system with Status notifications using mobile phones. The idea:

Drivers send an SMS to us with a specific code. The VBA in Outlook reads the SMS, identifies the record in our accdb over a ID and saves data in the accdb. In Outlook we are connected to a smarthphone that has SMS sync with the Exchange server.

The code in Outlook:

Option Explicit
Option Compare Text

Sub Status()
On Error GoTo EH

Dim ws As Workspace
Dim db As DAO.Database
Dim rsD As DAO.Recordset
Dim DBEngige As Object

Dim SourceMsg As String
Dim Message As String
Dim MsgCount As Integer
Dim DestFolder As Outlook.MAPIFolder
Dim DestFolder2 As Outlook.MAPIFolder

Dim Liste As String
Dim StatusID As String
Dim HNummer As String
Dim Funktion As String
Dim Daten As String
Dim tbl_Liste As String
Dim ContainerNR As String
Dim SiegelNr As String
Dim Status As String
Dim Status_log As String

Dim Email As String
Dim ConSize As String
Dim ConNr As String
Dim Firma As String
Dim Uhrzeit As String
Dim Kundenref As String
Dim Msg_OK As Boolean
Dim StatusID_temp As String
Dim Fahrer As String
Dim Update_OK As Boolean
Dim Counter As Integer

Counter = 0

Start:
Msg_OK = True
Update_OK = True
tbl_Liste = ""
StatusID = 0

Dim myOlItems As Outlook.Items
Set myOlItems = Application.GetNamespace("MAPI").Folders("Inbox").Folders("Posteingang").Items
Set DestFolder = Application.GetNamespace("MAPI").Folders("inbox").Folders("Posteingang").Folders("Readed")
Set DestFolder2 = Application.GetNamespace("MAPI").Folders("Inbox").Folders("Posteingang").Folders("Error")

Dim Msg As Object
For Each Msg In myOlItems
    
   SourceMsg = UCase(Msg.HTMLBody)
   
   Message = Mid(SourceMsg, Nz(InStr(SourceMsg, "<FONT SIZE=2>"), 0) + 13)
   Message = Left(Message, Nz(InStrRev(Message, "</FONT>"), 0))
   Message = Replace(Message, "<", "")
   Message = Replace(Message, "BR>", "")
   Message = Replace(Message, vbNewLine, "")
        
   Liste = Left(Message, 1)
   If Liste = "M" Then tbl_Liste = "Munchen"
   If Liste = "S" Then tbl_Liste = "Salzburg"
   If Liste = "U" Then tbl_Liste = "Ulm"

   If InStr(Message, " ") > 1 Then
        StatusID_temp = Mid(Message, 2, InStr(Message, " ") - 1)
        If IsNumeric(StatusID_temp) Then StatusID = CInt(StatusID_temp)
        Funktion = Mid(Message, InStr(Message, " ") + 1, 1)
   End If
   
   If InStrRev(Message, " ") > 0 Then Daten = Mid(Message, InStrRev(Message, " ") + 1)

   HNummer = Nz(Msg.SenderName, "")
   Status_log = Nz(Msg.CreationTime, Now())

If tbl_Liste = "" Or InStr(Message, " ") < 2 Or StatusID = 0 Or InStrRev(Message, " ") < 1 Then
Msg_OK = False
GoTo Gelesen
End If

    Set ws = DBEngine.Workspaces(0)
    Set db = ws.OpenDatabase("The Path in our Public server")
    Set rsD = db.OpenRecordset("SELECT * From tbl_DL_" & tbl_Liste & "_" & Year(Date) & " WHERE ID=" & StatusID & " ;", dbOpenDynaset)
    If rsD.RecordCount > 0 Then
    
        Email = Nz(rsD![Email], "")
        ConSize = Nz(rsD![ConSize], "")
        ConNr = Nz(rsD![ConNr], "")
        Firma = Nz(rsD![Firma], "")
        Uhrzeit = Nz(rsD![Uhrzeit], "")
        Kundenref = Nz(rsD![Kundenref], "")
        Fahrer = Nz(rsD![Fahrer], "")
        
        If Funktion = "C" Then
            rsD.Edit
            rsD![ConNr] = Daten
            rsD![Status_log] = Status_log
            Call mdl_Aviso.Aviso(tbl_Liste, Email, ConSize, Daten, Firma, Uhrzeit, Kundenref)
            rsD![AvisoS] = True
            rsD.Update
        End If
        
        If Funktion = "W" Then
            rsD.Edit
            rsD![Status] = "W"
            rsD![Siegelnummer] = Daten
            rsD![Status_logW] = Status_log
            rsD.Update
        End If
        
        If Funktion = "A" Then
            rsD.Edit
            rsD![Status] = "A"
            rsD![Status_logA] = Status_log
            rsD.Update
        End If
    End If
    
Gelesen:
    If Msg_OK = True Then
        Msg.UnRead = False
        If Update_OK = True Then Msg.Move DestFolder
    Else
        Msg.UnRead = True
        Msg.Move DestFolder2
    End If
     
Msg_OK = True
Update_OK = True


Next Msg

Counter = Counter + 1
If Counter < 4 Then
    Set myOlItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("SMS").Items
    MsgCount = myOlItems.Count
    If MsgCount > 0 Then Resume Start
End If


EH:
If Err.Number = 3218 Then
    Update_OK = False
    Set db = Nothing
    rsD.Close
    Set rsD = Nothing
    Resume Gelesen
End If


End Sub

More about it:

In OUtlook we have 3 Folders: Inbox (for Incoming SMS), Read (for Proccessed SMS) and Error(for SMS where a error ocured)

My problem is now that i can´t loop trough all SMS wile moving some of them. When I have to move all SMS it stops at the middle

Because of that I hava a part of the code that starts it selfe 4 Times to be shure that it reads all SMS. That is slowing Oulook down

I also want that SMS witch data can´t be updated to the accdb (because someone else is editing it) wait in the inbox but in that case i have to be careful to not make a endless loop it hapend severel times

Does someon have suggestions how to get rid of all that problems? THX in advance

 

[stopher]

Hi

The problem seems to be the way Outlook is indexing its objects (mailItems). Imagine if you have 4 items and you move the 1st item. This leaves you with three items and you move item 2. This then leaves you with two items but if you try to reference item 3 it doesn't exists. Tbh I really don't know the reason why it doesn't work but it doesn't.

The following method does work. To fix, instead of a For Each loop, construct your loop like this:

    Set msg = myOlItems.Find("[SenderName]<> ''")
    Do While TypeName(msg) <> "Nothing"
        msg.Move DestFolder    'or whatever other code you want here
        Set msg = myOlItems.FindNext
    Loop

As an aside, I notice you've used GOTO. As a general principle GOTO should only be used the likes of error handling and not for in code constructs. Instead you could put the block of code that you've foreced to skip inside and ELSE statement. This makes the code much easier to follow and decode.

Also, you should comment your code - particularly if you are posting it as it makes it much easier for readers to understand and sense check what is supposed to be happening.

Also, I see you have opened a recordset inside a loop. I think a better way is open the recordset before the loop for all records then just search the recordset within the loop. I think (not sure) that this would be more effient. Maybe a better way might be to simple execute an SQL UPDATE statement (again not sure).

I also notice from your SQL that you are accessing a table for a specific year. As a general principle you should not really store different years in different tables. Just store all years in one table (with an additional field denoting the year). I appreciate table sizes can be of a concern but you really need to be well into the 100s of 1000s of records to worry.

hth
Chris

 

[Reflex_ht]

Thank you stopher

The code is now like this:

Option Explicit
Option Compare Text

Sub Status()
On Error GoTo EH
Dim ws As Workspace
Dim db As DAO.Database
Dim rsD As DAO.Recordset
Dim DBEngige As Object
Dim SourceMsg As String
Dim Message As String
Dim MsgCount As Integer
Dim DestFolder As Outlook.MAPIFolder
Dim DestFolder2 As Outlook.MAPIFolder
Dim Liste As String
Dim StatusID As String
Dim HNummer As String
Dim HNummerD As String
Dim HNummerD2 As String
Dim Funktion As String
Dim Daten As String
Dim tbl_Liste As String
Dim ContainerNR As String
Dim SiegelNr As String
Dim Status As String
Dim Status_log As String
Dim Email As String
Dim ConSize As String
Dim ConNr As String
Dim Firma As String
Dim Uhrzeit As String
Dim Kundenref As String
Dim Msg_OK As Boolean
Dim StatusID_temp As String
Dim Fahrer As String
Dim Fahrer2 As String
Dim Update_OK As Boolean
Dim DFName As String
Dim Msg As Object
Dim myOlItems As Outlook.Items

Set myOlItems = Application.GetNamespace("MAPI").Folders("Status@ics-logistik.com").Folders("Posteingang").Items
Set ws = DBEngine.Workspaces(0)
Set db = ws.OpenDatabase("X:\ICS\DATEN\DATEN.accdb")
Set Msg = myOlItems.Find("[SenderName]<>''")
Do While TypeName(Msg) <> "Nothing"
   Msg_OK = True
   Update_OK = True
   tbl_Liste = ""
   StatusID = 0
   DFName = "Gelesen"
   SourceMsg = UCase(Msg.HTMLBody)
   If SourceMsg <> "" Then
        Message = Mid(SourceMsg, Nz(InStr(SourceMsg, "<FONT SIZE=2>"), 0) + 13)
        Message = Left(Message, Nz(InStrRev(Message, "</FONT>"), 0))
        Message = Replace(Message, "<", "")
        Message = Replace(Message, "BR>", "")
        Message = Replace(Message, vbNewLine, "")
        Liste = Left(Message, 1)
        If Liste = "M" Then tbl_Liste = "Munchen"
        If Liste = "S" Then tbl_Liste = "Salzburg"
        If Liste = "U" Then tbl_Liste = "Ulm"
        If tbl_Liste <> "" Then
            If InStr(Message, " ") > 1 And InStrRev(Message, " ") > 0 Then
                StatusID_temp = Mid(Message, 2, InStr(Message, " ") - 1)
                If IsNumeric(StatusID_temp) Then
                    StatusID = CInt(StatusID_temp)
                    If StatusID > 0 Then
                        Funktion = Mid(Message, InStr(Message, " ") + 1, 1)
                        Daten = Mid(Message, InStrRev(Message, " ") + 1)
                        HNummer = Nz(Msg.SenderName, "")
                        Status_log = Nz(Msg.CreationTime, Now())
                        Set rsD = db.OpenRecordset("SELECT * From tbl_DL_" & tbl_Liste & "_" & Year(Date) & " WHERE ID=" & StatusID & " ;", dbOpenDynaset)
                        If rsD.RecordCount > 0 Then
                            Email = Nz(rsD![Email], "")
                            ConSize = Nz(rsD![ConSize], "")
                            ConNr = Nz(rsD![ConNr], "")
                            Firma = Nz(rsD![Firma], "")
                            Uhrzeit = Nz(rsD![Uhrzeit], "")
                            Kundenref = Nz(rsD![Kundenref], "")
                            Fahrer = Nz(rsD![Fahrer], "")
                            Fahrer2 = Nz(rsD![Fahrer2], "")
                            HNummer = Replace(HNummer, " ", "")
                            HNummerD = Replace(Nz(HandyNR(Fahrer), ""), " ", "")
                            HNummerD2 = Replace(Nz(HandyNR(Fahrer2), ""), " ", "")
                                If Trim(HNummer) Like Trim(HNummerD) Or Trim(HNummer) Like Trim(HNummerD2) Then
                                    If Funktion = "C" Then
                                        rsD.Edit
                                        rsD![ConNr] = Daten
                                        rsD![Status_log] = Status_log
                                        Call mdl_Aviso.Aviso(tbl_Liste, Email, ConSize, Daten, Firma, Uhrzeit, Kundenref)
                                        rsD![AvisoS] = True
                                        rsD.Update
                                    ElseIf Funktion = "W" Then
                                        rsD.Edit
                                        rsD![Status] = "W"
                                        rsD![Siegelnummer] = Daten
                                        rsD![Status_logW] = Status_log
                                        rsD.Update
                                    ElseIf Funktion = "A" Then
                                        rsD.Edit
                                        rsD![Status] = "A"
                                        rsD![Status_logA] = Status_log
                                        rsD.Update
                                    Else
                                    DFName = "Fehler"
                                    End If
                                Else
                                DFName = "Fehler"
                                End If
                            Else
                            DFName = "Fehler"
                            End If
                            
                        Else
                        DFName = "Fehler"
                        End If
                    Else
                    DFName = "Fehler"
                    End If
                    If Not rsD Is Nothing Then
                    rsD.Close
                    Set rsD = Nothing
                    End If
               Else
               DFName = "Fehler"
               End If
          Else
          DFName = "Fehler"
          End If
     Else
     DFName = "Fehler"
     End If
    
Gelesen:
    Set DestFolder = Application.GetNamespace("MAPI").Folders("Status@ics-logistik.com").Folders("Posteingang").Folders(DFName)
    If DFName = "Fehler" Then
        Msg.UnRead = True
    Else
        Msg.UnRead = False
    End If
    If Update_OK = True Then Msg.Move DestFolder
    Set DestFolder = Nothing

Set Msg = myOlItems.FindNext
Loop

If Not db Is Nothing Then Set db = Nothing
If Not ws Is Nothing Then Set ws = Nothing

EHX:
Exit Sub

EH:
If Err.Number = 3218 Then
    Update_OK = False
    Resume Gelesen
End If

End Sub

The Loop is working greate It just like want it to be. If the update can´t be done it marks the SMS as read but leaves it in the Inbox so it can be processed when a other SMS comes in.

I also hate to use the GOTO but under time preasure i just use it for me to have a bether view of the code. But I also notices with more and more GOTO it gets very messy a realy bad habit i have to get rid of.

I tested the code with some SMS and it worked greate. Even if I insert 20 SMS at the same time it works fine I don´t thing that something like that can haben in real environment.

For me it is very importand that the code is Robust for Errors. If you have suggestions on that please tell me.

I have bad expirience with using SQL statements in Multyuser environment. The DB in witch the data is insered is used by 4-5 users continuously.

The reason for sperate Tables for each year is the number of records In one year we have about 10 000 and more. And the worst is that the users use all the time all data. The records are transpoprt orders so they need records for +2 months for Orders that are planed and -2 months to send invoices for done transports. I often suggest them a Date filter but thay don´t want it Reason for that is that they work in a split form on witch they have a greate viewe over all orders and they use the Table filter on the datashid very very often.

Thank you again for your help