I am trying to loop through a folder and open each word document one at a time in VBA. I had the code working, and then I added two more files to the folder. Now it won't open my first file (which I had opened previously. My code is as follows:
Sub readEmailsV2()
Dim oFSO As Object, oFolder As Object, oFile As Object
Dim i As Integer
Dim j As Integer
Dim pN As Integer
Dim sFileSmall As String, sFileYear As String, sFilePath As String
Dim wapp As Word.Application
Dim wdoc As Word.Document
Dim tabDest As Worksheet
Dim splitVals As Variant
Dim contentsVar As String
Dim jContent As String
Dim pageCount As Integer
Dim fpOpen As Variant
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' USER INPUT
sFileSmall = "C:\Users\rstrott\OneDrive - Research Triangle Institute\Desktop\VBApractice\Docket Index\filesToRead\"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Get variable with filenames from folder (Only contains word docs)
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.getfolder(sFileSmall)
Set tabDest = ThisWorkbook.Sheets("FileContents")
Set wapp = GetObject(, "Word.Application")
If wapp Is Nothing Then
Set wapp = CreateObject("Word.Application")
End If
tabDest.Cells.Clear
tabDest.Range("a1:a1") = "File Title"
tabDest.Range("b1:b1") = "From:"
tabDest.Range("c1:c1") = "To:"
tabDest.Range("d1:d1") = "cc:"
tabDest.Range("e1:e1") = "Date Sent:"
tabDest.Range("f1:f1") = "Subject:"
tabDest.Range("g1:g1") = "Body:"
tabDest.Range("h1:h1") = "Page Count:"
i = 2
For Each oFile In oFolder.Files
' Assign variables
sFilePath = sFileSmall & oFile.Name
wapp.Visible = True
fpOpen = oFile.Path
Set wdoc = wapp.Documents.Open(sFilePath) ' <---- ERROR HERE: Output is 'Nothing'
pN = ActiveDocument.Paragraphs.Count
pageCount = ActiveDocument.ActiveWindow.ActivePane.Pages.Count
' Put paragraph contents in cells
tabDest.Cells(i, 1) = oFile.Name
tabDest.Cells(i, 2) = wdoc.Paragraphs(2)
tabDest.Cells(i, 3) = wdoc.Paragraphs(8)
tabDest.Cells(i, 4) = wdoc.Paragraphs(11)
tabDest.Cells(i, 5) = wdoc.Paragraphs(5)
tabDest.Cells(i, 6) = wdoc.Paragraphs(14)
Dim item As Variant
For j = 15 To pN
jContent = wdoc.Paragraphs(j).Range.Text
If j = 15 And Len(jContent) > 2 Then
contentsVar = wdoc.Paragraphs(j).Range.Text
ElseIf Len(jContent) > 2 Then
contentsVar = contentsVar & Chr(10) & wdoc.Paragraphs(j).Range.Text
End If
Next j
tabDest.Cells(i, 7) = contentsVar
tabDest.Cells(i, 8) = pageCount
' Close Word Doc
wdoc.Close _
SaveChanges:=wdDoNotSaveChanges
i = i + 1
Next oFile
End Sub
I've tried lots of different things to get it to work again, and I ran out of ideas. Any help would be greatly appreciated.
Related
I have seen some code to do this, but for me it is not working. I am running Windows 7, and excel 2010 (from office 2010). My code:
Public Sub GetZipContents()
Dim oApp As Shell32.Shell
Set oApp = New Shell32.Shell
Dim strFile As String
Dim xFname
Dim xRow As Long
Dim newRow As Long
Dim rNew As Range
Dim fileNameInZip
Dim oFolder As Variant
Dim i As Integer
i = 1
xRow = 0
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Title = "Select the zip to get file names from"
fd.Filters.Clear
fd.Filters.Add "Zip Files", "*.zip"
fd.FilterIndex = 1
If fd.Show = -1 Then
strFile = fd.SelectedItems(1)
oFolder = oApp.Namespace(strFile).Items
Range("A" & i).Value = strFile
i = i + 1
For Each fileNameInZip In oFolder
Range("A" & i).Value = fileNameInZip
i = i + 1
Next
Set oApp = Nothing
End If
End Sub
I have also used fileNameInZip as a Variant, but the output is the same. Regardless of the zip file I chose, my output (text version attached, the screen shot is better but I can't attach images as this is my first post ... the first line is the name of the zip file, the next are the Items from the Namespace call) is always the same. I am at a loss because every site I have seen has similar code as the answer. Any ideas what is going on (the files within are generally pdfs, not &Open etc.)?
C:\Users\PGibson\Downloads\CW985786-T-00136.zip
&Open
Cu&t
&Copy
&Delete
P&roperties
Missing Set on the marked line...
Public Sub GetZipContents()
Dim oApp As Shell32.Shell
Set oApp = New Shell32.Shell
Dim strFile As String
Dim xFname
Dim xRow As Long
Dim newRow As Long
Dim rNew As Range
Dim fileNameInZip, fd
Dim oFolder As Variant
Dim i As Integer
i = 1
xRow = 0
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Title = "Select the zip to get file names from"
fd.Filters.Clear
fd.Filters.Add "Zip Files", "*.zip"
fd.FilterIndex = 1
If fd.Show = -1 Then
strFile = fd.SelectedItems(1)
Set oFolder = oApp.Namespace(strFile).Items '< Set!
Range("A" & i).Value = strFile
i = i + 1
For Each fileNameInZip In oFolder
Range("A" & i).Value = fileNameInZip
i = i + 1
Next
Set oApp = Nothing
End If
End Sub
I have hundreds of Word files (docx) which each have various headings, defined as Heading 1, Heading 2, Heading 3, etc. Each of these files has a table of contents which correspond to the headings.
I want to extract each heading from each of these files into an Excel workbook to build a database.
My first attempt was to extract the headings from a single Word document into an Excel workbook. I found code online to extract headings from Word to Outlook, and also separate code to extract headings from Word to a new Word file.
I haven't been able to adapt either of these.
How do I extract headings from a single Word file to Excel? I will then try to work out further steps.
Word to Outlook
Sub CopyHeadingsIntoOutlookMail()
Dim objOutlookApp, objMail As Object
Dim objMailDocument As Word.Document
Dim objMailRange As Word.Range
Dim varHeadings As Variant
Dim i As Long
Dim strText As String
Dim nLongDiff As Integer
'Create a new Outlook email
Set objOutlookApp = CreateObject("Outlook.Application")
Set objMail = objOutlookApp.CreateItem(olMailItem)
objMail.Display
Set objMailDocument = objMail.GetInspector.WordEditor
Set objMailRange = objMailDocument.Range(0, 0)
'Get the headings of the current Word document
varHeadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeHeading)
For i = LBound(varHeadings) To UBound(varHeadings)
strText = Trim(varHeadings(i))
'Get the heading level
nLongDiff = Len(RTrim$(CStr(varHeadings(i)))) - Len(Trim(CStr(varHeadings(i))))
nHeadingLevel = (nLongDiff / 2) + 1
'Insert the heading into the Outlook mail
With objMailRange
.InsertAfter strText & vbNewLine
.Style = "Heading " & nHeadingLevel
.Collapse wdCollapseEnd
End With
Next i
End Sub
Word to Word
Public Sub CreateOutline()
Dim docOutline As Word.Document
Dim docSource As Word.Document
Dim rng As Word.Range
Dim astrHeadings As Variant
Dim strText As String
Dim intLevel As Integer
Dim intItem As Integer
Set docSource = ActiveDocument
Set docOutline = Documents.Add
' Content returns only the
' main body of the document, not
' the headers and footer.
Set rng = docOutline.Content
astrHeadings = _
docSource.GetCrossReferenceItems(wdRefTypeHeading)
For intItem = LBound(astrHeadings) To UBound(astrHeadings)
' Get the text and the level.
strText = Trim$(astrHeadings(intItem))
intLevel = GetLevel(CStr(astrHeadings(intItem)))
' Add the text to the document.
rng.InsertAfter strText & vbNewLine
' Set the style of the selected range and
' then collapse the range for the next entry.
rng.Style = "Heading " & intLevel
rng.Collapse wdCollapseEnd
Next intItem
End Sub
Private Function GetLevel(strItem As String) As Integer
' Return the heading level of a header from the
' array returned by Word.
' The number of leading spaces indicates the
' outline level (2 spaces per level: H1 has
' 0 spaces, H2 has 2 spaces, H3 has 4 spaces.
Dim strTemp As String
Dim strOriginal As String
Dim intDiff As Integer
' Get rid of all trailing spaces.
strOriginal = RTrim$(strItem)
' Trim leading spaces, and then compare with
' the original.
strTemp = LTrim$(strOriginal)
' Subtract to find the number of
' leading spaces in the original string.
intDiff = Len(strOriginal) - Len(strTemp)
GetLevel = (intDiff / 2) + 1
End Function
Try the following Excel macro. When you run it, simply select the folder to process.
Sub GetTOCHeadings()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdDoc As Word.Document, wdRng As Word.Range, wdPara As Word.Paragraph
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet, i As Long, j As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application
Set WkSht = ActiveSheet
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
wdApp.WordBasic.DisableAutoMacros
wdApp.DisplayAlerts = wdAlertsNone
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
i = i + 1
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
j = 1: WkSht.Cells(i, j) = strFile
If .TablesOfContents.Count > 0 Then
With .TablesOfContents(1)
.IncludePageNumbers = False
.Update
Set wdRng = .Range
End With
With wdRng
.Fields(1).Unlink
For Each wdPara In .Paragraphs
j = j + 1
WkSht.Cells(i, j).Value = Replace(wdPara.Range.Text, vbTab, " ")
Next
End With
End If
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
I am trying to get the string after a word that gives me the needed data and all the phrase after every "-" into a new cell in excel except in RE: , where I omit "RE:" and only leave the TS... ticket ID.
This code works by selecting the emails in outlook and then running the macro for only that selected emails.
This is an example of a subject that has the
Example Subject
RE: TS001889493 - Translation failure - Inbound - ( VEXP/ HONCE/ Document Type 214 - Map AVE_NMHG_I_214_4010_XML_SAT - Error Conditional Relationship Error in N103 (0066) [ ref:_00D50c9MW._5000z1J3cG8:ref ]
Example of body
Dear Valued Trading Partner,
We received the attached 214 transactions from Sender ID: VEXP/ Receiver ID: HONCE that failed due to Conditional Relationship Error in the N1_03 (0066).
As per the map logic, If either N103 or N104 is present, then the other is required as they are in conditional relationship with each other.
But in the input file received, N104 value is missing hence the error.
Transaction Details: #4#
Attached
Please correct and resend the data.
Thank you,
Simon Huggs | Sass support - Basic
ref:_00D50c9MW._5000z1J3cG8:ref
What happens in the #num# is that it gets the sum of all these after making a match of the "TS" ticket ID.
This is the code I have up until now
Option Explicit
Sub WritingTicketNumberAndfailuresnew()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount, STicket, SticketNumber As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath, SSubject As String
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColS, strColB, sassupport, sMailDateReceived, SFrom As String
Dim Actions1, Actions2, Actions3, Actions4 As Boolean
Dim I, cnt, email_needed As Integer
' Get Excel set up
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open a specific workbook to input the data the path of the workbook under the windows user account
enviro = CStr(Environ("USERPROFILE"))
strPath = enviro & "\Documents\topthreeticket.xlsx"
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
' Add column names
xlSheet.Range("A1") = "Email Subject"
xlSheet.Range("B1") = "Map Name"
xlSheet.Range("C1") = "Case Number"
xlSheet.Range("D1") = "No. Of Failures"
xlSheet.Range("E1") = "Date"
xlSheet.Range("F1") = "Week Number"
sassupport = "sassuport#sass.com"
On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
'collect the fields for ticket number and failure count
strColS = olItem.Subject
strColB = olItem.Body
SFrom = olItem.SenderEmailAddress
sMailDateReceived = olItem.ReceivedTime
Dim sFailures, stmp1, stmp2, stmp3 As String
Dim RegX As Object, Mats As Object
Dim Found As Boolean
' Check the number of failures from body
sFailures = "0"
stmp1 = strColB
Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Global = True
.Pattern = "#\d+#"
Set Mats = .Execute(stmp1)
End With
If (RegX.Test(stmp1)) Then
stmp2 = Mats(0)
Found = True
stmp3 = Mid(stmp2, 2, Len(stmp2) - 2)
sFailures = stmp3
Else
With RegX
.Pattern = "#d\d+"
Set Mats = .Execute(stmp1)
End With
If (RegX.Test(stmp1)) Then
stmp2 = Mats(0)
Found = True
stmp3 = Mid(stmp2, 2, Len(stmp2) - 1)
sFailures = stmp3
End If
End If
Set Mats = Nothing
Set RegX = Nothing
Dim tmp As String
Dim RegX2 As Object, Mats1 As Object
tmp = strColS
Set RegX2 = CreateObject("VBScript.RegExp")
With RegX2
.Global = True
.Pattern = "TS00\d{7}"
Set Mats1 = .Execute(tmp)
End With
If (RegX2.Test(tmp)) Then
Set Mats1 = RegX2.Execute(tmp)
tmp = Mats1(0)
Else
With RegX2
.Pattern = "T.S\d{9}"
Set Mats1 = .Execute(tmp)
End With
If (RegX.Test(tmp)) Then
tmp = Mats1(0)
End If
End If
Set Mats1 = Nothing
Set RegX2 = Nothing
Dim tempticketnum, tmpdate As String
Dim ticketnumposition As Integer
'write them in the excel sheet
If SFrom = sassupport Then
xlSheet.Range("A" & rCount) = strColS
xlSheet.Range("B" & rCount) = tmp2
xlSheet.Range("C" & rCount) = tmp
xlSheet.Range("D" & rCount) = sFailures ' number of failures
xlSheet.Range("E" & rCount) = sMailDateReceived
rCount = rCount + 1
End If
Next
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlSheet = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
End Sub
You can use the SPLIT function in VBA, something like so
Sub x()
Dim s As String
Dim a() As String
s = "this-will-test-this-out"
a = Split(s, "-")
Range("a1").Resize(UBound(a) + 1, 1).Value = Application.Transpose(a)
End Sub
Hi I have written some vba code to loop through all emails in a folder , but I am struggling to find a way to look for a hyperlink. copy the hyperlink to the next empty row in column A. copy the text beneath the hyperlink to Column B. Then look for next hyperlink and repeat process. At present my code copies everything from the email and the hyperlinks are showing actual link not the visible wording.
Code
Option Explicit
Sub Get_Google_Alerts_From_Emails()
Sheet1.Select
ActiveSheet.Cells.NumberFormat = "#"
Application.DisplayAlerts = False
Dim oHTML As MSHTML.HTMLDocument: Set oHTML = New MSHTML.HTMLDocument
Dim ObjOutlook As Object
Dim MyNamespace As Object
Dim i As Integer
Dim j As Long
Dim abody() As String
Dim strSubject As String
Dim k
Dim x
Dim google_text As String
Dim strPattern As String
Dim strReplace As String
Dim strInput As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
Dim regEx As New RegExp
strPattern = "\s+"
strReplace = " "
x = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Set ObjOutlook = GetObject(, "Outlook.Application")
Set MyNamespace = ObjOutlook.GetNamespace("MAPI")
k = MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts").Items.Count
For i = k To 1 Step -1
On Error GoTo vend
strSubject = MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts").Items(i).Subject
If strSubject Like "*Google*" Then GoTo google:
GoTo notfound
google:
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts").Items(i).Body, vbCrLf)
For j = 0 To UBound(abody)
On Error GoTo error_google
If Len(abody(j)) > 1 Then
With regEx
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
.Global = False
.IgnoreCase = True
End With
If regEx.Test(abody(j)) Then
google_text = regEx.Replace(abody(j), strReplace)
End If
With objRegex
.Pattern = "[A-Z]+"
.Global = True
.IgnoreCase = False
If .Test(abody(j)) Then
x = x + 1
Sheet1.Range("A" & x) = google_text
Sheet1.Range("C" & x) = strSubject
Else
End If
End With
End If
error_google:
Next j
MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts_Complete")
GoTo comp
notfound:
comp:
Next i
vend:
Set ObjOutlook = Nothing
Set MyNamespace = Nothing
Application.DisplayAlerts = True
End Sub
At present my code copies everything from the email and the hyperlinks are showing actual link not the visible wording.
Here is a very basic example to achieve what you want. I am using Debug.Print to show the data. Feel free to amend it to move it to Excel. I am running this code from Excel.
Option Explicit
Const olMail As Integer = 43
Sub Sample()
Dim OutApp As Object
Dim MyNamespace As Object
Dim objFolder As Object
Dim olkMsg As Object
Dim objWordDocument As Object
Dim objWordApp As Object
Dim objHyperlinks As Object
Dim objHyperlink As Object
Set OutApp = CreateObject("Outlook.Application")
Set MyNamespace = OutApp.GetNamespace("MAPI")
'~~> Let the user select the folder
Set objFolder = MyNamespace.PickFolder
'~~> Loop through the emails in that folder
For Each olkMsg In objFolder.Items
'~~> Check if it is an email
If olkMsg.Class = olMail Then
'~~> Get the word inspector
Set objWordDocument = olkMsg.GetInspector.WordEditor
Set objWordApp = objWordDocument.Application
Set objHyperlinks = objWordDocument.Hyperlinks
If objHyperlinks.Count > 0 Then
For Each objHyperlink In objHyperlinks
Debug.Print objHyperlink.Address '<~~ Address
Debug.Print objHyperlink.TextToDisplay '<~~ Display text
Next
End If
End If
Next
End Sub
I have a working VBA script that pulls specific form fields from a specified PDF file into a spreadsheet. However I have several hundred PDFs that I need to do this for, so I'd like to loop through files in a directory and perform the same action.
Conveniently I have an old VBA script that loops through Word files in a directory and imports the content of each just how I'd like.
I hardly know VBA but I've adapted scripts in several language including VBA to meet my needs. I thought this would take 10 minutes but its taken several hours. Can somebody please look at my script below and tell me where I'm going wrong? I assume it has something to do with the Word and Acrobat libraries having different requirements, but even my loop isn't displaying the test message.
PS I have Acrobat Pro installed.
My Script (Non-Working)
Private Sub CommandButton1_Click()
Dim f As String: f = "C:\temp\ocopy"
Dim s As String: s = Dir(f & "*.pdf")
Dim AcroApp As Acrobat.CAcroApp
Dim theForm As Acrobat.CAcroPDDoc
Dim jso As Object
Dim text1, text2 As String
Dim col As Integer: col = 1
Do Until s = ""
Set AcroApp = CreateObject("AcroExch.App")
Set theForm = CreateObject("AcroExch.PDDoc")
theForm.Open (f & s)
Set jso = theForm.GetJSObject
text1 = jso.getField("Name of serviceRow1").Value
text2 = jso.getField("Who are the key contacts?").Value
MsgBox text1
MsgBox "text1"
Sheet1.Cells(col, 1).Value = text1
Sheet1.Cells(col, 2).Value = text2
col = col + 1: s = Dir
theForm.Close
AcroApp.Exit
Set AcroApp = Nothing
Set theForm = Nothing
Loop
End Sub
Word Script - Works at Looping and Importing
Sub fromWordDocsToMultiCols()
Dim f As String: f = "C:\temp\Test\"
Dim s As String: s = Dir(f & "*.docx")
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim col As Integer: col = 1
On Error GoTo errHandler
Do Until s = ""
Set wdDoc = wdApp.Documents.Open(f & s)
wdDoc.Range.Copy
Sheet1.Cells(1, col).Value = s
Sheet1.Cells(2, col).PasteSpecial xlPasteValues
wdDoc.Close False: col = col + 1: s = Dir
Loop
errHandler:
If Err.Number <> 0 Then MsgBox Err.Description
If Not wdApp Is Nothing Then wdApp.Quit False
End Sub
Acrobat Script - Works as Importing One-by-One
Private Sub CommandButton1_Click()
Dim AcroApp As Acrobat.CAcroApp
Dim theForm As Acrobat.CAcroPDDoc
Dim jso As Object
Dim text1, text2 As String
Set AcroApp = CreateObject("AcroExch.App")
Set theForm = CreateObject("AcroExch.PDDoc")
theForm.Open ("C:\temp\ocopy\Minerals asset management.pdf")
Set jso = theForm.GetJSObject
' get the information from the form fiels Text1 and Text2
text1 = jso.getField("Name of serviceRow1").Value
text2 = jso.getField("Who are the key contacts within the team for this service? Please provide one contact per region").Value
Sheet1.Cells(1, 1).Value = text1
Sheet1.Cells(1, 2).Value = text2
theForm.Close
AcroApp.Exit
Set AcroApp = Nothing
Set theForm = Nothing
End Sub
Many thanks in advance.