If clause is breaking my Do While loop

[Maximus Tatius]

I have some code which looks for some Word files in a particular folder, opens each one in turn and populates a spreadsheet with some document properties (including the "Subject" field - which is the reason I need to open them all).

This works fine and I've tweaked my code so that the list of files (these are all single page document transmittal notes which I create when I send documents to our client) is displayed together with a hyperlink to a correspondingly numbered PDF file which is in the same folder (there's always one digitally signed PDF for every Word Doc in the folder).

The problem comes when I want to check in a sub-folder called "Acknowledgements" to see if there is a PDF file with the same file name and, if there is one, enter a "Y" in a column on my spreadsheet together with a hyperlink to the acknowledgement. If it doesn't find an acknowledgement I just want it to leave that column blank.

To try and achieve this I introduced an IF clause into my code to check for an acknowledgement but when I run it, it completes the first full cycle of the loop then stops. If I comment out the IF clause and just get it to put a "Y" in there, hyperlinked to a file (whether it exists or not) then the code loops all the way through to the end of my folder full of transmittal notes.

Can anyone tell me why it stops when I introduce the IF clause?

Here's my full code as it stands

Sub Wd_Doc_Props()
'
' from http://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-mso_other/capture-a-list-of-selected-file-properties/4e7dcf12-1ee1-4f20-8911-c70709dc4b45
'
Dim p As String, r As Long, xlWb As Excel.Workbook, xlWs As Excel.Worksheet
Dim wdApp As Word.Application, wrd As String, wdDoc As Word.Document
'

Module2.ClearSheet 'erases previous entries

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
    Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
'
Set xlWb = Application.ActiveWorkbook
Set xlWs = xlWb.Worksheets("Transmittals Sent")
'
xlWs.Cells(1, 1) = "Transmittal"
xlWs.Cells(1, 2) = "Original Date"
xlWs.Cells(1, 3) = "Ack?" 'Has the transmittal been acknowledged?
xlWs.Cells(1, 4) = "Description"
'
'r = xlWs.Cells(Rows.Count, "A").End(xlUp).Row + 1 'option to start filling in values on next blank row (append to list)
 r = 2 'start filling in values on row 2 (overwrites list if not cleared)
'
p = xlWb.Path & "\Transmittals"
'
wrd = Dir(p & "\*.*")
'
Do While wrd <> ""
'
    If Right(wrd, 4) = ".doc" Or Right(wrd, 5) = ".docx" Then
    '
        Set wdDoc = wdApp.Documents.Open(p & "\" & wrd)
        wdApp.Visible = False 'how to hide Word docs flashing up on the screen?
        '
        On Error Resume Next
        '
        'xlWs.Cells(r, 1) = Replace(wdDoc.Name, ".doc", ".pdf")
        xlWs.Cells(r, 1).Formula = "=HYPERLINK(""" & p & "\" & Replace(wdDoc.Name, ".doc", ".pdf") & """,""" & Replace(wdDoc.Name, ".doc", "") & """)"
        xlWs.Cells(r, 2) = wdDoc.BuiltinDocumentProperties("Creation Date").Value
        
'''''''''''''''START OF PROBLEM''''''''''''''        
If FileThere(p & "\Acknowledgements\" & Replace(wdDoc.Name, ".doc", ".pdf")) Then
            xlWs.Cells(r, 3).Formula = "=HYPERLINK(""" & p & "\Acknowledgements\" & Replace(wdDoc.Name, ".doc", ".pdf") & """,""" & "Y" & """)"
        Else
             xlWs.Cells(r, 3) = ""
         End If
'''''''''''''''END OF PROBLEM''''''''''''''

         xlWs.Cells(r, 4) = wdDoc.BuiltinDocumentProperties("Subject").Value 'NB - this value is also entered before the loop stops.

        '
        r = r + 1
        '
        wdApp.Documents.Close savechanges = False
    '
    End If
    '
    wrd = Dir()
'
Loop
'
wdApp.Quit
'

End Sub

Function FileThere(FileName As String) As Boolean

' from http://excel.tips.net/T002516_Determining_If_a_File_Exists.html

     FileThere = (Dir(FileName) > "")
End Function

 

[BQardi]

I think it's your FileThere function that gives you problems:

Function FileThere(FileName As String) As Boolean
FileThere = (Dir(FileName) <> "")
End Function[/CODE]

It should be different from "" NOT greater than ""

 

[BQardi]

Oh and by the way, be careful using "On Error Resume Next" (highlighted in red). If any error occurs after this statement, all errors are ignored:

Sub Wd_Doc_Props()
'
' from http://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-mso_other/capture-a-list-of-selected-file-properties/4e7dcf12-1ee1-4f20-8911-c70709dc4b45
'
Dim p As String, r As Long, xlWb As Excel.Workbook, xlWs As Excel.Worksheet
Dim wdApp As Word.Application, wrd As String, wdDoc As Word.Document
'
Module2.ClearSheet 'erases previous entries
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
    Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
'
Set xlWb = Application.ActiveWorkbook
Set xlWs = xlWb.Worksheets("Transmittals Sent")
'
xlWs.Cells(1, 1) = "Transmittal"
xlWs.Cells(1, 2) = "Original Date"
xlWs.Cells(1, 3) = "Ack?" 'Has the transmittal been acknowledged?
xlWs.Cells(1, 4) = "Description"
'
'r = xlWs.Cells(Rows.Count, "A").End(xlUp).Row + 1 'option to start filling in values on next blank row (append to list)
 r = 2 'start filling in values on row 2 (overwrites list if not cleared)
