ワードベーシックで、離れた二つの箇所の属性を取得する方法

ワードで、Ctrlを押しながら範囲指定した、同一文書内の離れた二つの箇所の文を段落単位で比較させたいと思っています。
最初に指定した箇所をＡ、次に指定した箇所をＢとします。
ここで、
Dim Genzaiti as Long
Genzaiti = Selection.Range.Start
Msgbox(Genzaiti)
とすると、Ｂの開始位置が表示されます。
この場合、Ａの開始位置を取得する方法はあるでしょうか？

No.5 回答者： Wendy02 回答日時： 2009/06/27 09:10

補足：

元のドキュメントのイメージも置いておきます。

新たに出来るリストのドキュメントファイル名
Private Const LISTDOC As String = "CheckList1.doc"　'チェックリスト

マーカーの色の設定は、
Private Const MYCOLOR As Integer = wdYellow '黄色--7

wdColorIndex 定数
------------------------
'wdByAuthor
'wdAuto
'wdNoHighlight
'wdBlack
'wdBlue
'wdBrightGreen
'wdDarkBlue
'wdDarkRed
'wdDarkYellow
'wdGray25
'wdGray50
'wdGreen
'wdPink
'wdRed
'wdTeal
'wdTurquoise
'wdViolet
'wdWhite
'wdYellow　　<---今回（デフォルト)

この回答への補足

Wendy02　様

教えていただいたコードを実行してみました。新しいファイルに一覧が示されるのですね。
コードの内容、私のレベルではなかなか理解できませんので、もう少し勉強してみます。
ありがとうございました。

補足日時：2009/07/07 05:58

No.4 回答者： Wendy02 回答日時： 2009/06/26 22:27

こんばんは。

こちらの思惑で作りました。本来は、アドインにして、コマンドボタンに付けるとは良いのですが、まだ、ベータです。蛍光ペンで一覧を作ります。新旧のリストになります。ブックマークで付けていきますから、完全に、旧リストの単語を削除してしまうと、ズレてしまうかもしれません。なお、蛍光ペンを拾うサンプル・マクロは出ていますが、誤動作するので、私のオリジナル・マクロです。

現在は、ブックマークの名称欄に、リンクを付けていません。
失敗したときのことを考えて、「初期化プログラム」を付けておきます。


'--------------------------------------------

'Option Explicit

