Publisher VBA Startセット(3) PropertySearch 調査セット

Public Sub PublisheTextStyleList()
Dim pbDoc As Publisher.Document: Set pbDoc = Publisher.Application.ActiveDocument
Dim pbView As Publisher.View: Set pbView = pbDoc.ActiveView
Dim pbWin As Publisher.Window, WSz As pbWinSize: Set pbWin = pbDoc.ActiveWindow: WSz.h = pbWin.Height: WSz.l = pbWin.Left: WSz.w = pbWin.Width: WSz.t = pbWin.Top
Dim pbPages As Publisher.Pages: Set pbPages = pbDoc.Pages
Dim pbPage As Publisher.Page, PgS As pbPageSet: Set pbPage = Publisher.ActiveDocument.ActiveView.ActivePage
Dim pbShps As Publisher.Shapes, pbShp As Publisher.Shape
Dim pbtFrame As Publisher.TextFrame, pbtRng As Publisher.TextRange
Dim pbTStyles As Publisher.TextStyles, pbTstyle As Publisher.TextStyle
Dim Sz As pbShapeSize
PgS.IgnoreMaster = pbPage.IgnoreMaster: PgS.Height = pbPage.Height: PgS.Width = pbPage.Width: PgS.XOffsetWithinReaderSpread = pbPage.XOffsetWithinReaderSpread: PgS.YOffsetWithinReaderSpread = pbPage.YOffsetWithinReaderSpread
For Each pbPage In pbDoc.Pages
Set pbShps = pbPage.Shapes
If pbShps.Count > 0 Then
Debug.Print "-----------------------" & vbCrLf & " Page" & pbPage.PageNumber & vbCrLf & "-----------------------"
With pbPage
Debug.Print ".Height, .Width"
Debug.Print .Height, .Width
Debug.Print "-----------------------"
End With
Debug.Print ".AlternativeText, .AutoShapeType, .BlackWhiteMode, .HasTable, .HasTextFrame, .left, .top, .Width, .Height, .Name, .Type,.Rotation"
For Each pbShp In pbShps
With pbShp
Debug.Print .AlternativeText, .AutoShapeType, .BlackWhiteMode, .HasTable, .HasTextFrame, .Left, .Top, .Width, .Height, .Name, .Type, .Rotation
End With
Next
End If
Next
End Sub
Public Sub pbTstyle()
Dim pbDoc As Publisher.Document: Set pbDoc = Publisher.Application.ActiveDocument
Dim pbView As Publisher.View: Set pbView = pbDoc.ActiveView
Dim pbWin As Publisher.Window, WSz As pbWinSize: Set pbWin = pbDoc.ActiveWindow: WSz.h = pbWin.Height: WSz.l = pbWin.Left: WSz.w = pbWin.Width: WSz.t = pbWin.Top
Dim pbPages As Publisher.Pages: Set pbPages = pbDoc.Pages
Dim pbPage As Publisher.Page: Set pbPage = Publisher.ActiveDocument.ActiveView.ActivePage
Dim pbShps As Publisher.Shapes, pbShp As Publisher.Shape
Dim pbtFrame As Publisher.TextFrame, pbtRng As Publisher.TextRange
Dim pbTStyles As Publisher.TextStyles, pbTstyle As Publisher.TextStyle
Dim Sz As pbShapeSize, FSet As FontSetting, Para As ParagraphSet
Debug.Print "--------List Of Publisher ThisDocument TextStyle -----------------"
For Each pbTstyle In pbDoc.TextStyles
With pbTstyle
FSet.isBld = pbTstyle.Font.Bold
FSet.isiTa = .Font.Italic
FSet.N = .Font.Name
FSet.iStThrough = .Font.StrikeThrough
FSet.Ns = .Font.NumberStyle
FSet.Sz = .Font.Size
FSet.Trc = .Font.Tracking
FSet.TrPrSet = .Font.TrackingPreset
FSet.UdLine = .Font.Underline
Para.Ali = .ParagraphFormat.Alignment
Para.AtT = .ParagraphFormat.AttachedToText
On Error Resume Next
If IsEmpty(.ParagraphFormat.CharBasedFirstLineIndent) = False Then
Para.CBFLIndent = .ParagraphFormat.CharBasedFirstLineIndent
End If
On Error GoTo 0
Para.FLIndent = .ParagraphFormat.FirstLineIndent
Para.KLT = .ParagraphFormat.KeepLinesTogether
Para.KWN = .ParagraphFormat.KeepWithNext
Para.LS = .ParagraphFormat.LineSpacing
Para.LSR = .ParagraphFormat.LineSpacingRule
Para.ListIndent = .ParagraphFormat.ListIndent
Para.ListType = .ParagraphFormat.ListType
If Para.ListType = pbListTypeBullet Then
'Para.ListNumberSeparator = .ParagraphFormat.ListNumberSeparator
'Para.ListNumberStart = .ParagraphFormat.ListNumberStart
Para.ListBulletFontName = .ParagraphFormat.ListBulletFontName
Para.ListBulletFontSize = .ParagraphFormat.ListBulletFontSize
Para.ListBulletText = .ParagraphFormat.ListBulletText
End If
Para.RightIndent = .ParagraphFormat.RightIndent
Para.SpaceAfter = .ParagraphFormat.SpaceAfter
Para.SpaceBefore = .ParagraphFormat.SpaceBefore
Para.StartInNextTextBox = .ParagraphFormat.StartInNextTextBox
Para.TextDirection = .ParagraphFormat.TextDirection
Para.TextStyle = .ParagraphFormat.TextStyle
Debug.Print .Name, .Font.Name, .Font.Size, .Font.Bold
End With
Next
End Sub