'
p = xlWb.Path & "\Transmittals"
'
wrd = Dir(p & "\*.*")
'
Do While wrd <> ""
'
    If Right(wrd, 4) = ".doc" Or Right(wrd, 5) = ".docx" Then
    '
        Set wdDoc = wdApp.Documents.Open(p & "\" & wrd)
        wdApp.Visible = False 'how to hide Word docs flashing up on the screen?
        '
        [COLOR=#ff0000]On Error Resume Next 'All errors after this line is ignored until you do a "On Error GoTo 0"[/COLOR]
        '
        'xlWs.Cells(r, 1) = Replace(wdDoc.Name, ".doc", ".pdf")
        xlWs.Cells(r, 1).Formula = "=HYPERLINK(""" & p & "\" & Replace(wdDoc.Name, ".doc", ".pdf") & """,""" & Replace(wdDoc.Name, ".doc", "") & """)"
        xlWs.Cells(r, 2) = wdDoc.BuiltinDocumentProperties("Creation Date").Value
        
'''''''''''''''START OF PROBLEM''''''''''''''        
If FileThere(p & "\Acknowledgements\" & Replace(wdDoc.Name, ".doc", ".pdf")) Then
            xlWs.Cells(r, 3).Formula = "=HYPERLINK(""" & p & "\Acknowledgements\" & Replace(wdDoc.Name, ".doc", ".pdf") & """,""" & "Y" & """)"
        Else
             xlWs.Cells(r, 3) = ""
         End If
'''''''''''''''END OF PROBLEM''''''''''''''
         xlWs.Cells(r, 4) = wdDoc.BuiltinDocumentProperties("Subject").Value 'NB - this value is also entered before the loop stops.
        '
        r = r + 1
        '
        wdApp.Documents.Close savechanges = False
    '
    End If
    '
    wrd = Dir()
'
Loop
'
wdApp.Quit
'
End Sub
Function FileThere(FileName As String) As Boolean
' from http://excel.tips.net/T002516_Determining_If_a_File_Exists.html
     FileThere = (Dir(FileName) > "")
End Function

 

[Maximus Tatius]

I think it's your FileThere function that gives you problems:

It should be different from "" NOT greater than ""

Thanks for that. It tried it but it then just kept looping on the first item.

I'm right out of time right now so I'll look at it a bit closer over the weekend.

 

[Maximus Tatius]

I got it working... I'll probably keep working on it and change a few things but here's my working code in case it's useful to anyone.

I simplified things by running a separate script to list all of the acknowledgements on another worksheet called "Acknowledgements" and then writing a regular worksheet formula into the third column to check if the file name shown in column A on a given row appears in the list of Acknowledgements. You can see that formula in blue below.

It's still not perfect because I need to open each document to read the Subject property, and also a custom property I created to store the real date of the document (not being able to rely on any of the automatically calculated dates in the document). In hindsight I would've used properties I could just read via the file system so my next task will be to write some code to run through a folder and copy all of the Subject properties to the Title property, and I'll start storing the dates in the Comments property.

We live and learn!

Sub Wd_Doc_Props()
'
' adapted from http://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-mso_other/capture-a-list-of-selected-file-properties/4e7dcf12-1ee1-4f20-8911-c70709dc4b45
'
' IMPORTANT - You must set a reference to the Microsoft Word Object Library before running this code

Dim p As String, r As Long, xlWb As Excel.Workbook, xlWs As Excel.Worksheet
Dim wdApp As Word.Application, wrd As String, wdDoc As Word.Document

Application.ScreenUpdating = False

Module2.ClearSheet 'erases previous entries

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
    Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
'
Set xlWb = Application.ActiveWorkbook
Set xlWs = xlWb.Worksheets("Transmittals Sent")
'
xlWs.Cells(1, 1) = "Transmittal"
xlWs.Cells(1, 2) = "Original Date"
xlWs.Cells(1, 3) = "Ack?" 'Has the transmittal been acknowledged?
xlWs.Cells(1, 4) = "Description"
'
r = 2 'start filling in values on row 2 (overwrite list)
'
p = xlWb.Path & "\Transmittals"
'
wrd = Dir(p & "\*.*")
'
Do While wrd <> ""
'
    If Right(wrd, 4) = ".doc" Or Right(wrd, 5) = ".docx" Then
    '
        Set wdDoc = wdApp.Documents.Open(p & "\" & wrd)
        wdApp.Visible = False 'how to hide Word docs flashing up on the screen?
        '
        'On Error Resume Next
        '
        xlWs.Cells(r, 1).Formula = "=HYPERLINK(""" & p & "\" & Replace(wdDoc.Name, ".doc", ".pdf") & """,""" & Replace(wdDoc.Name, ".doc", "") & """)"
        xlWs.Cells(r, 2) = wdDoc.CustomDocumentProperties("DateSent").Value
        
[COLOR=#0000ff][B]xlWs.Cells(r, 3).Formula = "=IF(COUNTIF(Acknowledgements!A:A," & xlWs.Cells(r, 1).Address & ")=0,""MISSING"",""YES"")"
[/B][/COLOR]        
        xlWs.Cells(r, 4) = wdDoc.BuiltinDocumentProperties("Subject").Value
        '
        r = r + 1
        '
        wdApp.Documents.Close savechanges = False
    '
    End If
    '
    wrd = Dir()
'
Loop
'
wdApp.Quit
'

Application.ScreenUpdating = True 'restore normal functioning to Excel

End Sub