Private Const LISTDOC As String = "CheckList1.doc"　'チェックリスト
Private Const MYCOLOR As Integer = wdYellow '黄色--7
Sub WordHilightFind()
　　
　　Dim arList() As String
　　Dim i As Long
　　Dim j As Long
　　Dim NewDoc As Document
　　Dim v As Variant
　　Dim boolFound As Boolean
　　Dim intCount As Integer
　　ReDim arList(0)
　　arList(0) = "元リスト" & Format$(Date, "yy.mm.dd")
　　i = 1
　　For Each v In ActiveDocument.Bookmarks
　　　If v.Name Like "t#" Then
　　　　MsgBox "すでに、リストがあるはずですから、'SecountListUp'を実行してください。", vbInformation
　　　　Exit Sub
　　　End If
　　Next
　　Selection.HomeKey Unit:=wdStory
　　Options.DefaultHighlightColorIndex = MYCOLOR
　　Selection.Find.ClearFormatting
　　With Selection.Find
　　　　.Highlight = True
　　　　.Text = "*"
　　　　.Forward = True
　　　　.Format = True
　　　　.Wrap = wdFindContinue
　　　　.Format = True
　　　　.MatchCase = False
　　　　.MatchWholeWord = False
　　　　.MatchByte = False
　　　　.MatchAllWordForms = False
　　　　.MatchSoundsLike = False
　　　　.MatchFuzzy = False
　　　　.MatchWildcards = True
　　End With
　　　Application.ScreenUpdating = False
　　　 Do
　　　　With Selection.Find
　　　　　　.Execute
　　　　　　With Selection.Range
　　　　　　　　n = .Start
　　　　　　　　If b = 0 Then
　　　　　　　　　　s = n
　　　　　　　　　　b = n
　　　　　　　　End If
　　　　　　　　If n - b > 1 Then
　　　　　　　　　　Selection.SetRange s, b + 1
　　　　　　　　　　SetBookMark Selection.Range, "t" & CStr(i)
　　　　　　　　　　ReDim Preserve arList(i)
　　　　　　　　　　arList(i) = Selection.Range.Text
　　　　　　　　　　Selection.MoveRight Unit:=wdCharacter, Count:=Len(arList(i))
　　　　　　　　　　s = n
　　　　　　　　　　i = i + 1
　　　　　　　　End If
　　　　　　　　b = n
　　　　　　
　　　　　　End With
　　　　End With
　　　　boolFound = Selection.Find.Found
　　Loop While boolFound = True
　　Application.ScreenUpdating = True
　　Selection.SetRange s, b + 1
　　SetBookMark Selection.Range, "t" & CStr(i)
　　ReDim Preserve arList(i)
　　arList(i) = Selection.Range.Text
　
　　
　　'-----------新しい表---------
　　Set NewDoc = Documents.Add
　　AddmyTable NewDoc, UBound(arList()) + 1, 3 'リストの1行目使用
　　NewDoc.SaveAs LISTDOC
　　With NewDoc
　　For j = 1 To UBound(arList()) + 1　　'リストの1行目使用
　　 With .Tables(1)
　　　 If j = 1 Then
　　　　　 .Cell(j, 1).Range.Text = "ブックマーク"
　　　 Else
　　　　　 .Cell(j, 1).Range.Text = "t" & j - 1
　　　 End If
　　　 .Cell(j, 2).Range.Text = arList(j - 1)
　　 End With
　　Next
　　End With
End Sub

