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

duquancai · 发表于 2016-11-15 09:29

本帖最后由 duquancai 于 2016-11-15 09:34 编辑

笑九方发表于 2016-11-15 09:26
特别感谢 @duquancai

把上述提取的页码按照打印页码范围的格式直接输入到打印对话框内并打印。

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

本帖最后由笑九方于 2016-11-15 09:54 编辑

代码执行有点问题有的页码明明黑白的说是彩色的我在第一页放的按钮第一页永远认为是彩色

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
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
t = d.keys
For i = 0 To d.Count - 1
If i = 0 Then
s = t(0)
Else
If t(i) - t(i - 1) = 1 Then
s = s & "|" & t(i)
Else
s = s & "," & t(i)
End If
End If
Next
With CreateObject("VBScript.Regexp")
.Global = True: .Pattern = "\|[|\d]+\|"
s = Replace(.Replace(s, "-"), "|", "-")
End With
Open Act.Path & "\页码.txt" For Output As #1
Print #1, "图形/图片/彩色字/高亮字所在页码为:" & s
Close #1
Application.ScreenUpdating = True
MsgBox "页码已经输出到同文件夹下的TXT文本！"
End Sub

复制代码

测试2.zip (1.77 MB, 下载次数: 8)

duquancai · 发表于 2016-11-15 10:06

笑九方发表于 2016-11-15 09:49
代码执行有点问题有的页码明明黑白的说是彩色的我在第一页放的按钮第一页永远认为是彩色

有问题就对了！没问题才不对。呵呵

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

duquancai 发表于 2016-11-15 10:06
有问题就对了！没问题才不对。呵呵

大拿求解~~~~~

duquancai · 发表于 2016-11-15 12:23

笑九方发表于 2016-11-15 11:10
大拿求解~~~~~

简单，但是没时间搞！！！

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

duquancai 发表于 2016-11-15 12:23
简单，但是没时间搞！！！

我可以等 -_-

duquancai · 发表于 2016-11-15 15:06

笑九方发表于 2016-11-15 09:49
代码执行有点问题有的页码明明黑白的说是彩色的我在第一页放的按钮第一页永远认为是彩色

第一页有按钮，按钮是图片，所以第一页永远会输出，除非把按钮删除！或者从第二页（或者第三页，或者第N页。。。。）开始提取！
详见代码：

Private Sub CommandButton1_Click()
' 输出只需要彩色打印的页码至txt文本，以便降低打印成本！
Dim rng As Range, d As Object, Act As Document, k, i%, oSt%
Dim oRang As Range, oPara As Paragraph, mt, t, s, m, n, oEt%
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set Act = ActiveDocument
oEt = Act.ActiveWindow.ActivePane.Pages.Count
oSt = InputBox("输入开始页码", , "1")
If oSt = oEt Then Exit Sub
For i = oSt To oEt
Set rng = Selection.GoTo(1, 1, i).Bookmarks("\page").Range
If rng.InlineShapes.Count + rng.ShapeRange.Count > 0 Then
d(i) = "": GoTo 100
Else
With CreateObject("VBScript.Regexp")
.Global = True: .Pattern = "[^\x07\s\u3000\0a\x0b]"
For Each oPara In rng.Paragraphs
For Each mt In .Execute(oPara.Range.Text)
m = mt.FirstIndex: n = mt.Length
Set oRang = ActiveDocument.Range(oPara.Range.Start + m, oPara.Range.Start + m + n)
clo = oRang.Font.ColorIndex: gls = oRang.HighlightColorIndex
If gls <> 0 Or (clo <> 0 And clo <> 1 And clo <> 8 And clo <> 9999999) Then
d(i) = "": GoTo 100
End If
Next
Next
End With
End If
100 Next
t = d.keys
For i = 0 To d.Count - 1
If i = 0 Then
s = t(0)
Else
If t(i) - t(i - 1) = 1 Then
s = s & "|" & t(i)
Else
s = s & "," & t(i)
End If
End If
Next
With CreateObject("VBScript.Regexp")
.Global = True: .Pattern = "\|[|\d]+\|"
s = Replace(.Replace(s, "-"), "|", "-")
End With
Open Act.Path & "\页码.txt" For Output As #1
Print #1, "需要彩打的页码为:" & vbCrLf & s
Close #1
Application.ScreenUpdating = True
MsgBox "页码已输出到同文件夹下的TXT文本！"
End Sub

复制代码

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

代码执行效率很高！  200多页也没出现卡死情况

实际操作中  我看了下还需要输出不需要彩打的页码为：

我自己先试试看  不行再来请教~~~~~~~~

duquancai · 发表于 2016-11-15 20:21

笑九方发表于 2016-11-15 15:26
代码执行效率很高！ 200多页也没出现卡死情况

实际操作中我看了下还需要输出不需要彩打的页码为：
...

这句 .Global = True: .Pattern = "[^\x07\s\u3000\0a\x0b]"
改为 .Global = True: .Pattern = "[^\x07\s\u3000\x0a]"

笑九方 · 发表于 2016-11-16 17:32

本帖最后由笑九方于 2016-11-17 10:01 编辑

解决了~~~~~~~~~~

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

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

评分