Outlook project

Private WithEvents myOlItems  As Outlook.Items  'These are all the variables accessible from all the subs
Private sujet As String
Private bonjour As String
Private Body As String
Private L As Integer
Private t As Integer

Private Sub Application_Startup()  'Macro that will set the variables in order to use the current outlook address
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
      Set olApp = Outlook.Application
      Set objNS = olApp.GetNamespace("MAPI")
      Set myOlItems = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub myOlItems_ItemAdd(ByVal item As Object)  'Macro that will check when we get a new email

Stop

On Error GoTo ErrorHandler  'If an error occurs, go to the label ErrorHandler

  Dim Msg As Outlook.MailItem
  Dim myDestFolder As Outlook.Folder
  Dim myInbox As Outlook.Folder
  Dim myNameSpace As Outlook.NameSpace

  'MsgBox "New Email" 'To check if the macro is well running when we get a new email

  If TypeName(item) = "MailItem" Then
    Set myNameSpace = Application.GetNamespace("MAPI")  'Use the current session in outlook
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)  'Use the current inbox
    Set Msg = item
    Set myDestFolder = myInbox.Folders("Cycles Count")  'Set the destination folder to a Folder named Cycles Count in the Inbox folder

    sujet = Msg.Subject  'Save the subject of the new mail
    Body = Msg.Body      'Save the boody of the new mail

    t = 0                'set the variable t to 0, necessary to be reseted before every loop
    LoopThroughFiles (sujet) 'Call the macro LoopThroughFiles using the parameter suject which is the subject of the new mail

    If t = 1 Then  'If the file exist in the folder

    Add_Sheet_ClosedBook 'Call the macro Add_Sheet_CloseBook

    Msg.Move myDestFolder 'Call the macro myDestFolder

    End If

  End If

ProgramExit: 'define the label ProgramExit
  Exit Sub
ErrorHandler: 'define the label ErrorHandler
  MsgBox Err.Number & " - " & Err.Description 'Display the error in a message box
  Resume ProgramExit
End Sub

