Reflex_ht
Registered User.
- Local time
- Today, 10:55
- Joined
- Sep 11, 2012
- Messages
- 64
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:
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
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:
Code:
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 SubMore 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
