Batch renaming documents in VBA by first line, how to skip non-text?

Question

I have a folder full of Word Documents which has recently been "undeleted", while the contents of these files are viewable all metadata has been lost (Most importantly, original file names). I have found a VBA script that will run through a folder and rename any .doc files with the first line of its content.

The scripts works just as expected with documents that contain only text, although many of the files I need renamed are headed with an image. When the script gets to these files it ends and only the files up to that point are renamed.

I have very limited programming knownledge and know next to nothing about VBA but I imagine that I could skip the image with an if|else type statement and use the next line of text as the file name. My problem is I have no idea on how to accomplish this. Also, a method of removing any spaces which appear before the first line of text would be very helpful but is much less important.

The script I am currently working with is as follows:

Public Sub BatchReNameFiles()

Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim NewName As String
Dim OldName As String
Dim oRng As Range
Dim i As Integer
Dim j As Integer

'Specify folder where files are located
PathToUse = "C:\Test\"
'Count files in folder
OldName = Dir$(PathToUse & "*.doc")
While OldName <> ""
i = i + 1
OldName = Dir$()
Wend
'Rename files
j = 0
myFile = Dir$(PathToUse & "*.doc")
Do While myFile <> "" And j < i
j = j + 1
Set myDoc = Documents.Open(FileName:=PathToUse & myFile, Visible:=False)
With myDoc
OldName = .FullName
Set oRng = .Words(1)
oRng.End = .Words(min(9, .Words.Count - 1)).End
NewName = Trim(oRng.Text) & ".doc"
NewName = Replace(NewName, "\", "")
NewName = Replace(NewName, ":", "")
NewName = Replace(NewName, """", "")
NewName = Replace(NewName, vbCr, "")
NewName = Replace(NewName, vbTab, "")
.Close SaveChanges:=wdSaveChanges
End With
Name OldName As PathToUse & NewName
myFile = Dir$()
Loop

End Sub
Private Function min(a As Long, b As Long)
min = -((a < b) * a + (a >= b) * b)
End Function

I take no credit for this script, I found it as is while browsing the web looking for a solution. If anyone has any insight into this problem I would greatly appreciate a response.

Answer 1

"My problem is I have no idea on how to accomplish this." I don't think this is how SO was designed to operate, but I think I can use this routine also. So here's my version, which I think is better. The 'net is short on VBA tutorials, but this looks good: http://word.mvps.org/FAQs/MacrosVBA/VBABasicsIn15Mins.htm.

Option Explicit

Public Sub BatchReNameFiles()
  Const sPath = "c:\test\" ' could do FileDialog
  Dim OldName$, NewName$, openDoc As Document
  ThisDocument.Content.Delete
  OldName = Dir$(sPath & "*.doc", vbNormal)
  Do While OldName <> ""
    ThisDocument.Activate
    Selection.TypeText OldName & " -> "
    Set openDoc = Documents.Open(sPath & OldName)
    openDoc.Activate
    NewName = getChars(20) & ".doc"
    openDoc.Close
    ThisDocument.Activate
    If NewName <> ".doc" Then
      Selection.TypeText NewName
      On Error GoTo zError
      Name sPath & OldName As NewName
      On Error GoTo 0 ' reset
    End If
    Selection.TypeText vbCrLf
    DoEvents
    OldName = Dir$()
  Loop
Exit Sub
zError:
  Selection.TypeText "Error: " & Err.Description
  Resume Next
End Sub

Function getChars$(nChars&) ' get good characters
  Dim s1$, sChar$
  Selection.HomeKey wdStory
  Do
    sChar = Chr$(Asc(Selection.Text)) ' one character
    If "0" <= sChar And sChar <= "9" Or _
       "A" <= sChar And sChar <= "Z" Or _
       "a" <= sChar And sChar <= "z" Then
      s1 = s1 & sChar
      If Len(s1) = nChars Then Exit Do
    End If
  Loop While Selection.MoveRight(1, wdCharacter) <> 0
  getChars = s1
End Function

EDIT: Try this minimum and add/uncomment statements to it. I'm baffled.

Option Explicit

Public Sub BatchReNameFiles()
'  Const sPath = "c:\test\" ' could do FileDialog
'  Dim OldName$, NewName$, openDoc As Document
'  ThisDocument.Content.Delete
'  OldName = Dir$(sPath & "*.doc", vbNormal)
'  ThisDocument.Activate
  Selection.TypeText "This is data"
'  Selection.TypeText OldName & " -> "
End Sub