Private Sub Add_Sheet_ClosedBook() 'Macro that will modify the workbook
    Dim bk As Workbook
    Dim sh As Worksheet
    Dim shName As String
    Dim arr(1 To 12) As Variant

    Set bk = Workbooks.Open _
    ("H:\" & sujet & ".xlsm")  'Open the workbook named sujet.xlsm in this folder
                                                            'This path between the " " could be change

    L = bk.Worksheets.Count  'Count the number of sheets in the workbook

    Dim line As String

    For i = 1 To L - 2  'Loop through each line

    line = bk.Sheets(i + 1).name 'Save the name of the first line. The +1 is needed to exclude the main sheet from the loop
    cycle = ParseTextLinePair(Body, line & ": ") 'Call the function ParseTextLinePair for the body and the parameter "line: "


    Sheets(i + 1).Activate 'Activate the main sheet

    For j = 9 To 300 'Loop through the 300 first lines

    If Cells(j, 6) = "" Then  'Check the first empty cell in the column

    li = j - 9
    GoTo Label7  'Go out of the loop to the label suite
    End If

    Next

Label7:

Row = j - 1

     If Row < 9 Then GoTo Label3

    If Cells(Row, 9) = "ok" And Cells(Row, 8) = "" And Cells(9 + ok + 1, 2) <> "" Then
    Range("L15") = Cells(Row, 4)
    Range("L16") = Range("L16") + 1
    Cells(Row, 9) = ""
    Cells(Row, 7) = "Updated"
    End If

    If Cells(Row, 9) = "ok" And Cells(Row, 8) = "" Then
    Range("L15") = Cells(Row, 4)
    Cells(Row, 9) = ""
    Cells(Row, 7) = "Updated"
    End If

    If Cells(Row, 9) = "ok" And Cells(Row, 8) <> "" Then
    Range("L15") = Cells(Row, 4)
    Range("L16") = Range("L16") + 1
    Cells(Row, 9) = ""
    Cells(Row, 7) = "Updated"
    End If

    ok = Range("L16")

    Sheets(1).Activate

    For j = 5 To 300 'Loop through the 300 first lines

    If IsEmpty(Cells(j, 4 + 2 * (i - 1))) = True Then  'Check the first empty cell in the column

    Cells(j, 4 + 2 * (i - 1)) = cycle 'Copy the cycle value in this cell

    GoTo suite 'Go out of the loop to the label suite

    End If

    Next

suite:

    Sheets(i + 1).Activate

If IsEmpty(Cells(Row, 8)) = True Then

    Next_date1 = Cells(9 + ok, 2) + Range("L15") * 7 * (li - ok)
    Next_date1 = Mid(Next_date1, 1, 10)

    Next_date2 = Cells(Row, 2) + Cells(Row, 4) * 7
    Next_date2 = Mid(Next_date2, 1, 10)

    Else

    Next_date1 = Cells(9 + ok, 2) + Range("L15") * 7 * (li + 1 - ok)
    Next_date1 = Mid(Next_date1, 1, 10)

    Next_date2 = Cells(Row, 8) + Cells(Row, 4) * 7
    Next_date2 = Mid(Next_date2, 1, 10)

    End If

    Diff = DateDiff("d", Next_date2, Next_date1)

    Diff = Abs(Diff)

    If Diff >= 21 Then
    'MsgBox "Too big gap with the line" & i - 1 & ""
    arr(i) = line
    issue = 1
    End If

Label3:


Next

    If issue = 1 Then
    sendOutlookEmail arr
    End If

'=========================

    ActiveWorkbook.Close SaveChanges:=True 'Close the workbook and save the modifications

End Sub

Function ParseTextLinePair(strSource As String, strLabel As String) 'Macro that will check into a text for some specific characters and return what is just after it
    Dim intLocLabel As Integer
    Dim intLocCRLF As Integer
    Dim intLenLabel As Integer
    Dim strText As String

    ' locate the label in the source text
    intLocLabel = InStr(strSource, strLabel)
    intLenLabel = Len(strLabel)
        If intLocLabel > 0 Then
        intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
        If intLocCRLF > 0 Then
            intLocLabel = intLocLabel + intLenLabel
            strText = Mid(strSource, _
                            intLocLabel, _
                            intLocCRLF - intLocLabel)
        Else
            intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
        End If
    End If
    ParseTextLinePair = Trim(strText)
End Function

Sub LoopThroughFiles(nam)    'Macro that will check if there is a file in the folder with the name given by the parameter nam
    Dim MyObj As Object, MySource As Object, file As Variant
   file = Dir("C:\Users\pirenne\Desktop\Cycles\")  'Define the path of the folder, this one could be changed
   While (file <> "") 'While the file name is different from "", which means that there is a file
      If InStr(file, nam) > 0 Then 'If the file name contain the nam value
         'MsgBox "found "           'Message box to inform the user, could be deleted eventually
         t = 1                     'Set the variable t to 1 in order to not look after a workbook that doesn't exist in the folder
         GoTo fin                  'Go to label fin because there is only one file with this name in the folder
      End If
     file = Dir                    'For the next file
  Wend
fin:                               'Define the label fin
End Sub

Sub sendOutlookEmail(ligne() As Variant)
Dim oApp As Outlook.Application
Dim oMail As MailItem
Set oApp = CreateObject("Outlook.application")

text = "The services planned for the above lines have changed of more than 3 weeks. Please update the planning for these lines."

For i = 1 To 12
If ligne(i) <> 0 Then
text = text + "" & vbNewLine & " - " & ligne(i) & ""
End If
Next

Set oMail = oApp.CreateItem(olMailItem)
oMail.Body = text
oMail.Subject = "Services Plannification for " & sujet & ""
oMail.To = "thomas.pirenne@hotmail.com"
oMail.Send
Set oMail = Nothing
Set oApp = Nothing


End Sub