Consulting

Results 1 to 5 of 5

Thread: How to get a file path in a excel workbook using a index in the e-mail subject

  1. #1

    Question How to get a file path in a excel workbook using a index in the e-mail subject

    Srs,

    I am using the code below to save e-mails from my outlook to my hard drive but I would like to find a way to change the file path according to a index got from the subject of the e-mail. I have very little experience with VBA, and donīt know the commands, I would really appreciate any help to start my program or at least a tip if what I am searching for is possible or not.

    The index is a quote number. I would like to copy it from the subject of the e-mail and search its file path in a control excel worksheet where I have the file path of each quote number.

    So I have to challenges that I am still looking a wayout:

    1) All the quotes have the following format "PSARK"+7numbers. So I would like to correctly get the quote number anytime it is written "PSARK" in the e-mail subject.
    2) To get the file path I would use the quote number copied in stage one and search the file path in my control worksheet.


    Sorry for my poor english.

    Best Regards,
    Eduardo

    code:


    Sub SaveAsMsg(MyMail As MailItem)
    ' requires reference to Microsoft Scripting Runtime
    ' \Windows\System32\Scrrun.dll
    Dim fso As FileSystemObject
    Dim strSubject As String
    Dim strSaveName As String
    Dim blnOverwrite As Boolean
    Dim strFolderPath As String
    Dim looper As Integer
    Dim strID As String
    Dim olNS As Outlook.NameSpace
    Dim oMail As Outlook.MailItem

    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set oMail = olNS.GetItemFromID(strID)
    ' ### USER OPTIONS ###
    blnOverwrite = False ' False = don't overwrite, True = do overwrite
    strFolderPath = "C:\RAAN\Data\Emails" ' path to target folder
    strFolderPath = strFolderPath & Format(Now, " yyyymm") & "" ' Adds year/month
    subfolder

    If EnsureFolderExistence(strFolderPath) <> "PATH DOES NOT EXIST" Then
    strSubject = CleanFileName(oMail.Subject)
    strSaveName = Format(Now, " yyyymmdd") & "_" & strSubject & ".msg"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If blnOverwrite = False Then
    looper = 0
    Do While fso.FileExists(strFolderPath & strSaveName)
    looper = looper + 1
    strSaveName = Format(Now, " yyyymmdd") & "_" & strSubject & "_" &
    looper & ".msg"
    Loop
    Else
    If fso.FileExists(strFolderPath & strSaveName) Then
    fso.DeleteFile strFolderPath & strSaveName
    End If
    End If
    oMail.SaveAs strFolderPath & strSaveName, olMSG
    End If

    Set oMail = Nothing
    Set olNS = Nothing
    Set fso = Nothing
    End Sub

    Function EnsureFolderExistence(strPath) As String
    Dim fso As FileSystemObject
    On Error Resume Next

    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(strPath) Then
    fso.CreateFolder strPath
    If Err <> 0 Then
    EnsureFolderExistence = "PATH DOES NOT EXIST"
    End If
    End If

    Set fso = Nothing
    End Function

    Function CleanFileName(strText As String) As String
    Dim strStripChars As String
    Dim intLen As Integer
    Dim i As Integer
    strStripChars = "/\[]:=," & Chr(34)
    intLen = Len(strStripChars)
    strText = Trim(strText)
    For i = 1 To intLen
    strText = Replace(strText, Mid(strStripChars, i, 1), "")
    Next
    CleanFileName = strText
    End Function

  2. #2

    First attempt

    Would lines below enough and correctly to make item 1) work of my previous post? I am sorry to post twice in a row but I am trying to separete my attemps of my original question.

    CODE TO GET THE QUOTE NUMBER IN THE E-MAIL SUBJECT:

    Dim oMail As Outlook.MailItem
    Dim QuoteNumber As String
    Dim thesubject As String

    thesubject = oMail.Subject
    QuoteNumber = Mid(thesubject, InStr(1, thesubject, "PSARK") + 7,

  3. #3
    Item 1) solved. I need help how can I do item 2).

    Best Regards,

  4. #4
    I will put the "search intelligence" in the workbook using a formula in a cell, so my program would only need to write the value that I've got from the subject write on a specific cell of my control sheet and read the cell with the result of the corresponding path. Anyone could help me with following function/commands:

    1) Open a specific excel workboook in a specific folder.
    2) Write a value on a specific cell.
    3) Read the result of a specific cell.

  5. #5

    Close this TOPIC / PROBLEM SOLVED

    Close this topic! Program is finished.
    [VBA]Sub SaveAsMsgIn(MyMail As MailItem)

    Dim fso As FileSystemObject
    Dim strSubject As String
    Dim strSaveName As String
    Dim blnOverwrite As Boolean
    Dim strFolderPath As String
    Dim looper As Integer
    Dim strID As String
    Dim olNS As Outlook.NameSpace
    Dim oMail As Outlook.MailItem
    Dim QuoteNumber As String
    Dim thesubject As String
    Dim ExFilePath As String

    id=52[/url] for
    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set oMail = olNS.GetItemFromID(strID)
    thesubject = oMail.Subject
    QuoteNumber = Mid(thesubject, InStr(thesubject, "PSARK"), 12)
    Set objExcel = CreateObject("Excel.Application")
    objExcel.Workbooks.Open "C:\Temp\Book1.xlsx"
    objExcel.Cells(1, 1) = QuoteNumber
    ExFilePath = objExcel.Cells(2, 2)

    ' ### USER OPTIONS ###
    blnOverwrite = False ' False = don't overwrite, True = do overwrite
    strFolderPath = ExFilePath ' path to target folder

    If EnsureFolderExistence(strFolderPath) <> "PATH DOES NOT EXIST" Then
    strSubject = CleanFileName(oMail.Subject)
    strSaveName = Format(Now, " yymmdd") & "_" & strSubject & ".msg"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If blnOverwrite = False Then
    looper = 0
    Do While fso.FileExists(strFolderPath & strSaveName)
    looper = looper + 1
    strSaveName = Format(Now, " yymmdd") & "_" & strSubject & "_" & looper & ".msg"
    Loop
    Else
    If fso.FileExists(strFolderPath & strSaveName) Then
    fso.DeleteFile strFolderPath & strSaveName
    End If
    End If
    oMail.SaveAs strFolderPath & "\e-mail\entrada\" & strSaveName, olMSG
    End If

    Set oMail = Nothing
    Set olNS = Nothing
    Set fso = Nothing
    End Sub

    Sub SaveAsMsgOut(MyMail As MailItem)

    Dim fso As FileSystemObject
    Dim strSubject As String
    Dim strSaveName As String
    Dim blnOverwrite As Boolean
    Dim strFolderPath As String
    Dim looper As Integer
    Dim strID As String
    Dim olNS As Outlook.NameSpace
    Dim oMail As Outlook.MailItem
    Dim QuoteNumber As String
    Dim thesubject As String
    Dim ExFilePath As String

    id=52[/url] for
    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set oMail = olNS.GetItemFromID(strID)
    thesubject = oMail.Subject
    QuoteNumber = Mid(thesubject, InStr(thesubject, "PSARK"), 12)
    Set objExcel = CreateObject("Excel.Application")
    objExcel.Workbooks.Open "C:\Temp\Book1.xlsx"
    objExcel.Cells(1, 1) = QuoteNumber
    ExFilePath = objExcel.Cells(2, 2)

    ' ### USER OPTIONS ###
    blnOverwrite = False ' False = don't overwrite, True = do overwrite
    strFolderPath = ExFilePath ' path to target folder

    If EnsureFolderExistence(strFolderPath) <> "PATH DOES NOT EXIST" Then
    strSubject = CleanFileName(oMail.Subject)
    strSaveName = Format(Now, " yymmdd") & "_" & strSubject & ".msg"
    Set fso = CreateObject("Scripting.FileSystemObject")
    If blnOverwrite = False Then
    looper = 0
    Do While fso.FileExists(strFolderPath & strSaveName)
    looper = looper + 1
    strSaveName = Format(Now, " yymmdd") & "_" & strSubject & "_" & looper & ".msg"
    Loop
    Else
    If fso.FileExists(strFolderPath & strSaveName) Then
    fso.DeleteFile strFolderPath & strSaveName
    End If
    End If
    oMail.SaveAs strFolderPath & "\e-mail\saida\" & strSaveName, olMSG
    End If

    Set oMail = Nothing
    Set olNS = Nothing
    Set fso = Nothing
    End Sub


    Function EnsureFolderExistence(strPath) As String
    Dim fso As FileSystemObject
    On Error Resume Next

    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(strPath) Then
    fso.CreateFolder strPath
    If Err <> 0 Then
    EnsureFolderExistence = "PATH DOES NOT EXIST"
    End If
    End If

    Set fso = Nothing
    End Function

    Function CleanFileName(strText As String) As String
    Dim strStripChars As String
    Dim intLen As Integer
    Dim i As Integer
    strStripChars = "/\[]:=," & Chr(34)
    intLen = Len(strStripChars)
    strText = Trim(strText)
    For i = 1 To intLen
    strText = Replace(strText, Mid(strStripChars, i, 1), "")
    Next
    CleanFileName = strText
    End Function



    Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    End Sub

    [/VBA]

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •