I'm interested in using VBA/VBscript to parse email header data. There are other answers on this site that address this to some degree, however not to the extent that I need.
I have a number of message headers that I've extracted from emails and have saved as text files, all in one folder (see image below). I would like to loop through the folder and parse the area identified in the box (perhaps save to excel or a table in Access?). The data identified in the box shows all the email "hops" (when an email is sent it is transferred between many computers - each transfer is a "hop"). This data is found in the "Received: from" section highlighted below:
*NOTE: Apologies, I'm not at a reputation as of yet to post images:
https://msdnshared.blob.core.windows.net/media/TNBlogsFS/prod.evol.blogs.technet.com/CommunityServer.Blogs.Components.WeblogFiles/00/00/00/76/18/3782.HSG-8-18-11-1.jpg
The result should look like this:
https://msdnshared.blob.core.windows.net/media/TNBlogsFS/prod.evol.blogs.technet.com/CommunityServer.Blogs.Components.WeblogFiles/00/00/00/76/18/7624.hsg-8-19-11-1.png
This is accomplished by parsing the FROM, BY, WITH, and DATESTAMP information from the above boxed area of the message header.
Kind of a tall order, I know. But I can't seem to find anything online. Any assistance (or direction to other solutions) would be appreciated.
Thank you.
Try this code and let me know if it works for you or not.
You just need to provide the path of the folder containing all your text files. The code would store the output in a file"1.txt" within the same folder. All the values in the file will be separated by double-pipe(||). Ofcourse, you can change it later as per your requirement.
Dim objFso, strFolderPath, objFolder, file, workFile, tempArr, strAllData
Dim strRecordData, arrRecordData
strFolderPath = "C:\Users\gu.singh\Desktop\Desktop\Gurman\2017\5. May\aa" 'REPLACE THIS PATH WITH YOUR FOLDER PATH
Set objFso = CreateObject("Scripting.FileSystemObject")
If objFso.FolderExists(strFolderPath) Then
Set objFolder = objFso.GetFolder(strFolderPath)
For Each file In objFolder.Files
tempArr = Split(file.Name,".")
If StrComp(tempArr(UBound(tempArr)),"txt",1)=0 Then
Set workFile = file.OpenAsTextStream(1)
strAllData = workFile.ReadAll()
workFile.Close
arrRecordData = Split(strAllData,"Received:")
For i=1 To UBound(arrRecordData) Step 1
intby = InStr(1,arrRecordData(i),"by ",1)
intfrom = InStr(1,arrRecordData(i),"from ",1)
intwith = InStr(1,arrRecordData(i),"with ",1)
intsemi = InStr(1,arrRecordData(i),";",1)
intdash = InStr(1,arrRecordData(i),"-",1)
strFROM = Trim(Mid(arrRecordData(i),intfrom+Len("from "), intby-intfrom-Len("from ")))
strBY = Trim(Mid(arrRecordData(i),intby+Len("by "), intwith-intby-Len("by ")))
strWITH = Trim(Mid(arrRecordData(i),intwith+Len("with "), intsemi-intwith-Len("with ")))
strDATE = Trim(Mid(arrRecordData(i),intsemi+Len(";"), intdash-intsemi-Len(";")))
strResult = strResult & strBY &"||"&strFROM&"||"&strWITH&"||"&strDATE&vbCrLf
Next
Set WorkFile = Nothing
End If
Next
Set objFolder = Nothing
End If
Set fyl = objFso.OpenTextFile(strFolderPath&"\1.txt",2,True)
fyl.Write strResult
fyl.Close
Set fyl=Nothing
Set objFso = Nothing
Related
It seems like I just cant add a copied Part two a productDoc. Its possible to paste it directly into the ProductDocument, but than I cant save it. What I need to do is:
Create ProductDoc
Create a ProductDoc in rootProductDoc
Copy Part from another Doc
Paste Part in ProductDoc from second step
Anyone an idea how to do that?
Im using CATIA V5-6 Release 2016, ServicePack 5 Build Number 26
There just dont seem any functions to select the ProductDoc from step 2.
I figured it out, thanks downvoters.
You cannot add a PartDocument itself to a Product, it needs to be a ProductDocument to which a Part is added (with AddNewComponent("Part","")).
Dim documents1 As Documents
Set documents1 = CATIA.Documents
Dim productDoc As ProductDocument
Set productDoc = documents1.Add("Product")
Dim rootProduct As Product
Set rootProduct = productDoc.Product
Dim childProduct As Product
Set childProduct = rootProduct.Products.AddNewComponent("Product", "")
Dim part1 As Product
Set part1 = childProduct.Products.AddNewComponent("Part", "")
Dim part2 As Product
Set part2 = childProduct.Products.AddNewComponent("Part", "")
MaxVR, thanks for coming back and posting the solution! It was really helpful for the product symmetry macro I'm working on. There's another way to insert parts into a CATProduct if the parts already exist.
'These three lines are variants
'products_variant_file_open represents the product that we want our part to be added to
'variant_array_file_open is where we store our file path
Dim products_variant_file_open
Set products_variant_file_open = current_rh_product.Products
Dim variant_array_file_open(0)
variant_array_file_open(0) = root_file_location & "\" & current_product.PartNumber & "_RH.CATPart"
'Below is the command that inserts the CATPart. The left thing to specify is the array that holds
'the file name and the right thing is the type of file to add
Here's some sample code that shows how I got my file path to insert parts from
'prod_doc.Path gets path of the product document and the stuff to the right becomes the folder name
root_file_location = prod_doc.Path & "\" & name_prod.Name & "_RH_Parts"
Dim fso As FileSystemObject
Set fso = New FileSystemObject
'Creates a folder in specified path with the specified name
fso.CreateFolder (root_file_location)
Then I used a function to loop through the folder and search for specific names
Function rh_folder_lookup(rh_part_file_name As String,
root_file_location_func As String)
'Default rh folder lookup to be false when it's false we can't find a matching file in our folder so we make a new rh part
rh_folder_lookup = False
'Set the file name to all the files in our folder
Dim fileName As Variant
fileName = Dir(root_file_location_func & "\") 'The slash at the ends makes the directory all the files in the folder instead of just that folder
'Loop through all files in a folder
While fileName <> ""
If fileName = rh_part_file_name & ".CATPart" Or fileName = rh_part_file_name Then
'MsgBox fileName & "!!!"
rh_folder_lookup = True
Exit Function
End If
fileName = Dir 'Set the fileName to the next file
Wend 'Wend means end when the condition is true
End Function
I have a little problem with VBScript. There is how it should work. It is a simply code that should go through all emails in particular folder, get particular email body and try to find regular expression. It works correctly on my computer but somehow the same code is not working on other laptop (my friend laptop). Most (not all of them) of emails body look very weird like on attached screen below:
I would like to add that we had the same email messages to test. What is also curious, after use script, it converts first email into these weird characters.
And this is how code looks:
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objMailbox = objNamespace.Folders(Main_mailbox)
Set objMainMailbox = objMailbox.Folders(Main_folder)
Set objFolder = objMainMailbox.Folders(Sub_folder)
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "<.+>"
Set colItems = objFolder.Items
NumberOfEmails = colItems.Count
WScript.Echo NumberOfEmails & " emails found"
For i = NumberOfEmails To 1 Step - 1
BodyMsg = colItems(i).Body
Lines = Split(BodyMsg, vbCrlf)
For j = 1 To UBound(Lines)
If InStr(1, Lines(j), "Reply-To:") Then
Set RegMatches = re.Execute(Lines(j))
For Each myMatch In RegMatches
OutputMatch = OutputMatch & " " & myMatch & ";"
OutputMatch = Replace(OutputMatch, "<", "", 1, 1)
OutputMatch = Replace(OutputMatch, ">", "", 1, 1)
EmailCount = EmailCount + 1
Next
End If
Next
Next
I am wondering if it is about encoding or something like that and if that problem is caused by system settings?
If you need some more information that I forgot mention about, please let me know.
That sure sounds like you are running into an NDR (Non-Delivery Report - represented by the ReportItem object) - ReportItem.Body returns gibberish when accessed though the Outlook Object Model. This has been a problem for a few versions of Outlook now.
You can either skip items like this by checking that you only get the MailItem object (Class property must be 43 (olMail)) or use Redemption (I am its author) - its RDOReportItem object does not have this problem.
I have a simple Access 2013 database that currently has one table, and one form for inputting data. I input data using the form, things like first name, last name, etc. I then have the database calling a function that takes these values, and places them on a word document in specific areas, (similar to mail merge, but mail merge doesn't suit my exact needs.) The function then converts a copy of that word document to a .pdf, and saves it in a location that is pre-defined.
I currently have the function tied to a button that is on the form. Everything works fine now, and I would like to break the soon-to-be large amount of code that will follow into modules; however, this is where I am having the issue. When I place this function in a module, it does not populate all of the form fields on the word document. It only populates one or two fields, not all of them. If I place the code back in a function that is on the main form, it works just fine.
I do not get any errors either way. The .pdf is created and stored exactly where it is supposed to be, but if the button calls the module, it doesn't populate all of the fields. If the button calls the function within the same form, it works like a champ. I will post a shortened version of the code below.
My initial thoughts are that perhaps I am not calling the module correctly, but at this point, I am lost. I have tried passing the values as 'Function Memo(LN, FN, srcFile) As String', labeling individually 'As String', but I can't seem to get it to work.
Function Memo(LN, FN, srcFile)
Dim appword As Object
Dim doc As Object
Dim Path As String
Dim pdfFileName As String
Dim folderName As String
Dim directory As String
Path = srcFile
folderName = LN & ", " & FN
directory = Application.CurrentProject.Path & "\" & folderName
pdfFileName = directory & "\" & folderName & " 2015 Memo" & ".pdf"
If Dir(directory, vbDirectory) = "" Then
MkDir (directory)
Else
End If
On Error Resume Next
Error.Clear
Set appword = GetObject(, "word.application")
If Err.Number <> 0 Then
Set appword = CreateObject("Word.Application")
appword.Visible = False
End If
Set doc = appword.Documents.Open(Path, , True)
With doc
.FormFields("TextFN1").Result = FN
.FormFields("TextMI1").Result = MI
.FormFields("TextLN11").Result = LN
.ExportAsFixedFormat pdfFileName, 17
appword.Visible = False
Set doc = appword.Documents.Close()
appword.Quit SaveChanges:=False
End With
Set doc = Nothing
Set appword = Nothing
End Function
Wow. Silly me. After some additional exploratory surgery on the code, I found my problem. The issue is that a few of my variables did not have unique names. Problem solved.
I am not very clued up with VBA and need some help with the following:
I want to create a txt file and save it in a specific location (overwriting the existing file with the same name).
The text file must countain the last word in the email subject, which will be an Account Number. For the purpose of this explanation I'm going to call the account number Variable1.
if the Email Subject = Account Recon - 10201314050019434586
then Variable1 = 10201314050019434586
The text file that must be created/replaced:
C:\Users\tenba1\Documents\QlikView\Account Recons\Recon_Acct.txt
The text in the file must be:
SET vAcct = 'Variable1';
So in this example the text in the file must be:
SET vAcct = '10201314050019434586';
The macro must look at the last word in the subject (i.e. everything after the last space) - an account number is not always 20 digits.
Thanks in advance
This should do the trick. It's a macro script which takes the Subject of the top opened email and writes the Accountnumber into Recon_Acct.txt. If there is no number, the text will be SET vAcct = ''. The File will be overwritten, every time you execute the script.
Sub writeSubjectToFile()
Const FILEPATH = "C:\Users\tenba1\Documents\QlikView\Account Recons\Recon_Acct.txt"
Dim objEmailItem As Object, strSubject
Dim strSubject As String
Dim strText As String
Set objEmailItem = Application.ActiveInspector.CurrentItem
strSubject = objEmailItem.subject
strText = Trim(Right(strSubject, Len(strSubject) - InStr(1, strSubject, "-")))
Open FILEPATH For Output As 1
Print #1, "SET vAcct = '" & strText & "';"
Close #1
End Sub
Trying to use Excel VBA to capture all the file attributes from files on disk, including extended attributes. Was able to get it to loop through the files and capture the basic attributes (that come from the file system):
File Path
File Name
File Size
Date Created
Date Last Accessed
Date Last Modified
File Type
Would also like to capture the extended properties that come from the file itself:
Author
Keywords
Comments
Last Author
Category
Subject
And other properties which are visible when right clicking on the file.
The goal is to create a detailed list of all the files on a file server.
You say loop .. so if you want to do this for a dir instead of the current document;
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace("c:\foo")
For Each sFile In oDir.Items
Debug.Print oDir.GetDetailsOf(sFile, XXX)
Next
Where XXX is an attribute column index, 9 for Author for example.
To list available indexes for your reference you can replace the for loop with;
for i = 0 To 40
debug.? i, oDir.GetDetailsOf(oDir.Items, i)
Next
Quickly for a single file/attribute:
Const PROP_COMPUTER As Long = 56
With CreateObject("Shell.Application").Namespace("C:\HOSTDIRECTORY")
MsgBox .GetDetailsOf(.Items.Item("FILE.NAME"), PROP_COMPUTER)
End With
You can get this with .BuiltInDocmementProperties.
For example:
Public Sub PrintDocumentProperties()
Dim oApp As New Excel.Application
Dim oWB As Workbook
Set oWB = ActiveWorkbook
Dim title As String
title = oWB.BuiltinDocumentProperties("Title")
Dim lastauthor As String
lastauthor = oWB.BuiltinDocumentProperties("Last Author")
Debug.Print title
Debug.Print lastauthor
End Sub
See this page for all the fields you can access with this: http://msdn.microsoft.com/en-us/library/bb220896.aspx
If you're trying to do this outside of the client (i.e. with Excel closed and running code from, say, a .NET program), you need to use DSOFile.dll.
'vb.net
'Extended file stributes
'visual basic .net sample
Dim sFile As Object
Dim oShell = CreateObject("Shell.Application")
Dim oDir = oShell.Namespace("c:\temp")
For i = 0 To 34
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(oDir, i) & vbCrLf
For Each sFile In oDir.Items
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(sFile, i) & vbCrLf
Next
TextBox1.Text = TextBox1.Text & vbCrLf
Next
I was finally able to get this to work for my needs.
The old voted up code does not run on windows 10 system (at least not mine). The referenced MS library link below provides current examples on how to make this work. My example uses them with late bindings.
https://learn.microsoft.com/en-us/windows/win32/shell/folder-getdetailsof.
The attribute codes were different on my computer and like someone mentioned above most return blank values even if they are not. I used a for loop to cycle through all of them and found out that Title and Subject can still be accessed which is more then enough for my purposes.
Private Sub MySubNamek()
Dim objShell As Object 'Shell
Dim objFolder As Object 'Folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("E:\MyFolder")
If (Not objFolder Is Nothing) Then
Dim objFolderItem As Object 'FolderItem
Set objFolderItem = objFolder.ParseName("Myfilename.txt")
For i = 0 To 288
szItem = objFolder.GetDetailsOf(objFolderItem, i)
Debug.Print i & " - " & szItem
Next
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
Set objShell = Nothing
End Sub
Lucky discovery
if objFolderItem is Nothing when you call
objFolder.GetDetailsOf(objFolderItem, i)
the string returned is the name of the property, rather than its (undefined) value
e.g. when i=3 it returns "Date modified"
Doing it for all 288 values of I makes it clear why most cause it to return blank for most filetypes
e.g i=175 is "Horizontal resolution"