Private Sub SetBookMark(rng As Range, ByVal tName As String)
　　With ActiveDocument.Bookmarks
　　　　.Add Range:=Selection.Range, Name:=tName
　　　　.DefaultSorting = wdSortByName
　　　　.ShowHidden = True
　　End With
End Sub
Private Sub AddmyTable(mDoc As Document, ByVal rw As Integer, ByVal col As Integer)
　　　mDoc.Tables.Add _
　　　　　 Range:=Selection.Range, _
　　　　　 NumRows:=rw, _
　　　　　 NumColumns:=col, _
　　　　　 DefaultTableBehavior:=wdWord9TableBehavior, _
　　　　　 AutoFitBehavior:=wdAutoFitFixed
End Sub
'===================================================================================
Sub SecountListUp()
'二度目のリストアップ
　　Dim v As Variant
　　Dim i As Long
　　Dim myDoc As Document
　　Dim lisDoc As Document
　　On Error GoTo ErrHandler
　　If ActiveDocument.Bookmarks.Count = 0 Then
　　　　MsgBox "文章のあるドキュメントをアクティブにしてください。", vbCritical
　　　　Exit Sub
　　End If
　　Set myDoc = ActiveDocument
　　Set lisDoc = Documents(LISTDOC)
　　With lisDoc.Tables(1)
　　　　.Cell(1, 3).Range.Text = "新リスト"
　　　　For i = 2 To myDoc.Bookmarks.Count + 1
　　　　　　.Cell(i, 3).Range.Text = myDoc.Bookmarks(i - 1).Range.Text
　　　　Next
　　End With
　　lisDoc.Activate
　　If i > 1 Then
　　　MsgBox "リストが更新されました。", vbInformation
　　End If
　　Exit Sub
ErrHandler:
　　If Dir(myDoc.Path & "\" & LISTDOC) <> "" Then
　　　　Application.Documents.Open LISTDOC
　　　　Resume
　　End If
End Sub
'===================================================================================
Sub CleanUpBookNames()
　　'初期化ブログラム（リストファイルも削除)
　　Dim v As Variant
　　Dim i As Integer
　　Dim dum As Document
　　On Error Resume Next
　　Set dum = Documents(LISTDOC)
　　dum.Close False
　　On Error GoTo 0
　　If MsgBox("リストを初期化します。", vbQuestion + vbOKCancel) = vbCancel Then
　　　　Exit Sub
　　End If
　　For Each v In ActiveDocument.Bookmarks
　　　　If v.Name Like "t#*" Then
　　　　　　v.Delete
　　　　　　i = i + 1
　　　　End If
　　Next v
　　If i > 0 Then
　　　i = 1
　　Else
　　　i = 0
　　End If
　　If Dir(ActiveDocument.Path & "\" & LISTDOC) <> "" Then
　　　　If MsgBox("リストドキュメントを削除してよろしいですか", vbQuestion + vbOKCancel) = vbCancel Then
　　　　　　Exit Sub
　　　　End If
　　　　Kill ActiveDocument.Path & "\" & LISTDOC
　　　　i = i + 2
　　Else
　　　　MsgBox "リストドキュメントファイルが見つかりません。手動で削除してください。", vbInformation
　　End If
　　
　　If i = 3 Then
　　　　MsgBox "すべて完了しました。", vbInformation
　　ElseIf i = 2 Then
　　　　MsgBox "リストファイルのみ削除しました。" & vbCrLf & LISTDOC, vbInformation
　　ElseIf i = 1 Then
　　　　MsgBox "ブックマークのみ削除しました。", vbInformation
　　ElseIf i = 0 Then
　　　　MsgBox "ブックマークもリストファイルの削除も実行されませんでした。", vbInformation
　　End If
End Sub

この回答への補足

Wendy02 様

いろいろご努力いただき、ありがとうございます。
会社のパソコンでないとできませんので、月曜日に試してみます。

補足日時：2009/06/27 06:43

No.3 回答者： Wendy02 回答日時： 2009/06/25 18:29

こんにちは。

>お役所に提出する書類で新旧対比表のようなものです。
イメージは良く分かりました。

>合致した言葉だけ色を消していくことで、合致しない言葉が蛍光色のまま残るというマクロを作りました。

>セルの文章量が多すぎると大抵合致してしまい、

それは、Find メソッドで一括して使ったせいですね。Wordの持つ校正ツール（チェック/コメント)が、もう少し良いといいのですが、ゴテゴテしすぎますね。

余計なお世話でしょうけれども、マーカーの蛍光色を残すマクロの延長を、私なりに、一体どうなるのか、もう一度考えてみます。今のイメージでは、フィールドは使っていないことが条件です。(textプロパティを使うのは邪道ですが、場合によっては、やむを得ません)
やってみないとわかりません。

締めないで、しばらく開けておいてください。

No.2 回答者： Wendy02 回答日時： 2009/06/23 10:49

こんにちは。

>横に並べて、どこを修正したか確認もできるようにしておきたいので、これができれば、大変役に立ちます。

そんなマクロでよかったのですか？もう少し、いろんなアイデアを加えることが可能？/必要性があるような気がします。私も書くのが仕事です。だから、共感が得られれば、私も考えてみたいなって思います。

わたし的な考えですと、最初の段階では、色づけ（マーカー)が良いのではないかと思います。マーカーのショートカットで単語を色づけしておいて、後は、別のWord・ドキュメントやメモ帳に一覧にするとか？あったらいいなって思うものは、言ってみたほうがよいのではありませんか？　(出来る出来ないは別問題ですけれどもね（^^;)

Wordマクロはあまり色を扱うことが得意ではありませんが、ある程度は可能です。ただ、Word97 だと、もっと制限が加わってしまうと思います。書式検索はなかったと思いますから。

なお、余談ですが、Wordの代表的なマクロは、前に書いていた最後のところにカーソルが飛ぶという一行マクロです。ところが、こんなものでも全バージョンは難しいのです。理由は、Excelは、前のバージョンになるべく近づけるのですが、Wordは、簡単に変えてしまうことがあるからです。後は、Excelと同等の日付を入れるマクロとかです。

