locked
Export to Excel RRS feed

  • Question

  • Hi Graham,

    I was really benefited from your threads couple of months back. Now i have another project to work on. The situation is similar to what i had before with some changes. I have emails coming in tabular format both in English and French which i wanted to export to excel. Here is the email format:

    English Version-

    EMPLOYEE

    User ID

    Mary.Kiarie

    Name

    Mary Kiarie

    Group

    Retention

    REQUEST DETAILS

    Overtime

    0h10m

    Date

    June 29

    Banked/Paid?

    PAID

    Original Shift

    16:00 to 21:00

    OTHER

    Comments

    French Version-

    EMPLOYÉ

    Code d'utilisateur

    jouliana.tabbakh

    Nom

    Jouliana Tabbakh

    Groupe

    Rétention

    DÉTAILS DE LA DEMANDE

    Temps supplémentaire

    h10m

    Date

    29 juin

    Banqué/Payé?

    BANQUÉ

    Quart de travail original

    16:00 à 21:00

    AUTRE

    Commentaires

    So far i have the following code which is working but it is extracting heading as well. Here is the code...

        

    Sub FidoOT()
        On Error Resume Next
        Set myOlApp = Outlook.Application
        Set mynamespace = myOlApp.GetNamespace("mapi")

        'open the current folder

        Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
        Set xlobj = CreateObject("excel.application.14")
        xlobj.Visible = True
        xlobj.Workbooks.Add
        'Set Heading

        xlobj.Range("a" & 1).Value = "Emp Name"
        xlobj.Range("b" & 1).Value = "Group"
        xlobj.Range("c" & 1).Value = "Time"
        xlobj.Range("d" & 1).Value = "Date"
        xlobj.Range("e" & 1).Value = "Bank/OT Paid"
        xlobj.Range("f" & 1).Value = "Shift-Start/End Time"


        For i = 1 To myfolder.Items.Count
        Set myitem = myfolder.Items(i)
        msgtext = myitem.Body

        'search for specific text
        delimtedMessage = Replace(msgtext, "Name", "###")
        delimtedMessage = Replace(delimtedMessage, "Group", "###")
        delimtedMessage = Replace(delimtedMessage, "Overtime", "###")
        delimtedMessage = Replace(delimtedMessage, "Date", "###")
        delimtedMessage = Replace(delimtedMessage, "Banked/Paid?", "###")
        delimtedMessage = Replace(delimtedMessage, "Original Shift", "###")
        messageArray = Split(delimtedMessage, "###")

        'write to excel
        xlobj.Range("a" & i + 1).Value = messageArray(1)
        xlobj.Range("b" & i + 1).Value = messageArray(2)
        xlobj.Range("c" & i + 1).Value = messageArray(3)
        xlobj.Range("d" & i + 1).Value = messageArray(4)
        xlobj.Range("e" & i + 1).Value = messageArray(5)
        xlobj.Range("f" & i + 1).Value = messageArray(6)

        Next
        End Sub

    Here is my output

    Emp Name Group Time Date Bank/OT Paid Shift-Start/End Time
      Mohammad Qasim Ahmed   Retention REQUEST DETAILS   0h8m   June 29   BANKED   17:00 to 22:00 OTHER Comments
      Jessie Xing Jia (M)   Chinese team REQUEST DETAILS   0h16m   June 29   BANKED   14:00 to 22:00 OTHER Comments WF-7789904958-CTN

    e Équipe chinoise DÉTAILS DE LA DEMANDE Temps supplémentaire h11m

      29 juin Banqué/Payé? BANQUÉ Quart de travail original 14:00 à 22:00 AUTRE Commentaires

    If you see this code is extracting only the english version and not french. Also, is it possible to change time in hh:mm:ss format before exporting and also the Date in YY:MM:DD. I also wanted to split shift start and end time in different cells.

    Any help will be highly appreciated. Please let me know if i have not made myself clear in any stage. Thanks a lot in advance as you have always been brilliant.

    Puneet Soni



    Tuesday, June 30, 2015 8:23 PM