Sub DocumentFind()
'https://msdn.microsoft.com/en-us/library/office/ff940564.aspx
'全オブジェクト対象
Dim objFind As FindReplace
Dim fFound As Boolean
Set objFind = ActiveDocument.Find
fFound = True
With objFind
.Clear
.FindText = "important"
Do While fFound = True
fFound = .Execute
If Not .FoundTextRange Is Nothing Then
.FoundTextRange.Font.Bold = True
.FoundTextRange.InsertAfter newtext:="<I Found This"
End If
Loop
End With
End Sub

Sub PbDocumentReplace()
With ActiveDocument.Find
.Clear
.Forward = True '文書の最初から検索する場合True 文書の最後から検索する場合False
.MatchWidth = False 'False 全角か半角かを区別する True 区別しない
.MatchWholeWord = True 'True 完全一致検索 False 部分一致検索
.MatchCase = False 'False means O and o is same.
' .MatchDiacritics = True 'ドイツ語のような発音記号で区別される言語で、Trueの場合は区別する、日本語では設定しない
.FindText = "bizarre" '書式設定されていない検索対象文字列。特殊記号^p段落記号 ^t タブ文字も可能
.ReplaceWithText = "strange"
.ReplaceScope = pbReplaceScopeOne '１回置換
Do While .Execute = True
'<I Found This を加え、太字イタリックにする
.FoundTextRange.Font.Italic = msoTrue
.FoundTextRange.Font.Bold = msoTrue
.FoundTextRange.InsertAfter newtext:="<I Found This"
Loop
End With
End Sub

Sub FindWithLike()
'部分一致検索
With ActiveDocument.Find
.Clear
.MatchWholeWord = False '部分一致検索の場合False
.FindText = "fact"
.ReplaceScope = pbReplaceScopeNone '置換しない
Do While .Execute = True
.FoundTextRange.Font.Bold = msoTrue
Loop
End With
End Sub


Sub replacewithtexttest()
'hello を goodbyに変えて太字にする
With ActiveDocument.Find
.Clear '検索条件のクリア
.FindText = "hello"
.ReplaceWithText = "goodbye"
.MatchWholeWord = True
.ReplaceScope = pbReplaceScopeAll 'すべて置換
.Execute
End With
End Sub

Sub testrgbarray()
'Colorの値からRGBに分解して値をイミディエイトに表示 R G B 色名(8色）です
'定数、関数はTypeSetモジュールに入っています
Dim objCol As Collection
Dim i as Long
Set objCol = rgbarray(0)
For i = 1 To objCol.Count
Debug.Print objCol.Item(i)
Next i
End Sub