この回答へのお礼

さらなるコメントありがとうございます。
マクロを使う文書は、お役所に提出する書類で新旧対比表のようなものです。
新旧の文書は、数段落の一定の単位の文章でセルに切られています。
この表の左右のセルを選択してまず蛍光ペンで色を着け、左のセルの文書を頭からinstrで比較していって、合致した言葉だけ色を消していくことで、合致しない言葉が蛍光色のまま残るというマクロを作りました。しかし、セルの文章量が多すぎると大抵合致してしまい、いまいち役に立たないのです。
もっと、ピンポイントで比較できたらと考えて、会社の2003ではCtrlで離れた場所を同時に選択できるので、これを使うと視覚的にもやりやすいと考え、あのような質問をした次第です。

お礼日時：2009/06/24 23:16

No.1 回答者： Wendy02 回答日時： 2009/06/21 10:51

こんにちは。

まず、ワードベーシック(WordBasic)は、分かりません。今のWord97以上ではWordBasic は使えません。WordBasicというのは、Word Ver.5(95)/Word6 のプログラミング・コードで、おそらくはほとんどは互換性がありません。もし、それをお求めなら、できる人はいないと思います。あくまでも、以下は、Word VBAです。

それと、Ctrl で押しながら、点在する範囲を取る方法は直接にはありません。ご質問に関しては、あるともないとも言えます。そこから、一旦、別の書式やフォントに換えておいて、それをFind で検索をして、そのRange を取って、元の書式やフォントに戻すというコードになるのでしょうけれど、このようなマクロが何の役にたつのでしょうね？


Sub Test1()
　　Dim myStart As String
　　Dim i As Long
　　Dim bi As Long
　　If Len(Selection.Range.Text) = 0 Then
　　　　MsgBox "選択されていません。", vbInformation
　　　　Exit Sub
　　End If
　　
　　With Selection
　　　　.Font.Bold = True
　　　　.Font.Italic = True
　　End With
　　With Selection.Find
　　　　.ClearFormatting
　　　　.Text = "?*"
　　　　.Replacement.Text = ""
　　　　.Font.Bold = True
　　　　.Font.Italic = True
　　　　
　　　　.Forward = True
　　　　.Wrap = wdFindContinue
　　　　.Format = True
　　　　.MatchCase = False
　　　　.MatchWholeWord = False
　　　　.MatchByte = False
　　　　.MatchAllWordForms = False
　　　　.MatchSoundsLike = False
　　　　.MatchFuzzy = False
　　　　.MatchWildcards = True
　　End With
　　Selection.HomeKey Unit:=wdStory
　　With Selection
　　　　.Find.Replacement.ClearFormatting
　　　　Application.ScreenUpdating = False
　　　　Do
　　　　　　.Find.Execute
　　　　　　i = .Range.Start
　　　　　　If i > bi + 1 And bi > 0 Then
　　　　　　　　myStart = myStart & "," & i
　　　　　　ElseIf bi = 0 Then
　　　　　　　　myStart = i
　　　　　　End If
　　　　　　bi = i
　　　　　　.Range.Font.Bold = False
　　　　　　.Range.Font.Italic = False
　　　　　　.Collapse Direction:=wdCollapseEnd
　　　　Loop While .Find.Found = True
　　Application.ScreenUpdating = True
　　End With
　　MsgBox myStart
End Sub

この回答へのお礼

Wendy02様
さっそくのご回答ありがとうございます。
今のマクロは、ＶＢＡというのでしたね！　うっかりしておりました。

さて、ご回答いただいた内容、会社のワード2003で（というのも自宅のワードは９７で、これは離れた場所の選択ができません）ためしてみました。
なるほど、発想の転換ですね。

いま、文書をどんどん修正作業をしていますが、横に並べて、どこを修正したか確認もできるようにしておきたいので、これができれば、大変役に立ちます。
ありがとうございました。

お礼日時：2009/06/23 05:28