【谢谢vbee、duquancai两位老师】读取Word的页眉内容

roz · 发表于 2018-10-2 17:07

本帖最后由 roz 于 2018-10-2 23:26 编辑

论坛里前人有帖子，也有回答，但我是小白，不知道怎么用，
希望高人可以伸出援手哈！

怎样用VBA读取word页眉页脚？
http://club.excelhome.net/thread-266269-1-1.html?jdfwkey=hyh6e1

页眉的文字在文本框中。
读取的结果保存为纯文本就好。
只读页眉，不需要读页脚的。
结果保存在哪里都行！

怎样提取文本框中的内容，可能可以参考http://club.excelhome.net/thread-870139-1-1.html
怎样提取页眉内容，可能可以参考http://club.excelhome.net/thread-267100-1-440.html
谢谢咯！

样本提取页眉 - 副本.zip (44.69 KB, 下载次数: 21)

duquancai · 发表于 2018-10-2 18:37

本帖最后由 duquancai 于 2018-10-2 19:56 编辑

Sub getHeaderString()
想见楼下代码！
End Sub

复制代码

duquancai · 发表于 2018-10-2 18:45

Sub getHeaderString()
Dim se As Section, doc As Document, sr$, hp As Shape, p As Range
Set doc = ActiveDocument: Set p = doc.Content
If p.Find.Execute("页眉内容") Then
p.SetRange p.Start, doc.Content.End
p.Delete
End If
For Each se In doc.Sections
For i = 1 To 3
For Each hp In se.Headers(i).Range.ShapeRange
sr = sr & vbCr & hp.TextFrame.TextRange.Text
Next
Next
Next
doc.Content.InsertAfter vbCr & "页眉内容" & sr
MsgBox "获取的页眉内容已插入文档末尾！"
End Sub

复制代码

duquancai · 发表于 2018-10-2 18:48

这个贴子的问题也是你吧？

http://club.excelhome.net/forum. ... p;page=1#pid9671961

在这里重新又注册账号。。。。。。。。

duquancai · 发表于 2018-10-2 18:50

这个问题，我给你解答了！代码审核中，耐心等待。。。。。。。。。。。。。。。。。。。。

vbee · 发表于 2018-10-2 18:52

Sub VBEE()
'On Error Resume Next
Dim myRange As Range
Dim H As String
For I = 1 To ActiveDocument.Sections.Count
'首页页眉
Set myRange = ActiveDocument.Sections(I).Headers(wdHeaderFooterFirstPage).Range
H = H & myRange.ShapeRange.AlternativeText & vbCrLf
'偶数页页眉
Set myRange = ActiveDocument.Sections(I).Headers(wdHeaderFooterEvenPages).Range
H = H & myRange.ShapeRange.AlternativeText & vbCrLf
'基本页眉
Set myRange = ActiveDocument.Sections(I).Headers(wdHeaderFooterPrimary).Range
H = H & myRange.ShapeRange.AlternativeText & vbCrLf
Next I
MsgBox Replace(H, "文本框:", "")
End Sub

复制代码

vbee · 发表于 2018-10-2 19:11

2016版

Sub VBEE()
On Error Resume Next
Dim myRange As Range
Dim H As String
For I = 1 To ActiveDocument.Sections.Count
'首页页眉
Set myRange = ActiveDocument.Sections(I).Headers(wdHeaderFooterFirstPage).Range
H = H & myRange.ShapeRange.TextFrame.TextRange.Text & vbCrLf
'偶数页页眉
Set myRange = ActiveDocument.Sections(I).Headers(wdHeaderFooterEvenPages).Range
H = H & myRange.ShapeRange.TextFrame.TextRange.Text & vbCrLf
'基本页眉
Set myRange = ActiveDocument.Sections(I).Headers(wdHeaderFooterPrimary).Range
H = H & myRange.ShapeRange.TextFrame.TextRange.Text & vbCrLf
Next I
H = Replace(H, "文本框:", "")
Selection.EndKey Unit:=wdStory
Selection.TypeText Text:=vbCrLf & "**********************************************************" & vbCrLf & H
End Sub

复制代码

yhs185 · 发表于 2018-12-6 19:19

好

loquat · 发表于 2018-12-7 09:11

vbee 发表于 2018-10-2 19:11
2016版

请教，2016为啥还需要selection，还有为啥要忽略错误呢

		自动登录	找回密码
密码			免费注册

[已解决] 【谢谢vbee、duquancai两位老师】读取Word的页眉内容