Sub MakeShapeList()
Const StLine = 9 'Input This Line Number
Dim pbDoc As Publisher.Document: Set pbDoc = Publisher.Application.ActiveDocument
Dim pbView As Publisher.View: Set pbView = pbDoc.ActiveView
Dim pbWin As Publisher.Window, WSz As pbWinSize: Set pbWin = pbDoc.ActiveWindow: WSz.h = pbWin.Height: WSz.l = pbWin.Left: WSz.w = pbWin.Width: WSz.t = pbWin.Top
Dim pbPages As Publisher.Pages: Set pbPages = pbDoc.Pages
Dim pbPage As Publisher.Page, pbPSet As pbPageSet: Set pbPage = Publisher.ActiveDocument.ActiveView.ActivePage
Dim pbShps As Publisher.Shapes, pbShp As Publisher.Shape
Dim pbFrameCollection As PbTextFrameset
Dim pbtFrame As Publisher.TextFrame, pbtRng As Publisher.TextRange
Dim pbTStyles As Publisher.TextStyles, pbTstyle As Publisher.TextStyle
Dim Sz As pbShapeSize, FS As FontSetting, Para As ParagraphSet, PSz As pbShapeSize, Tss As pbTableSet, SS As pbStroySet, TFS As PbTextFrameset, TRS As PbTextRangeset
Dim buf As String, cl As Collection
Dim sr As ADODB.Stream: Set sr = New ADODB.Stream
sr.Charset = "utf-8": sr.LineSeparator = adCRLF: sr.Mode = adModeReadWrite: sr.Type = adTypeText: sr.Open
Debug.Print StLine + 10 'Line:0012 <StLine Use Like This. Show Relative Row Position.And Add Remark Line Number Like "'Line:0012" is Readabily.
Dim pbShp1 As Publisher.Shape
sr.WriteText "name;type;left;top;witdth;height;blackandwhitemode;R;G;B;autofittext;orientation;VerticalTextAlignment;Txt", adWriteLine
For Each pbShp In pbPage.Shapes
Sz.h = pbShp.Height: Sz.l = pbShp.Left: Sz.t = pbShp.Top: Sz.w = pbShp.Width: Sz.Altext = pbShp.AlternativeText: Sz.BWmode = pbShp.BlackWhiteMode
If pbShp.HasTextFrame Then
Set cl = rgbarray(pbShp.Line.ForeColor)
buf = Left(pbShp.TextFrame.TextRange.Text, 300)
pbFrameCollection.AutoFitText = pbShp.TextFrame.AutoFitText: pbFrameCollection.Orientation = pbShp.TextFrame.Orientation: pbFrameCollection.VerticalTextAlignment = pbShp.TextFrame.VerticalTextAlignment

