convert excel workbook to pipe delimited csv file using vba

Hi guys,

The below code extracts outlook email contents to excel workbook but I want to save the workbook down in pipe delimited .txt file format.

Can anyone please amend the code accordingly ?

Sub Extract()
    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")
    xlobj.Visible = True
    xlobj.Workbooks.Add
    
    Dim objFS As New Scripting.FileSystemObject
    Dim objFile As Scripting.TextStream
    Dim FilePath As String
    'open the current folder
    Dim sFilePath As String
    Dim fileNumber As Integer
    'Set Heading

    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, "Contact Number", "###")
    delimtedMessage = Replace(delimtedMessage, "Address", "###")
    delimtedMessage = Replace(delimtedMessage, "Telephone Number", "###")
    delimtedMessage = Replace(delimtedMessage, "Email", "###")
    delimtedMessage = Replace(delimtedMessage, "Account number", "###")
    delimtedMessage = Replace(delimtedMessage, "Hobbies", "###")
    delimtedMessage = Replace(delimtedMessage, "DOB", "###")
    delimtedMessage = Replace(delimtedMessage, "University", "###")
    delimtedMessage = Replace(delimtedMessage, "Subjects", "###")
    delimtedMessage = Replace(delimtedMessage, "Score", "###")
    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)
    xlobj.Range("g" & I + 1).Value = messageArray(7)
    xlobj.Range("h" & I + 1).Value = messageArray(8)
    xlobj.Range("i" & I + 1).Value = messageArray(9)
    xlobj.Range("j" & I + 1).Value = messageArray(10)
    xlobj.Range("k" & I + 1).Value = messageArray(11)
    
    myPath = "C:\test\"
    myFileName = "a" & Format(Now, "ddmmyyyyhhmmss")
    xlobj.SaveAs FileName:=myPath & sFilePath & ".csv", FileFormat:=xlCSV, Local:=True
    Next
    End Sub

Hi,

I had to simulate the data, since you got your data from a file structure. Important parts of the code are highlighted in red.
Your code can be simplified by just replacing '###' with the 'Pipe Character'.

Try code like the following

Sub ExtractSimulation()
    
  Dim myNewWorkbook As Workbook
  Dim xlobj As Object
  Dim iRow As Long
  Dim delimtedMessage As String
    
  Dim sPath As String
  Dim sFileName As String
  Dim sPathAndFileNameCombination As String
    
    
  Set xlobj = CreateObject("excel.application")
  xlobj.Visible = True
  Set myNewWorkbook = xlobj.Workbooks.Add
  
  iRow = 0
  
  delimtedMessage = "abc###def###201-555-5555###03/27/1988###88###None"
  delimtedMessage = Replace(delimtedMessage, "###", "|")
  iRow = iRow + 1
  xlobj.Cells(iRow, "A").Value = delimtedMessage
    
  delimtedMessage = "def###def###201-555-5555###03/27/1988###88###None"
  delimtedMessage = Replace(delimtedMessage, "###", "|")
  iRow = iRow + 1
  xlobj.Cells(iRow, "A").Value = delimtedMessage
    
  sPath = "C:\test\"
  sPath = ThisWorkbook.Path & "\"    'DELETE THIS LINE - I don't write directly outside my Login
  sFileName = "a" & Format(Now, "ddmmyyyyhhmmss") & ".csv"
  sPathAndFileNameCombination = sPath & sFileName
  
  'Reference: https://docs.microsoft.com/en-us/office/vba/api/excel.workbook.saveas
  'Reference: https://docs.microsoft.com/en-us/office/vba/api/excel.xlfileformat
  myNewWorkbook.SaveAs Filename:=sPathAndFileNameCombination, FileFormat:=xlTextPrinter, Local:=True
  
  'Clear Object Pointers
  Set xlobj = Nothing
  Set myNewWorkbook = Nothing
    
End Sub

To prevent typos from ruining days and weeks of work 'Option Explicit' is NEEDED at the top of each code module. This prevents errors caused by missspellings and FORCES every variable to be DECLARED (e.g. Dim i as Integer). http://www.cpearson.com/excel/DeclaringVariables.aspx

Lewis