vba怎样批量为多个word文档用文件名作为页眉文字

ynlxyzr00

vba怎样批量为多个word文档用文件名作为页眉文字

如：245.doc文件名设为页眉文字：245

       246.doc文件名设为页眉文字：246

       247.doc文件名设为页眉文字：247

       248.doc文件名设为页眉文字：248

       249.doc文件名设为页眉文字：249

       250.doc文件名设为页眉文字：250

       251.doc文件名设为页眉文字：251

       252.doc文件名设为页眉文字：252

......................等等

         用VBA代码处理，请大家帮忙处理一下谢谢

cuanju

Option Explicit
Sub d7()
Dim oD As Document
Dim s As String
Dim oItem As Variant
Rem 此代码遍历多个word文件，不是遍历子文件夹
Rem 代码会弹出一个对话框，需要事先手工选择所需的一个或多个word文件，然后代码会批量给这些文件添加页眉
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Word Files", "*.do*"
        If .Show = -1 Then
            For Each oItem In .SelectedItems
            Set oD = Documents.Open(oItem)
                With oD
                    '此处放置代码内容
                    s = Left(.Name, InStrRev(.Name, ".") - 1)
                    .Sections(1).Headers(wdHeaderFooterPrimary).Range = s
                    .Save
                    .Close
                End With
            Next '继续下一个文件
        Else
            Exit Sub
        End If
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "操作完毕！"
End Sub

ynlxyzr00

cuanju 发表于 2020-8-3 09:57
Sub d1()
Rem 选择所需的word文件添加页眉
    Application.ScreenUpdating = False

谢谢你，非常感谢！！！！！！！！！！

abcttud

cuanju 发表于 2020-8-3 09:57
Sub d1()
Rem 选择所需的word文件添加页眉
    Application.ScreenUpdating = False

朋友
如何批量操作

413191246se

cuanju 老师：太厉害了！——但你 2 楼代码，未声明变量，我试了半天，也不知道是啥，请问：
oItem 应该声明为哪个变量？（object/document都出错），s 是 $ 我知道。最后我灵机一动，声明为变体，就是只声明，不写 as ，结果运行结果正确！——另外，这样是很简单的处理文件夹中的文件，但此宏，是不是不能处理子文件夹中的文件？

cuanju

413191246se 发表于 2020-8-3 12:26
cuanju 老师：太厉害了！——但你 2 楼代码，未声明变量，我试了半天，也不知道是啥，请问：
oItem 应该声 ...

俺不爱声明变量，所写代码较为随意^_^追求只要能达到效果就行，（第一版代码修改后，已声明变量，并加上Option Explicit，太累了，但达到了一种更加完善的代码）
如果要遍历子文件夹，难度加大很多，可使用如下代码。

==================================
Option Explicit
Sub dm8()
    Dim strFileFilter As String
    Dim strFileName As String, strType As String
    Dim startFolder As String
    Dim folderList As Object, fileList As Object
    Dim FolderName, arr1
    Dim i As Integer
    Dim oD As Document
    Dim s As String

    Rem 如果遍历子文件夹
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    strFileFilter = "do*"        '在此修改文件类型，注意不要有.，可以使用通配符
    Set folderList = CreateObject("scripting.dictionary")
    Set fileList = CreateObject("scripting.dictionary")
    'On Error Resume Next
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then startFolder = .SelectedItems(1) & "\" Else Exit Sub
    End With
    folderList.Add startFolder, ""
    Do While folderList.Count > 0
        For Each FolderName In folderList.keys
            strFileName = Dir(FolderName, vbDirectory)
            Do While strFileName <> ""
                If strFileName <> ".." And strFileName <> "." Then
                    If GetAttr(FolderName & strFileName) And vbDirectory Then
                        folderList.Add FolderName & strFileName & "\", ""
                    Else
                        i = InStrRev(strFileName, ".")
                        strType = Right(strFileName, Len(strFileName) - i)
                        If strType Like strFileFilter Then
                            fileList.Add FolderName & strFileName, ""
                        End If
                    End If
                End If
                strFileName = Dir
            Loop
            folderList.Remove (FolderName)
        Next
    Loop
    For Each arr1 In fileList.keys
        Set oD = Documents.Open(arr1)  '依次打开各个文件
        s = Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1)
        ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range = s
        oD.Close True
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "操作完毕！"
End Sub

ming0018

这习惯要改

cuanju

ming0018 发表于 2020-8-3 12:59
这习惯要改

好的  已用Option Explicit 规范代码，并加上Dim

413191246se

谢谢 cuanju 老师！辛苦了！代码已经保存，有空时测试一下。以前，杜老师也写过一个循环遍历文件夹代码，在我的《Word2007-2019自动排版宏(通用)(金秋版)2020-7-19》，宏名叫《FSO_循环遍历文件夹》。
cuanju 老师 虽然来得较晚，但啥都会啊！我深表敬佩！多谢！（我只会一点段落格式设置。）

小花鹿

Sub xiaohualu()
Dim n1 As String, n2 As String, pt As String, mydoc As Document
n1 = ThisDocument.Name
pt = ThisDocument.Path & "\"
n2 = Dir(pt & "*.doc")
Do While n2 <> ""
    If n2 <> n1 Then
        Set mydoc = Documents.Open(pt & n2)
        mydoc.Sections(1).Headers(1).Range = n2
        mydoc.Close -1
    End If
    n2 = Dir
Loop
End Sub