Debug.Print pbShp.Name & ";" & fnShapeTypeString(pbShp.Type) & ";" & Sz.l & ";" & Sz.t & ";" & Sz.w & ";" & Sz.h & ";" & Sz.BWmode & ";" & cl.Item(1) & ";" & cl.Item(2) & ";" & cl.Item(3) & ";" & pbFrameCollection.AutoFitText & ";" & pbFrameCollection.Orientation & ";" & pbFrameCollection.VerticalTextAlignment & ";" & Chr(34) & buf & Chr(34), adWriteLine
Debug.Print pbShp.Name & ";" & fnShapeTypeString(pbShp.Type) & ";" & Sz.l & ";" & Sz.t & ";" & Sz.w & ";" & Sz.h & ";" & Sz.BWmode & ";" & cl.Item(1) & ";" & cl.Item(2) & ";" & cl.Item(3) & ";" & pbFrameCollection.AutoFitText & ";" & pbFrameCollection.Orientation & ";" & pbFrameCollection.VerticalTextAlignment & ";""" & Replace(Replace(Replace(buf, Chr(10), vbLf, 1, -1, vbTextCompare), Chr(13), vbLf, 1, -1, vbTextCompare), vbCr, vbLf, 1, -1, vbTextCompare) & """"
'sr.WriteText pbShp.Name & ";" & fnShapeTypeString(pbShp.Type) & ";" & Sz.l & ";" & Sz.t & ";" & Sz.w & ";" & Sz.h & ";" & Sz.BWmode & ";" & cl.Item(1) & ";" & cl.Item(2) & ";" & cl.Item(3) & ";" & pbFrameCollection.AutoFitText & ";" & pbFrameCollection.Orientation & ";" & pbFrameCollection.VerticalTextAlignment & ";""" & Replace(Replace(buf, Chr(10), vbLf, 1, -1, vbTextCompare), Chr(13), vbLf, 1, -1, vbTextCompare) & """;", adWriteLine ' & Replace(Replace(pbShp.AlternativeText, Chr(10), vbLf, 1, -1, vbTextCompare), Chr(13), vbLf, 1, -1, vbTextCompare) & """"";", adWriteLine
sr.WriteText pbShp.Name & ";" & fnShapeTypeString(pbShp.Type) & ";" & Sz.l & ";" & Sz.t & ";" & Sz.w & ";" & Sz.h & ";" & Sz.BWmode & ";" & cl.Item(1) & ";" & cl.Item(2) & ";" & cl.Item(3) & ";" & pbFrameCollection.AutoFitText & ";" & pbFrameCollection.Orientation & ";" & pbFrameCollection.VerticalTextAlignment & ";""" & Replace(Replace(Replace(buf, Chr(10), vbLf, 1, -1, vbTextCompare), Chr(13), vbLf, 1, -1, vbTextCompare), vbCr, vbLf, 1, -1, vbTextCompare) & """", adWriteLine
Else
buf = """"
Debug.Print pbShp.Name & ";" & fnShapeTypeString(pbShp.Type) & ";" & Sz.l & ";" & Sz.t & ";" & Sz.w & ";" & Sz.h & ";" & Sz.BWmode & ";" & cl.Item(1) & ";" & cl.Item(2) & ";" & cl.Item(3)
sr.WriteText pbShp.Name & ";" & fnShapeTypeString(pbShp.Type) & ";" & Sz.l & ";" & Sz.t & ";" & Sz.w & ";" & Sz.h & ";" & Sz.BWmode & ";" & cl.Item(1) & ";" & cl.Item(2) & ";" & cl.Item(3) & ";" & Sz.BWmode & ";" & cl.Item(1) & ";" & cl.Item(2) & ";" & cl.Item(3), adWriteLine
End If
Next
sr.SaveToFile "C:\hoge\ShapeList.txt", adSaveCreateOverWrite
End Sub

要Typeset 下記のリンク先のType statementは追加してください

Publisher VBA Startセット(1) Typeステートメントと関数
http://qiita.com/Q11Q/items/c8a1e05457722d0092f2
必ずこちらのType宣言、ユーザー定義関数を別のモジュールか、このVBAプロシージャの上に作ってください。
す。

Sub Searchoptions()

ApplicationとApplication.Optionsで定まっているPublisherの設定を読み取ります。
Typeでイミディエイトに現れるより多くの設定を読み取っていますので、必要に応じて追加してください。

Sub Publishetextstylelist()

こちらはShapeのプロパティを探るマクロです。
イミディエイトウィンドウに出力します。
またTypeセットで捕捉したものを包含していますので、図形ごとに止めて、ローカルウィンドで設定を見る、あるいはイミディエイトに出力するなどカスタマイズしてください。

Sub pbTstyle()

Wordと同じようにテキストのスタイルがあります。
このプロパティをイミディエイトに出力します。

Sub FindWithLike()

部分一致検索（あいまい検索）です

Sub replacewithtexttest() 2018/5/23追加

テキスト検索系 全文を検索するサンプルコードです

Sub MakeShapeList()

StartキットのType設定を活用してActivePageのShapeのリストを作成します。
UTF-8セミコロン区切りのCSVになっているため、エクセルでそのように設定して開くとリストになります。（ただし1行ごとに1行空白ができます）

単位がポイント

ユーザー定義関数で変換していないので、上下左右、高さ、幅はポイント単位です。
なぜmmではないかというと、それはPublisherの標準のウィンドで書式の詳細を出すとわかるためです。
また出力された数値をイミディエイトで変換することも可能です。
以上からポイント単位にしています。