在VBA中批量重命名文档第一行，如何跳过非文本？

Question

我有一个充满Word文档的文件夹，该文件夹最近被“删除”，而这些文件的内容是可查看的--所有元数据都丢失了(最重要的是，原始文件名)。我已经找到了一个VBA脚本，它将在文件夹中运行，并用其内容的第一行重命名任何.doc文件。

尽管我需要重命名的许多文件都带有图像，但这些脚本的工作方式与预期的一样，文档中只包含文本。当脚本到达这些文件时，它就结束了，只有到那时为止的文件才会被重命名。

我的编程知识非常有限，对VBA几乎一无所知，但我想我可以跳过图像，使用一个if_~_类型语句，并使用下一行文本作为文件名。我的问题是，我不知道如何做到这一点。此外，删除出现在第一行文本前的任何空格的方法将非常有用，但重要性要小得多。

我目前正在使用的脚本如下：

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

我不相信这个脚本，我发现它是在浏览网页寻找解决方案。如果有人对这个问题有任何见解，我将非常感谢你的答复。

Answer 1

“我的问题是，我不知道如何做到这一点。”我不认为这是为操作而设计的，但我认为我也可以使用这个例程。这是我的版本，我认为更好。在VBA教程上，'net‘很短，但这看起来很好：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

编辑:尝试这个最小值，并向其中添加/取消注释语句。我很困惑。

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

Answer 2

<pre>
Este funciona correctamente (is OK)
</pre>


-------------------------
Option Explicit

Sub FirstPara()
    Application.ScreenUpdating = False
    Dim strFolder As String, salFolder As String, docu As String, NombreCarpeta As String, strFile As String, wdDoc As Document
    Dim FirstPara As String
    Dim counter As Integer, a  As Integer, i  As Integer


    strFolder = GetFolder
    If strFolder = "" Then Exit Sub

    strFile = Dir(strFolder & "\*.doc*", vbNormal)
    i = 0
    a = 0
    Do While strFile <> ""
      i = i + 1
      strFile = Dir
    Loop
                   'MsgBox "value is " & i

    While a < i
        strFile = Dir(strFolder & "\*.doc*", vbNormal)
              docu = strFolder & "\" & strFile
        Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)

        With wdDoc
            FirstPara = .Paragraphs(1).Range.Text
            FirstPara = Left(FirstPara, Len(FirstPara) - 1)
            NewName = Replace(FirstPara, "\", "")
            NewName = Replace(NewName, "/", "")
            NewName = Replace(NewName, ":", "")
            NewName = Replace(NewName, """", "")
            NewName = Replace(NewName, vbCr, "")
            FirstPara = Replace(NewName, vbTab, "")
               'MsgBox "value is " & FirstPara
                NombreCarpeta = "\PROCESADOS"
                'Comprueba que la carpeta no existe para crearla.
                  If Dir(strFolder & NombreCarpeta, vbDirectory) = "" Then MkDir strFolder & NombreCarpeta
                  'MkDir se emplea para crear un directorio/carpeta.

            .SaveAs FileName:=strFolder & "\PROCESADOS\" & FirstPara & ".docx"
            .Close
             'Muevo el fichero a ORIGINALES.
                  NombreCarpeta = "\ORIGINALES"
                    'Comprueba que la carpeta no existe para crearla.
                  If Dir(strFolder & NombreCarpeta, vbDirectory) = "" Then MkDir strFolder & NombreCarpeta
                  'MkDir se emplea para crear un directorio/carpeta.

                FileCopy docu, strFolder & "\ORIGINALES\" & strFile
                Kill docu
          a = a + 1
        End With
        Set wdDoc = Nothing
        strFile = Dir()
    Wend
    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

-----------------------

Answer 3

Option Explicit

Sub FirstPara()
    Application.ScreenUpdating = False
    Dim strFolder As String, salFolder As String, docu As String, NombreCarpeta As String, strFile As String, wdDoc As Document
    Dim FirstPara As String
    Dim counter As Integer, a  As Integer, i  As Integer


    strFolder = GetFolder
    If strFolder = "" Then Exit Sub

    strFile = Dir(strFolder & "\*.doc*", vbNormal)
    i = 0
    a = 0
    Do While strFile <> ""
      i = i + 1
      strFile = Dir
    Loop
                   'MsgBox "value is " & i

    While a < i
        strFile = Dir(strFolder & "\*.doc*", vbNormal)
              docu = strFolder & "\" & strFile
        Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)

        With wdDoc
            FirstPara = .Paragraphs(1).Range.Text
            FirstPara = Left(FirstPara, Len(FirstPara) - 1)
            NewName = Replace(FirstPara, "\", "")
            NewName = Replace(NewName, "/", "")
            NewName = Replace(NewName, ":", "")
            NewName = Replace(NewName, """", "")
            NewName = Replace(NewName, vbCr, "")
            FirstPara = Replace(NewName, vbTab, "")
               'MsgBox "value is " & FirstPara
                NombreCarpeta = "\PROCESADOS"
                'Comprueba que la carpeta no existe para crearla.
                  If Dir(strFolder & NombreCarpeta, vbDirectory) = "" Then MkDir strFolder & NombreCarpeta
                  'MkDir se emplea para crear un directorio/carpeta.

            .SaveAs FileName:=strFolder & "\PROCESADOS\" & FirstPara & ".docx"
            .Close
             'Muevo el fichero a ORIGINALES.
                  NombreCarpeta = "\ORIGINALES"
                    'Comprueba que la carpeta no existe para crearla.
                  If Dir(strFolder & NombreCarpeta, vbDirectory) = "" Then MkDir strFolder & NombreCarpeta
                  'MkDir se emplea para crear un directorio/carpeta.

                FileCopy docu, strFolder & "\ORIGINALES\" & strFile
                Kill docu
          a = a + 1
        End With
        Set wdDoc = Nothing
        strFile = Dir()
    Wend
    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