Bullracer2
05-04-2015, 10:03 PM
Hi, I have a vba code which grabs a bit of info from a heap of .htm documents and puts it into a spreadsheet. The code works well however I want to extend it to also include sub directories. I've had a play with incorporating a similar solution posted at http://stackoverflow.com/questions/16908344/vba-macro-replace-text-in-word-file-in-all-sub-folders but end up further away then where i started.
My code is as follows:
Sub GetHyperlinksHTML() Application.ScreenUpdating = False
Dim StrFolder As String, StrFile As String
Dim wdApp As Object, wdDoc As Object
Dim WkSht As Worksheet, LRow As Long, i As Long
StrFolder = GetFolder
If StrFolder = "" Then Exit Sub
Set WkSht = ActiveWorkbook.ActiveSheet
LRow = WkSht.Cells.SpecialCells(xlCellTypeLastCell).Row
Set wdApp = CreateObject("Word.Application")
If wdApp Is Nothing Then
MsgBox "Can't start Word.", vbExclamation
Exit Sub
End If
StrFile = Dir(StrFolder & "\*.htm", vbNormal)
While StrFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=StrFolder & "\" & StrFile, _
AddToRecentFiles:=False, Visible:=False, ReadOnly:=True)
With wdDoc
'Get the data for each defined Excel column
For i = 1 To .Hyperlinks.Count
LRow = LRow + 1
WkSht.Cells(LRow, 1).Value = .FullName
WkSht.Cells(LRow, 2).Value = .Hyperlinks(i).TextToDisplay
WkSht.Cells(LRow, 3).Value = .Hyperlinks(i).Address
Next
.Close SaveChanges:=False
End With
StrFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
Any help / points would be appreciated.
Thanks.
My code is as follows:
Sub GetHyperlinksHTML() Application.ScreenUpdating = False
Dim StrFolder As String, StrFile As String
Dim wdApp As Object, wdDoc As Object
Dim WkSht As Worksheet, LRow As Long, i As Long
StrFolder = GetFolder
If StrFolder = "" Then Exit Sub
Set WkSht = ActiveWorkbook.ActiveSheet
LRow = WkSht.Cells.SpecialCells(xlCellTypeLastCell).Row
Set wdApp = CreateObject("Word.Application")
If wdApp Is Nothing Then
MsgBox "Can't start Word.", vbExclamation
Exit Sub
End If
StrFile = Dir(StrFolder & "\*.htm", vbNormal)
While StrFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=StrFolder & "\" & StrFile, _
AddToRecentFiles:=False, Visible:=False, ReadOnly:=True)
With wdDoc
'Get the data for each defined Excel column
For i = 1 To .Hyperlinks.Count
LRow = LRow + 1
WkSht.Cells(LRow, 1).Value = .FullName
WkSht.Cells(LRow, 2).Value = .Hyperlinks(i).TextToDisplay
WkSht.Cells(LRow, 3).Value = .Hyperlinks(i).Address
Next
.Close SaveChanges:=False
End With
StrFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
Any help / points would be appreciated.
Thanks.