之前的求助内容简化下！~~~~~~~~~~~~

笑九方 · 发表于 2016-11-12 09:27

将下面例子中非黑白的字页码，有底色的页码，有彩色图片的页码，输出到word或者txt里

主要是招标文件几百页内容有的是彩色的大部分是黑白的为了不浪费彩色打印机的碳粉分开打印

比如word和txt里内容为：1,2,5,23,117..............

输出颜色页码.rar (29.58 KB, 下载次数: 15)

笑九方 · 发表于 2016-11-12 12:35

这个很麻烦吗？

duquancai · 发表于 2016-11-12 12:47

笑九方发表于 2016-11-12 12:35
这个很麻烦吗？

不难，就是要时间，没时间搞！跟你上一个贴原理一样，自己搞一下。

笑九方 · 发表于 2016-11-12 14:50

那大神这样嘞你分享一下如何判断图片所在的页码【一页有多张图片的话只输出一个页码】。就这个不会了

duquancai · 发表于 2016-11-12 16:57

笑九方发表于 2016-11-12 14:50
那大神这样嘞你分享一下如何判断图片所在的页码【一页有多张图片的话只输出一个页码】。就这个不会了

你附件中没有图片？，所以不用判断了！！！（文档中图片也得区分浮动还是嵌入？）

zhanglei1371 · 发表于 2016-11-13 11:17

黑白和彩色图片我不会判断：

Sub dsfsda()
On Error Resume Next
Dim co As New Collection
For i = 1 To ActiveDocument.ActiveWindow.Panes(1).Pages.Count
ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, i).Select
Selection.Bookmarks("\page").Range.Select
If Selection.ShapeRange.Count > 0 Or Selection.InlineShapes.Count > 0 Then
co.Add i & "----有图"
Else
Set S = Selection.Range.Duplicate
With S.Find
.Text = "[!^13]"
.MatchWildcards = True
Do While .Execute
If Not .Parent.InRange(Selection.Range) Then Exit Do
If .Parent.HighlightColorIndex <> wdAuto Or .Parent.Font.ColorIndex <> wdAuto Then
co.Add i & "------有彩色字体或底纹"
Exit Do
End If
Loop
End With
End If
Next
Kill "c:\tem.txt"
Open "c:\tem.txt" For Append As #1
Print #1, "有颜色的字体或图像的页码为:"
For i = 1 To co.Count
Print #1, co(i)
Next
Close #1
Shell "notepad c:\tem.txt", vbNormalFocus
End Sub

复制代码

duquancai · 发表于 2016-11-13 21:04

本帖最后由 duquancai 于 2016-11-13 23:24 编辑

Private Sub CommandButton1_Click()
Dim rng As Range, d As Object, Act As Document, k, i%, Ds As Range
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set Act = ActiveDocument
On Error Resume Next
For i = 1 To Act.ActiveWindow.ActivePane.Pages.Count
Selection.GoTo 1, 1, i
Set rng = Selection.Bookmarks("\page").Range
If rng.InlineShapes.Count + rng.ShapeRange.Count > 0 Then
d.Add i, "": GoTo 100
Else
Set Ds = rng.Duplicate
With Ds.Find
.Text = "[!^13]{1,}"
.MatchWildcards = True
Do While .Execute
If Not .Parent.InRange(rng) Then Exit Do
If .Parent.HighlightColorIndex <> wdAuto Or .Parent.Font.ColorIndex <> wdAuto Then
d.Add i, "": Exit Do
End If
Loop
End With
End If
100 Next
For Each k In d.keys
stxt = stxt & k & ","
Next
Open Act.Path & "\页码.txt" For Output As #1
Print #1, "图形/图片/彩色字/高亮字所在页码为:" & stxt
Close #1
Application.ScreenUpdating = True
MsgBox "页码已经输出到同文件夹下的TXT文本！"
End Sub

复制代码

笑九方 · 发表于 2016-11-14 16:54

膜拜2位大神~~~~~~~~~~ 解决了这个难题

duquancai · 发表于 2016-11-14 17:10

本帖最后由 duquancai 于 2016-11-14 17:47 编辑

笑九方发表于 2016-11-14 16:54
膜拜2位大神~~~~~~~~~~ 解决了这个难题

Sub 输出页码()
' 输出只需要彩色打印的页码至txt文本，以便降低打印成本！
Dim rng As Range, d As Object, Act As Document, k, i%, Ds As Range
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set Act = ActiveDocument
On Error Resume Next
For i = 1 To Act.ActiveWindow.ActivePane.Pages.Count
Set rng = Selection.GoTo(1, 1, i).Bookmarks("\page").Range
If rng.InlineShapes.Count + rng.ShapeRange.Count > 0 Then
d.Add i, "": GoTo 100
Else
Set Ds = rng.Duplicate
With Ds.Find
.Text = "[!^13]{1,}"
.MatchWildcards = True
Do While .Execute
If Not .Parent.InRange(rng) Then Exit Do
If .Parent.HighlightColorIndex <> wdAuto Or .Parent.Font.ColorIndex <> wdAuto Then
d.Add i, "": Exit Do
End If
Loop
End With
End If
100 Next
For Each k In d.keys
stxt = stxt & k & ","
Next
Open Act.Path & "\页码.txt" For Output As #1
Print #1, "图形/图片/彩色字/高亮字所在页码为:" & stxt
Close #1
Application.ScreenUpdating = True
MsgBox "页码已经输出到同文件夹下的TXT文本！"
End Sub

复制代码

笑九方 · 发表于 2016-11-15 09:26

特别感谢 @duquancai

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

[求助] 之前的求助内容简化下！~~~~~~~~~~~~