All replies

  • I think something like this should get you going.

    Code to Loop through all unread emails in "Inbox" Folder of outlook and import the details to Excel
    
    
    Sub Scan_my_outlook_inbox()
    'TOOLS ->Refrence -> microsoft outlook
    'declare outlook objects
    Dim olapp As Outlook.Application
    Dim olappns As Outlook.Namespace
    Dim oinbox As Outlook.Folder
    Dim oitem As Outlook.MailItem
    Dim myItems As Outlook.Items
    Dim i As Long
    i = 2
    'set outlook objects
    Set olapp = New Outlook.Application
    Set olappns = olapp.GetNamespace("MAPI")
    ' it will scan inbox folder only
    Set oinbox = olappns.GetDefaultFolder(olFolderInbox)
    
    ' check if any unread email in inbox
        If oinbox.Items.Restrict("[UnRead] = True").Count = 0 Then
            MsgBox "NO Unread Email In Inbox"
            Exit Sub
        End If
    
    ' sort emails on recieved basis
    Set myItems = oinbox.Items
    myItems.Sort "[Received]", True
    
    'loop through all unread emails
    
        For Each oitem In myItems.Restrict("[UnRead] = True")
            Sheets("Inbox Scan").Cells(i, 1).Value = oitem.SenderName
            Sheets("Inbox Scan").Cells(i, 2).Value = oitem.SenderEmailAddress
            Sheets("Inbox Scan").Cells(i, 3).Value = oitem.Subject
            Sheets("Inbox Scan").Cells(i, 4).Value = oitem.Body
            Sheets("Inbox Scan").Cells(i, 5).Value = oitem.ReceivedTime
            i = i + 1
        Next
    End Sub
    
    
    Code to Loop through all unread emails in any folder created by user  of outlook and import the details to Excel . 
    For Example i have taken folder "My Gmail" in below code.
    
    
    Sub Scan_my_outlook_folder()
    
    
    
    'TOOLS ->Refrence -> microsoft outlook
    
    'declare outlook objects
    
    
    
    Dim olapp As Outlook.Application
    
    Dim olappns As Outlook.Namespace
    
    Dim oinbox As Outlook.Folder
    
    Dim oitem As Outlook.MailItem
    
    Dim myItems As Outlook.Items
    
    Dim i As Long
    
    i = 2
    
    'set outlook objects
    
    Set olapp = New Outlook.Application
    
    Set olappns = olapp.GetNamespace("MAPI")
    
    Set oinbox = olappns.GetDefaultFolder(olFolderInbox)
    
    ' folder to scan
    
    Set oinbox = oinbox.Folders("My Gmail")
    
    
    
    
    
    ' check if any unread email in folder name  " my gmail "
    
        If oinbox.Items.Restrict("[UnRead] = True").Count = 0 Then
    
            MsgBox "NO Unread Email In Inbox"
    
            Exit Sub
    
        End If
    
    
    
    ' sort emails on recieved basis
    
    Set myItems = oinbox.Items
    
    myItems.Sort "[Received]", True
    
    
    
    'loop through all unread emails
    
    
    
        For Each oitem In myItems.Restrict("[UnRead] = True")
    
            Sheets("Specific Folder").Cells(i, 1).Value = oitem.SenderName
    
            Sheets("Specific Folder").Cells(i, 2).Value = oitem.SenderEmailAddress
    
            Sheets("Specific Folder").Cells(i, 3).Value = oitem.Subject
    
            'Sheets("Specific Folder").Cells(i, 4).Value = oitem.Body
    
            Sheets("Specific Folder").Cells(i, 5).Value = oitem.ReceivedTime
    
            i = i + 1
    
        Next
    
    
    
    End Sub
    
    
    Code to Loop through all unread emails in all folders in outlook and import the details to Excel .
    
    
    Dim oitem As Outlook.MailItem
    
    Dim i As Long
    
    Sub all_folder_scan()
    
    'Tools Reference Microsoft Outlook
    
    Dim olapp As Outlook.Application
    
    Dim olappns As Outlook.Namespace
    
    Dim oinbox As Outlook.Folder
    
    Dim oFolder As Outlook.MAPIFolder
    
    i = 2
    
    'tools->refrence->microsoft outlook
    
    Set olapp = New Outlook.Application
    
    Set olappns = olapp.GetNamespace("MAPI")
    
    ' set inbox folder
    
    Set oinbox = olappns.GetDefaultFolder(olFolderInbox)
    
        For Each oitem In oinbox.Items.Restrict("[UnRead] = True")
    
            Sheets("All Folders Scan").Cells(i, 5).Value = oitem.Subject
    
            Sheets("All Folders Scan").Cells(i, 4).Value = oitem.SenderEmailAddress
    
            Sheets("All Folders Scan").Cells(i, 3).Value = oitem.SenderName
    
            Sheets("All Folders Scan").Cells(i, 6).Value = oitem.Body
    
            Sheets("All Folders Scan").Cells(i, 7).Value = oitem.ReceivedTime
    
            Sheets("All Folders Scan").Cells(i, 2).Value = oinbox.Name
    
            Sheets("All Folders Scan").Cells(i, 1).Value = oinbox.FolderPath
    
            i = i + 1
    
        Next
    
        For Each oFolder In oinbox.Folders
    
            Call subfolders_go(oFolder)
    
        Next
    
    End Sub
    
    Private Sub subfolders_go(oParent As Outlook.Folder)
    
    Dim oFolder1 As Outlook.MAPIFolder
    
        For Each oitem In oParent.Items.Restrict("[UnRead] = True")
    
            Sheets("All Folders Scan").Cells(i, 5).Value = oitem.Subject
    
            Sheets("All Folders Scan").Cells(i, 4).Value = oitem.SenderEmailAddress
    
            Sheets("All Folders Scan").Cells(i, 3).Value = oitem.SenderName
    
            Sheets("All Folders Scan").Cells(i, 6).Value = oitem.Body
    
            Sheets("All Folders Scan").Cells(i, 7).Value = oitem.ReceivedTime
    
            Sheets("All Folders Scan").Cells(i, 2).Value = oParent.Name
    
            Sheets("All Folders Scan").Cells(i, 1).Value = oParent.FolderPath
    
            i = i + 1
    
        Next
    
        If (oParent.Folders.Count > 0) Then
    
            For Each oFolder1 In oParent.Folders
    
                Call subfolders_go(oFolder1)
    
            Next
    
        End If
    
    End Sub
    
    


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Thursday, July 2, 2015 3:18 PM
  • Or, perhaps this.

    Public Sub DisplayOutlookContactNames()
      Dim Outlook As Outlook.Application
      Dim NameSpace As Outlook.NameSpace
      Dim AddressList As AddressList
      Dim Entry As AddressEntry
      Dim exUser As Outlook.ExchangeUser
      Dim I As Long
      
      On Error Resume Next 'GoTo Finally
    
      
      Set Outlook = New Outlook.Application
      Set NameSpace = Outlook.GetNamespace("MAPI")
      Set AddressList = NameSpace.AddressLists("All Users")
      
      For Each Entry In AddressList.AddressEntries
        If Entry.AddressEntryUserType = olExchangeUserAddressEntry Then
          Set exUser = Entry.GetExchangeUser
            I = I + 1
            Cells(I, 1).Value = exUser.Alias 'adjust properties based on what your wanting to see.
            Cells(I, 2).Value = exUser.Name 'since you've added the reference vba's intellisense will list the menbers of exUser.
            Cells(I, 3).Value = exUser.Address
        End If
      Next
    Exit Sub
    
    Finally:
    If Err.Number <> 0 Then Debug.Print Err.Description
    Outlook.Quit
    Set Outlook = Nothing
    
    End Sub
    
    


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Thursday, July 2, 2015 3:20 PM
  • Hey ryguy72

    I think you posted the above solution in wrong path. This is not what i am looking for.

    Puneet

    Thursday, July 2, 2015 5:44 PM
  • The following will work whether your messages are in English or French. If you don't know how this works, refer to my web site - http://www.gmayor.com/extract_data_from_email.htm

    Option Explicit
    
    Sub FidoOT()
    Dim olFolder As Outlook.Folder
    Dim olItem As Outlook.MailItem
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim sText As String
    Dim vText As Variant
    Dim sAddr As String
    Dim i As Long, rCount As Long
    
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
        End If
        On Error GoTo 0
     
        Set olFolder = ActiveExplorer.CurrentFolder
        xlApp.Visible = True
        Set xlWB = xlApp.Workbooks.Add
        Set xlSheet = xlWB.sheets(1)
    
        With xlSheet
            .Range("a" & 1).Value = "Emp Name"
            .Range("b" & 1).Value = "Group"
            .Range("c" & 1).Value = "Time"
            .Range("d" & 1).Value = "Date"
            .Range("e" & 1).Value = "Bank/OT Paid"
            .Range("f" & 1).Value = "Shift-Start/End Time"
        End With
    
        For Each olItem In olFolder.Items
            rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1
            sText = olItem.Body
            sText = Replace(sText, Chr(160), Chr(32))
            vText = Split(sText, Chr(13))
    
    
            For i = 0 To UBound(vText)
                If InStr(1, vText(i), "Name") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("A" & rCount) = Trim(sAddr)
                End If
                If InStr(1, vText(i), "Nom") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("A" & rCount) = Trim(sAddr)
                End If
    
                If InStr(1, vText(i), "Group") > 0 And InStr(1, vText(i), "Groupe") = 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("B" & rCount) = Trim(sAddr)
                End If
                If InStr(1, vText(i), "Groupe") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("B" & rCount) = Trim(sAddr)
                End If
    
                If InStr(1, vText(i), "Overtime") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("C" & rCount) = Trim(sAddr)
                End If
                If InStr(1, vText(i), "Temps supplémentaire") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("C" & rCount) = Trim(sAddr)
                End If
    
                If InStr(1, vText(i), "Date") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("D" & rCount) = Trim(sAddr)
                End If
    
                If InStr(1, vText(i), "Banked/Paid?") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("E" & rCount) = Trim(sAddr)
                End If
                If InStr(1, vText(i), "Banqué/Payé?") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("E" & rCount) = Trim(sAddr)
                End If
    
                If InStr(1, vText(i), "Original Shift") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("F" & rCount) = Trim(sAddr)
                End If
                If InStr(1, vText(i), "Quart de travail original") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("F" & rCount) = Trim(sAddr)
                End If
    
            Next i
        Next olItem
    lbl_Exit:
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
        Set olItem = Nothing
        Exit Sub
    End Sub
    
    



    Graham Mayor - Word MVP
    www.gmayor.com


    Friday, July 3, 2015 5:29 AM
  • Good Day Graham,

    Thank you so very much for the wonderful code and help. You have always been a great help for people like us who are newbie to VBA. God Bless you.

    I have modified the code to suite my needs and it is working perfectly fine. Here is the output as needed:

    Employee Name Group Overtime Date Banked/Paid Original Shift
    Mohammad Qasim Ahmed  Retention 0h8m 06/29/2015 BANKED 17:00 to 22:00 
    Jessie Xing Jia (M)  Chinese team 0h16m 06/29/2015 BANKED 14:00 to 22:00 
    Wen Yang  Équipe chinoise h11m 29 juin BANQUÉ 14:00 à 22:00
    Wing Shan Chung  Chinese team 0h12m 06/29/2015 BANKED 14:00 to  22:00 
    Mary Kiarie  Retention 0h10m 06/29/2015 PAID 16:00 to 21:00 
    Jouliana Tabbakh  Rétention h10m 29 juin BANQUÉ 16:00 à 21:00
    Jessie Xing Jia (M)  Chinese team 0h19m 07/01/2015 BANKED 14:00 to 22:00 
    Melissa Reimer  Retention h20m 07/01/2015 BANKED 13:00 to 21:00 
    Shuvoraz Dey  Retention 0h12m 07/01/2015 PAID 14:00 to 22:00 
    Hamza Alami  E-Solutions 0h31m 1 juillet PAYÉ 11:00 à 21:30
    Karim Khaoulani  EOS 0h22m 1 juillet BANQUÉ 13:00 à 21:00
    Brunia Doiron  Rétention h16m 1 juillet PAYÉ 13:00 à 21:00
    Maxime Alfred-Callimaci  EOS 0h17m 1 juillet BANQUÉ 11:30 à 19:30

    I have two problems to solve now.

    1. How can i format the cells with Overtime to hh:mm (as you see it is 0h22 and so on right now). I tried looking up for that but to no use.

    2. How can i format the cells with Date to make it standard as English. Right now there are some with French version. I tried the text function 

    =TEXT(E1,"[$-409]mmmm, yyyy")

    but this one is returning 01/00/1900 (not converting the French date.

    I wanted to use both macros in Excel sheets. With the exporting of data from outlook i am good.

    Thanks again in advance for all your help.

    Puneet

    Friday, July 3, 2015 9:13 PM
  • The macro runs from Outlook not Excel.

    I am no expert on Excel formatting, but I don't think you can have French and English in the same worksheet and expect Excel to be able to sort it out. I would therefore recommend doing the conversions in the Outlook macro before it gets to Excel. The following should do the job, translating everything to its English form.

    Ihave not translated 'Chinese Team' from the French, but you can see from the code how it is done.

    Sub FidoOT()
    Dim olFolder As Outlook.Folder
    Dim olItem As Outlook.MailItem
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim sText As String
    Dim vText As Variant
    Dim vMonthEnglish As Variant
    Dim vMonthFrench As Variant
    Dim vDate As Variant
    Dim sAddr As String
    Dim i As Long, j As Long, rCount As Long
    Const strMonthEnglish As String = "January|February|March|April|May|June|July|August|September|October|November|December"
    Const strMonthFrench As String = "janvier|février|mars|avril|mai|juin|juillet|août|septembre|octobre|novembre|décembre"
    
        vMonthEnglish = Split(strMonthEnglish, "|")
        vMonthFrench = Split(strMonthFrench, "|")
    
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
        End If
        On Error GoTo 0
    
        Set olFolder = ActiveExplorer.CurrentFolder
        xlApp.Visible = True
        Set xlWB = xlApp.Workbooks.Add
        Set xlSheet = xlWB.sheets(1)
    
        With xlSheet
            .Range("a" & 1).Value = "Emp Name"
            .Range("b" & 1).Value = "Group"
            .Range("c" & 1).Value = "Time"
            .Range("d" & 1).Value = "Date"
            .Range("e" & 1).Value = "Bank/OT Paid"
            .Range("f" & 1).Value = "Shift-Start/End Time"
        End With
    
        For Each olItem In olFolder.Items
            rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1
            sText = olItem.Body
            sText = Replace(sText, Chr(160), Chr(32))
            vText = Split(sText, Chr(13))
    
    
            For i = 0 To UBound(vText)
                If InStr(1, vText(i), "Name") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("A" & rCount) = Trim(sAddr)
                End If
                If InStr(1, vText(i), "Nom") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("A" & rCount) = Trim(sAddr)
                End If
    
                If InStr(1, vText(i), "Group") > 0 And InStr(1, vText(i), "Groupe") = 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("B" & rCount) = Trim(sAddr)
                End If
                If InStr(1, vText(i), "Groupe") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    sAddr = Trim(sAddr)
                    sAddr = Replace(sAddr, "Rétention", "Retention")
                    xlSheet.Range("B" & rCount) = sAddr
                End If
    
                If InStr(1, vText(i), "Overtime") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    sAddr = Trim(sAddr)
                    If Left(sAddr, 1) = "h" Or Left(sAddr, 1) = "H" Then
                        sAddr = "0" & sAddr
                    End If
                    sAddr = Replace(sAddr, "h", ":")
                    sAddr = Replace(sAddr, "H", ":")
                    sAddr = Replace(sAddr, "m", ":00")
                    sAddr = Replace(sAddr, "M", ":00")
                    xlSheet.Range("C" & rCount) = sAddr
                End If
                If InStr(1, vText(i), "Temps supplémentaire") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    sAddr = Trim(sAddr)
                    If Left(sAddr, 1) = "h" Or Left(sAddr, 1) = "H" Then
                        sAddr = "0" & sAddr
                    End If
                    sAddr = Replace(sAddr, "h", ":")
                    sAddr = Replace(sAddr, "H", ":")
                    sAddr = Replace(sAddr, "m", ":00")
                    sAddr = Replace(sAddr, "M", ":00")
                    xlSheet.Range("C" & rCount) = sAddr
                End If
    
                If InStr(1, vText(i), "Date") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    For j = LBound(vMonthFrench) To UBound(vMonthFrench)
                        sAddr = Replace(sAddr, vMonthFrench(j), vMonthEnglish(j))
                    Next j
                    sAddr = Trim(sAddr)
                    vDate = Split(sAddr, Chr(32))
                    If IsNumeric(vDate(0)) Then
                        sAddr = vDate(1) & Chr(32) & vDate(0)
                    End If
                    xlSheet.Range("D" & rCount) = sAddr
                End If
    
                If InStr(1, vText(i), "Banked/Paid?") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("E" & rCount) = Trim(sAddr)
                End If
                If InStr(1, vText(i), "Banqué/Payé?") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    sAddr = Trim(sAddr)
                    sAddr = Replace(sAddr, "BANQUÉ", "PAID")
                    xlSheet.Range("E" & rCount) = sAddr
                End If
    
                If InStr(1, vText(i), "Original Shift") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    xlSheet.Range("F" & rCount) = Trim(sAddr)
                End If
                If InStr(1, vText(i), "Quart de travail original") > 0 Then
                    sAddr = Replace(vText(i + 2), Chr(10), "")
                    sAddr = Trim(sAddr)
                    sAddr = Replace(sAddr, "à", "to")
                    xlSheet.Range("F" & rCount) = sAddr
                End If
    
            Next i
        Next olItem
    lbl_Exit:
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
        Set olItem = Nothing
        Exit Sub
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com




    Saturday, July 4, 2015 12:09 PM