Results of 1 - 1 of about 85 for VBA 強制終了 (0.004 sec.)
vba (14736), 強制終了 (237)
- [[20180321131232]]
- #score: 16175
- @digest: c75dc8712cb2a4a9c2405c10d6ebf019
- @id: 75879
- @mdate: 2018-04-11T00:15:39Z
- @size: 36669
- @type: text/plain
- #keywords: 吹出 (91913), autoshapetype (65671), wdactiveendadjustedpagenumber (65413), wdgotoobject (64439), 吹き (54029), activedocument (52621), cfiles (52320), ino (40043), documents (28211), 文書 (23728), wd (20162), doc (19549), word (16931), ir (9674), wk (9091), 図形 (8562), document (8412), shape (7657), shapes (7043), プン (6529), application (6304), ブジ (5493), オブ (5472), き出 (5262), ジェ (5112), visible (4524), ェク (4445), target (4390), クト (3646), 行番 (3455), createobject (3290), ペー (2779)
- 『Excel2010からWord2010中の図形を検索 』（かず）
文書のチェックを行っており エクセルからWord文書を開いて、文書中の「吹き出し」 を調べて、エクセルに一覧表示をしようとしています。 この掲示板で調べるなどして以下のマクロを作成し 自宅環境(Winodws10、Excel2007、 テスト対象の Word文書は メインメニュー 挿入-図形- 四角形吹き出し で吹き出しの中にHello とか適当な文字列を入れています この状態でマクロ実行すると 吹き出しの数だけ 吹き出し、パス、吹き出しの中の文字列、リンクを出力します 一歩 会社環境 Windows7、Excel 2010で同じマクロを実行すると 以下のリストの ★For Each x In ActiveDocument.Shapes の所で shapes.Count が 0となっています 会社でも 参照設定をしてます。Wordのライブラリのバージョンが違うと 思います。 会社の環境のことで、今今は確認できませんが★ の所で ActiveDocument.Shapes.Count がゼロになります。 他の方のソースをまねて ☆ActiveDocument.Range.ShapeRange のように に変えてみましたが、何の図形の情報も取れません 問題の原因がわかりません。 Q1 Word2007 のライブラリを使っているのから? Word2010 の文書中の図形orオブジェクトを検索 しているのまずいのでしょうか? マクロ VBEでツール -参照設定 を見ると Microsoft Word 12.0 Object Library を参照しています。 このマクロを、家の別のPC（ Windows10 Excel2016 ）で 実行すると、最初のPCと同じように動作しました Q2 テストデータ 家 :自分が吹き出しを入れた .docx ファイル3,4個 会社 :すでに存在するデータをコピーして、そこに吹き出し を1個 挿入。 この文書に他に吹き出しはないです 既存のWord文書 20個ほどと合わせて検索しました なぜ会社の環境では、図形を検索できないのか、有識者の方 どうかアドバイスをお願いいたします。 以上 Sub test() Dim doc As Document Dim x As Word.Shape Dim y As Shape Dim wb As Workbook Dim wk As Worksheet Dim cFiles As Variant Dim C As Comment Dim cPath As String Dim cFile As String Dim i As Long Dim j As Long Dim iR As Long Dim w As Variant Dim sh As Worksheet Dim cc As Range Dim r As Range Dim z As Variant Dim flag As Boolean Dim isp As InlineShape Dim msg As String Application.ScreenUpdating = False Application.DisplayAlerts = False Application.ShowWindowsInTaskbar = False Application.EnableEvents = False Set wk = ActiveSheet Cells.Delete iR = 1 wk.Range("A" & iR & ":" & "D" & iR).Value = Array("種類", "パス", "文字列", "リンク") cPath = ThisWorkbook.Path & "¥" cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.doc*""").StdOut().ReadAll(), vbNewLine) For i = 0 To UBound(cFiles) - 1 cFile = Mid(cFiles(i), InStrRev(cFiles(i), "¥") + 1) If Left(cFile, 2) <> "‾$" Then With CreateObject("word.application") '.Visible = True .documents.Open Filename:=cFiles(i), ReadOnly:=True Set doc = ActiveDocument ' アクティブ文書の全Shapeにループを回す For Each x In ActiveDocument.Shapes ' Shapeが吹き出しだったら If ((x.AutoShapeType >= 53 And x.AutoShapeType <= 59) Or _ (x.AutoShapeType >= 105 And x.AutoShapeType <= 124) Or _ x.AutoShapeType = 137) Then iR = iR + 1 wk.Cells(iR, "A").Value = "吹出し" wk.Cells(iR, "B").Value = cFiles(i) wk.Cells(iR, "C").Value = x.TextFrame.TextRange.Text 'wk.Cells(iR, "D").Value = x.Top wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "D"), Address:=cFiles(i), SubAddress:="'" & .Name '& "'!" & x.TopLeft.Address(False, False) wk.Cells(iR, "D").Font.Underline = xlUnderlineStyleSingle wk.Cells(iR, "D").Font.ColorIndex = 5 End If Next x 'For Each isp In doc.InlineShapes ' With isp ' msg = isp.Title & vbTab ' With .Range ' msg = msg & .Information(wdActiveEndAdjustedPageNumber) ' msg = msg & .Information(wdFirstCharacterLineNumber) ' End With ' End With 'Next isp End With End If Next i Columns("A:D").AutoFit Rows("1:" & iR).AutoFit 'ThisWorkbook.Activate Range("B2").Select ActiveWindow.FreezePanes = False ActiveWindow.FreezePanes = True Application.EnableEvents = True Application.ShowWindowsInTaskbar = True Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub ＜ 使用 Excel:Excel2010、使用 OS:Windows7 ＞ ---- 吹き出しを1個挿入したWord文書だけでの動作確認はしていないのでしょうか。 ＞ 会社 :すでに存在するデータをコピーして、そこに吹き出し ＞ を1個 挿入。 この文書に他に吹き出しはないです ＞ 既存のWord文書 20個ほどと合わせて検索しました 図形が挿入されたWORD文書を予め1つだけ開いた状態で 下記のマクロを実行したらどうなりますか。 Sub test1() MsgBox GetObject(, "word.application").activedocument.Shapes.Count End Sub Sub test2() Dim doc As document With GetObject(, "word.application") Set doc = .activedocument MsgBox doc.Shapes.Count End With End Sub （マナ） 2018/03/21(水) 15:22 ---- マナさん アドバイス有難うございます 会社の環境で、1ファイルだけの環境でも実施しましたが だめでした。 思い返してみますと、タスクバーの所に該当するWordファイルの アイコンと言いますかタグと言いますか表示されていたので ファイルはオープンされているけれど、それ毎の処理が なにもされていないものと思います アドバイスの点、頂いたマクロを実行して、activedocument.Shapes.Count が1以上だったら 以下のようにコードを修正してみればいいのでしょうか ・・・ With CreateObject("word.application") '.Visible = True .documents.Open Filename:=cFiles(i), ReadOnly:=True ' 案1 ' Set doc = ActiveDocument ここを以下 ' アクティブ文書の全Shapeにループを回す For Each x In GetObject(, "word.application").activedocument.Shapes ' 案2 With GetObject(, "word.application") Set doc = .activedocument For Each x In doc.Shapes End With Set doc = ActiveDocument のあたりがうまくないかもしれないということ でしょうか。図形の操作など不明の点が多く、こういった事象の回避するために コードの書き方として どういうことに注意すべきか補足頂けると大変助かります よろしくお願いいたします （かず） 2018/03/21(水) 16:32 ---- そうでしたね。 うまくいかないのは、会社のPCですぐには確認できないですね。 ＞1以上だったら 以下のようにコードを修正してみればいいのでしょうか いえいえ。あくまで動作確認のためだけのコードです。 向こうでも書きましたが、 ちゃんと検証できていたのか疑っています。 なので、先入観無しで、 一つずつ確認していこうかと考えていました。 もし、今のコードで動作確認するなら .Visible = True にして、ステップ実行してみてはどうでしょうか。 あと、本題とは関係ないですが、 ＞CreateObject("word.application") は、1回でよいと思います。 ＞Set doc = ActiveDocument 変数docが、有効に使われていません。 文書、アプリケーションが開きっぱなしなのも気になります。 というようなことを考えると、エクセル使わなくても ワードに結果を書き出せばいいのにと思ったりします。 （マナ） 2018/03/21(水) 20:10 ---- オブジェクトがごちゃごちゃしているのと、閉じずに終わるのはまずいので、その辺りを整形してみた例なぞ。 Sub test() Dim WD As Object Dim doc As Object Dim x As Object Dim y As Shape Dim wb As Workbook Dim wk As Worksheet Dim cFiles As Variant Dim C As Comment Dim cPath As String Dim cFile As String Dim i As Long Dim j As Long Dim iR As Long Application.ScreenUpdating = False Application.DisplayAlerts = False Application.ShowWindowsInTaskbar = False Application.EnableEvents = False Set WD = CreateObject("Word.Application") 'WD.Visible = True Set wk = ActiveSheet wk.Cells.Delete iR = 1 wk.Range("A" & iR & ":" & "D" & iR).Value = Array("種類", "パス", "文字列", "リンク") cPath = ThisWorkbook.Path & "¥" cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.doc*""").StdOut().ReadAll(), vbNewLine) For i = 0 To UBound(cFiles) - 1 cFile = Mid(cFiles(i), InStrRev(cFiles(i), "¥") + 1) If Left(cFile, 2) <> "‾$" Then Set doc = WD.documents.Open(Filename:=cFiles(i), ReadOnly:=True) ' アクティブ文書の全Shapeにループを回す For Each x In doc.Shapes ' Shapeが吹き出しだったら If ((x.AutoShapeType >= 53 And x.AutoShapeType <= 59) Or _ (x.AutoShapeType >= 105 And x.AutoShapeType <= 124) Or _ x.AutoShapeType = 137) Then iR = iR + 1 wk.Cells(iR, "A").Value = "吹出し" wk.Cells(iR, "B").Value = cFiles(i) wk.Cells(iR, "C").Value = x.TextFrame.TextRange.Text wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "D"), Address:=cFiles(i), SubAddress:="", TextToDisplay:=doc.Name wk.Cells(iR, "D").Font.Underline = xlUnderlineStyleSingle wk.Cells(iR, "D").Font.ColorIndex = 5 End If Next x doc.Close End If Next i WD.Quit Set doc = Nothing Set WD = Nothing 'ThisWorkbook.Activate Columns("A:A").AutoFit Columns("B:B").ColumnWidth = 4 Columns("C:D").AutoFit Rows("1:" & iR).AutoFit Range("B2").Select ActiveWindow.FreezePanes = False ActiveWindow.FreezePanes = True Application.EnableEvents = True Application.ShowWindowsInTaskbar = True Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub （???） 2018/03/22(木) 11:05 ---- おまけ。コメントアウトした部分でページ位置と行位置を見ようとしているようなので、以下を追記してみてください。（レイトバインドでコーディングしているので、Word VBAの定数が使えないので、独自に定数宣言してます） Const wdActiveEndAdjustedPageNumber = 1 Const wdFirstCharacterLineNumber = 10 wk.Cells(iR, "E").Value = x.Anchor.Information(wdActiveEndAdjustedPageNumber) wk.Cells(iR, "F").Value = x.Anchor.Information(wdFirstCharacterLineNumber) （???） 2018/03/22(木) 11:43 ---- ???さん、マナさん 時間が空いてしまい申し訳ありません ご指摘頂いた点を修正して、家のWindows10 Excel2007 環境で試したところ以下のようになります 1.吹き出しなどの図形の表示位置が不明 (1)同じページに「吹出し」※を複数含むWord文書 ※挿入リボン-図形- 吹き出し→ 四角形吹きだし or 、角丸四角形吹き出し (2)複数の吹き出しを含むWord文書 (3)ページの余白部分に吹き出しの角が位置するWord文書 をデータとしてマクロを実行すると以下の結果となります Q1 同じページに位置する 複数の吹出しについて 出力例 種類 パス ページ 行番号 文字列 吹出し 略 1 1 おはよう 吹出し 略 1 1 こんにちは 吹出し 略 2 1 こんばんは 吹出し 略 2 1 あいうえお ・・・ となって同じページにある複数の吹き出しの行番号がみな1になってしまい 図形の位置を 行番号で表現できない状態です。 調べきれていませんがWordでは図形がアンカー?やブックマーク?というオブ ジェクト?に対して紐づけられるらしいので複数の吹き出しが同じ何かに対応して いてその行番号を表示しているのではと考えています。ご存知の点がああればご 教示頂けると助かります。 ちなみに インストラクターのネタ帳 http://www.relief.jp/docs/018015.html によると wdActiveEndAdjustedPageNumber 指定範囲の、終了位置のページ番号を取得します。 開始ページ番号を設定したり、手動で調整したりした場合、 変更後のページ番号を取得します。 wdActiveEndPageNumber 指定範囲の、終了位置のページ番号を文書の先頭から数えて 取得します。 ページ番号を手動で調整した結果は廃棄されます。 とあり、wdActiveEndAdjustedPageNumber を wdActiveEndPageNumberに変えてみても特に結果がかわりませんでした。 WordをVBAで操作する上での上記定数の使い分けについての自分が理解できる 情報が見つからず上の2つの定義で 指定範囲 とは 手で操作する場合だけで マクロで For Each x In doc.Shapes など形で操作する場合は含まないのではないか と思いますが不明です Q2 複数の図形を含むWord文書をに対しマクロを実行すると、同じ図形が複数 処理される 出力例 種類 パス ページ 行番号 文字列 吹出し 略 1 1 ABCDE 吹出し 略 2 1 こんにちは 吹出し 略 3 1 こんばんは 吹出し 略 1 1 ABCDE ・・・ 上の例のように既に処理したはずの1ページ目1行の「ABCDE」を 再度処理している。どうしてこのようなことになるのか For Eachの所で、全体でshapeがいくつあるのかどういう順番で処理 されるか 1ステップずつ実行して確認してみようと思います お気づきの点があればご教示頂けると助かります。 (3)(1)のように行番号の意味が不明なため、吹き出しの位置を一番下に移動 させて、余白の位置に吹き出しの角があるような状況では ペー行番号が31となった。注 このときWord文書の行は35行に なっている。毎行 1行目の先頭に1、2行目の先頭に2、というように 行数を示す番号を実際に手入力している。 尚、(1)で示したようにすべの図形の行番号が常に1と言うわけではなく 図形の作り方ななおか ページ番号5という中途半端な行番号が表示される 場合もあります 結局(1) と根本原因が一緒かもしれないと思っています お気づきの点があればご教示頂けると助かります。 Q4 Word文書をオープンするとき読み取り専用で Set doc = WD.documents.Open(Filename:=cFiles(i), ReadOnly:=True) のように開いています。 サブフォルダの下のファイルまで再帰的に処理するので読み取り専用に しているつもりですが、たまに?またはいろいろ問題解決のためにソース 変えてテストのためにマクロを実行を繰り返す際、ダイアログが 開いてWord文書を開くときのモードの選択を促されます。いつも発生する わけではなく原因が不明です。 これは 何らかの理由でマクロ処理を中断した際、たまたま書き込み可能で オープンしていて、それで開いたままの文書に、再度読み取り専用でマクロ を実行すると発生する事象でしょうか? お気づきの点があればご教示頂けると大変助かります ---現状のソース--- Sub test() Dim wd As Word.Application Dim doc As Document Dim x As Word.Shape 'Dim y As Shape Dim wb As Workbook Dim wk As Worksheet Dim cFiles As Variant Dim cPath As String Dim cFile As String Dim i As Long Dim j As Long Dim P As Long Dim L As Long Dim iR As Long Dim sh As Worksheet Const wdActiveEndAdjustedPageNumber = 1 Const wdFirstCharacterLineNumber = 10 Application.ScreenUpdating = False Application.DisplayAlerts = False Application.ShowWindowsInTaskbar = False Application.EnableEvents = False Set wk = ActiveSheet Cells.Delete iR = 1 wk.Range("A" & iR & ":" & "E" & iR).Value = Array("種類", "パス", "ページ", "行番号", "文字列", "リンク") cPath = ThisWorkbook.Path & "¥" cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.doc*""").StdOut().ReadAll(), vbNewLine) Set wd = CreateObject("word.application") For i = 0 To UBound(cFiles) - 1 cFile = Mid(cFiles(i), InStrRev(cFiles(i), "¥") + 1) If Left(cFile, 2) <> "‾$" Then '.Visible = True Set doc = wd.documents.Open(cFiles(i), False) 'Set doc = ActiveDocument ' アクティブ文書の全Shapeにループを回す For Each x In doc.Shapes x.Select ' Shapeが吹き出しだったら If ((x.AutoShapeType >= 53 And x.AutoShapeType <= 59) Or _ (x.AutoShapeType >= 105 And x.AutoShapeType <= 124) Or _ x.AutoShapeType = 137) Then iR = iR + 1 wk.Cells(iR, "A").Value = "吹出し" wk.Cells(iR, "B").Value = cFiles(i) wk.Cells(iR, "C").Value = x.Anchor.Information(wdActiveEndAdjustedPageNumber) wk.Cells(iR, "D").Value = x.Anchor.Information(wdFirstCharacterLineNumber) wk.Cells(iR, "E").Value = x.TextFrame.TextRange.Text wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "F"), Address:=cFiles(i), SubAddress:=x.TextFrame.TextRange.Text ' & x.TopLeft.Address(False, False) wk.Cells(iR, "F").Font.Underline = xlUnderlineStyleSingle wk.Cells(iR, "F").Font.ColorIndex = 5 End If Next x End If Next i Cells.Columns.AutoFit wd.Quit Set wd = Nothing Set doc = Nothing 'ThisWorkbook.Activate Range("B2").Select ActiveWindow.FreezePanes = False ActiveWindow.FreezePanes = True Application.EnableEvents = True Application.ShowWindowsInTaskbar = True Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub （かず） 2018/03/27(火) 02:00 ---- Wordって、Excelとは違い、行の考え方が必須ではないのですよ。だからページ内に明確に改行と連動するオブジェクトを使っていないと、1になってしまうかと…。吹き出し図形を、座標指定で置いている感じなのです。（だから、ハイパーリンクではページや行に飛べない） もし、抽出された行をクリックすることでWordの該当箇所に飛ぶ機能を考えているならば、ハイパーリンクを使わず、例えば右クリックするとdocを開いて該当ページに飛ぶようなコードにするのが良いと思います。（ハイパーリンクのようにWord自身の機能で飛ぶのではなく、Excel側からWordオブジェクトを操作して、Goto命令でwdGoToPage指定でページジャンプさせる） 同様に、wdGoToObject という指定もあるのでオブジェクトにジャンプできそうに思うのですが、ちょっと試してみたけど駄目でした。 そして、中断させたときの動きですが、中断ということはWordオブジェクトを開きっぱなしにしていると思いますので、同一ファイルを開こうとしているのでは? Visible が False だと、動かしっぱなしでも見えないので、中断した場合はタスクマネージャで、WinWord のプロセスが残っていないか確認しましょう。（Excelマクロ側ではオブジェクトを手放しているだろうから、残っていたら強制終了!） （???） 2018/03/27(火) 09:28 ---- ???さん マナさん 時間があいてしまいましたが、以下を改善or検討しています (1)吹き出し類を取り出す際、 Set doc = wd.documents.Open(cFiles(i), False) For Each x In doc.Shapes とすると、吹き出しを作成した順序で処理されるようです つまり、文書内のある吹出し図形(仮に上から20行目に存在) コピーして、その吹き出しより前の位置(仮に10行目)にコピ ーすると、For each x in shpes でxを処理される順番は 20行目にある吹き出しを処理 10行目にある吹き出しを処理 となります 上から順番に処理させたい場合は For each ループを For Each x In doc.Range.ShapeRange とすることで実現できました。 参考 Range オブジェクトを使用す (Wordでの Rangeオブジェクトの意味理解を 理解するのに参考になります) http://makoto-watanabe.main.jp/WordVba_style.html#UseRange (2)出力の際、wdGoToObjectを使って 吹き出しジャンプするのはできていません いろいろなサイトを調べたのですが よいサンプルを見つけられていません。 そもそも ハイパーリンクする wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "F") の所を wdGoToObjectにするわけにはいかない と思っています。吹き出しに飛ばす方法あれば 教えてください。 (3)Word文書のヘッダーとして吹き出しなどを 使用していて、それはリストアップから 除外したい場合は、以下ロジックが参考に になりそうです ヘッダー内の行内オブジェクトをすべて削除するサンプルマクロ ヘッダー内の行内オブジェクト（InlineShapeオブジェクト）を すべて削除するのなら、以下のマクロが有用そうです。 --- サンプルマクロ --- Sub ヘッダーのInlineShapeをすべて削除する() Dim sec As Section Dim hdr As HeaderFooter Dim isp As InlineShape For Each sec In ActiveDocument.Sections For Each hdr In sec.Headers For Each isp In hdr.Range.InlineShapes isp.Delete Next isp Next hdr Next sec End Sub ---現状のソース---- Sub test() Dim wd As Word.Application Dim doc As Document Dim x As Word.Shape 'Dim y As Shape Dim wb As Workbook Dim wk As Worksheet Dim cFiles As Variant Dim cPath As String Dim cFile As String Dim i As Long Dim j As Long Dim P As Long Dim L As Long Dim iR As Long Dim sh As Worksheet Const wdActiveEndAdjustedPageNumber = 1 Const wdFirstCharacterLineNumber = 10 Application.ScreenUpdating = False Application.DisplayAlerts = False Application.ShowWindowsInTaskbar = False Application.EnableEvents = False Set wk = ActiveSheet Cells.Delete iR = 1 wk.Range("A" & iR & ":" & "E" & iR).Value = Array("種類", "パス", "ページ", "行番号", "文字列", "リンク") cPath = ThisWorkbook.Path & "¥" cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.doc*""").StdOut().ReadAll(), vbNewLine) Set wd = CreateObject("word.application") For i = 0 To UBound(cFiles) - 1 cFile = Mid(cFiles(i), InStrRev(cFiles(i), "¥") + 1) If Left(cFile, 2) <> "‾$" Then '.Visible = True Set doc = wd.documents.Open(cFiles(i), False) ' アクティブ文書の全Shapeにループを回す For Each x In doc.Range.ShapeRange 'For Each x In doc.Shapes 'x.Select ' Shapeが吹き出しだったら If ((x.AutoShapeType >= 53 And x.AutoShapeType <= 59) Or _ (x.AutoShapeType >= 105 And x.AutoShapeType <= 124) Or _ x.AutoShapeType = 137) Then iR = iR + 1 wk.Cells(iR, "A").Value = "吹出し" wk.Cells(iR, "B").Value = cFiles(i) wk.Cells(iR, "C").Value = x.Anchor.Information(wdActiveEndAdjustedPageNumber) wk.Cells(iR, "D").Value = x.Anchor.Information(wdFirstCharacterLineNumber) wk.Cells(iR, "E").Value = x.TextFrame.TextRange.Text wk.Hyperlinks.Add Anchor:=wk.Cells(iR, "F"), Address:=cFiles(i), SubAddress:=x.TextFrame.TextRange.Text ' & x.TopLeft.Address(False, False) wk.Cells(iR, "F").Font.Underline = xlUnderlineStyleSingle wk.Cells(iR, "F").Font.ColorIndex = 5 End If Next x doc.Close End If Next i Cells.Columns.AutoFit wd.Quit Set wd = Nothing Set doc = Nothing 'ThisWorkbook.Activate Range("B2").Select ActiveWindow.FreezePanes = False ActiveWindow.FreezePanes = True Application.EnableEvents = True Application.ShowWindowsInTaskbar = True Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub kazu （かず） 2018/04/03(火) 00:21 ---- ハイパーリンクでは駄目でしょう。Word内手操作でもできないですし。 なので、例えばシートモジュールに以下を貼ってから、文字列の入ったE列を右クリックしてみてください。これでページジャンプまでは実現できます。 （ただし、手抜きしているので、Wordはこの参照用の1つしか開かない前提でコーディングしています。WD.Documents内まで調べるようにすれば、汎用性が上がるでしょう） Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Const wdGoToPage = 1 Const wdGoToAbsolute = 1 Dim WD As Object If Target.Count <> 1 Then Exit Sub If Target.Value = "" Then Exit Sub If Target.Column <> 5 Then Exit Sub If Dir(Target.Offset(0, -3).Value) <> "" Then On Error Resume Next Set WD = GetObject(, "Word.Application") On Error GoTo 0 If WD Is Nothing Then Set WD = CreateObject("Word.Application") WD.Visible = True WD.Documents.Open Target.Offset(0, -3).Value End If WD.Documents.Application.Selection.Goto what:=wdGoToPage, Which:=wdGoToAbsolute, Count:=Target.Offset(0, -2).Value WD.Activate End If Cancel = True End Sub wdGoToPageの代わりに、wdGoToObject(=9)を使えば、Wordマクロなら吹き出しに飛ぶ事ができましたが、Excelマクロからだとうまくいきませんでした。 オブジェクト名は、一覧を作る際に x.Name を書き出しておけば判りますので、これをヒントに頑張ってみてください。 （???） 2018/04/03(火) 11:15 ---- その後、右クリック処理を見直してみました。 もしかすると無駄な処理をしているかも知れませんが、まぁ試してみてください。 まず、元の一覧作成マクロに、以下の1行を追加しておきます。 wk.Cells(iR, "G").Value = x.Name 右クリック用は、以下。 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Const wdGoToObject = 9 Dim WD As Object Dim iNo As Long If Target.Count <> 1 Then Exit Sub If Target.Value = "" Then Exit Sub If Target.Column <> 5 Then Exit Sub If Dir(Target.Offset(0, -3).Value) <> "" Then On Error Resume Next Set WD = GetObject(, "Word.Application") On Error GoTo 0 If WD Is Nothing Then Set WD = CreateObject("Word.Application") WD.Visible = True WD.Documents.Open Target.Offset(0, -3).Value iNo = 1 Else For iNo = 1 To WD.Documents.Count If WD.Documents(iNo).FullName = Target.Offset(0, -3).Value Then Exit For End If Next iNo End If WD.Documents(iNo).Shapes(Target.Offset(0, 2).Value).Select WD.Documents.Application.Selection.Goto what:=wdGoToObject, Name:=Target.Offset(0, 2).Value WD.Activate End If Cancel = True End Sub （???） 2018/04/03(火) 18:55 ---- ???さん 有難うございます。 複数のWordファイルを入力として マクロ実行すると WD.Documents(iNo).Shapes(Target.Offset(0, 2).Value).Select WD.Documents.Application.Selection.Goto what:=wdGoToObject, Name:=Target.Offset(0, 2).Value WD.Activate の1行目でWordファイルが1つ開いている状態で iNoが2となって 異常終了となうケースがありテストです。 以上 （かず） 2018/04/04(水) 01:04 ---- それは、「手抜きしているので、Wordはこの参照用の1つしか開かない前提」と書いた部分なのです。Wordが生きているかどうかで新しいWordを開くか決めているので、目的のdocではない別のWordがある（吹き出し参照用ではないWordが開かれている）と、誤動作するのです。デバッグし修正するのが面倒だし、Word上の吹き出しにジャンプできる事を見せるのが目的だったので、そこは軽く注意書きだけして、ご自身でデバッグして直して頂きたかった。 とりあえず、既にWordが開かれていた場合の処理を、以下のように直せば動くでしょう。ただし、後から開いたDocが必ず1番になるかは深く試していないので、もし必ず1ではない場合があるようならば、開いたDocが何番目になっているか探す処理を追加してください。 For iNo = 1 To WD.Documents.Count If WD.Documents(iNo).FullName = Target.Offset(0, -3).Value Then Exit For End If Next iNo If WD.Documents.Count < iNo Then WD.Documents.Open Target.Offset(0, -3).Value iNo = 1 End If （???） 2018/04/04(水) 09:26 ---- ???さん たびたび有難うございます。 頂いたコメント元に以下をシートモジュールに記述しました。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Const wdGoToObject = 9 Dim WD As Object Dim iNo As Long If Target.Count <> 1 Then Exit Sub If Target.Value = "" Then Exit Sub If Target.Column <> 5 Then Exit Sub If Dir(Target.Offset(0, -3).Value) <> "" Then On Error Resume Next Set WD = GetObject(, "Word.Application") On Error GoTo 0 ' Wordのインスタンスが存在するか判定し ' 開いていない場合Wordを起動し、右クリックしたセル 'の左のパスに記載されたファイルをオープンする If WD Is Nothing Then Set WD = CreateObject("Word.Application") WD.Visible = True WD.Documents.Open Target.Offset(0, -3).Value iNo = 1 Else '既にWordが開いていた場合 'Target ファイルと 既に開いた文書と同じか文書の数だけ比較する '同じだったらすでに開いているのでオープンしなくてよい 'その場合 iNo<=WD.Document.Count '既オープン文書のどれとも違っていたらiNo>WD.Document.Countとなりその場合オープンする For iNo = 1 To WD.Documents.Count If WD.Documents(iNo).FullName = Target.Offset(0, -3).Value Then Exit For End If Next iNo ' 既に開かれている文書の数 '★ If WD.Documents.Count < iNo Then WD.Documents.Open Target.Offset(0, -3).Value iNo = 1 End If End If ' 文書をオープン済にしておいてオブジェクトに飛ばす ' 新しくオープンした場合WD.Document(iNo) インデックス番号 ' Document(インデックス) の場合=インデックス番号（開いた順番）で指定 ' https://kosapi.com/post-3986/#Documents '☆ WD.Documents(iNo).Shapes(Target.Offset(0, 2).Value).Select WD.Documents.Application.Selection.Goto what:=wdGoToObject, Name:=Target.Offset(0, 2).Value WD.Activate End If Cancel = True End Sub 尚、、E列のセルから右クリックで図形にジャンプさせる イベント処理は、右クリックの代わりにダブルクリックに変更 しました。 この状態でWindows10、Excel2007 でいくつかのパターンで テスト中です。今の所は問題なしです ・マクロ実行前に複数2個のマクロが開かないWord文書を起動 しておいてマクロを実行、その後ダブルクリックでさらにWordを 起動→図形にフォーカスします ・なお、オブジェクト.Documents([Index]) の(引数)の説明は いかを見つけました https://kosapi.com/post-3986/#Documents Index【インデックス】（省略可） 参照するWord文書名を拡張子を付けて文字列で指定 または、インデックス番号（開いた順番）で指定します。 確かに2、3回のテストでは、先に別のWordが起動しているので WD.Document.Countが2になっていて ★の所の If WD.Documents.Count < iNo Then WD.Documents.Open Target.Offset(0, -3).Value iNo = 1 End If ☆の所でiNo は1になっています。 「ただし、後から開いたDocが必ず1番になるかは深く試していないので、 もし必ず1ではない場合があるようならば、開いたDocが何番目になって いるか探す処理を追加してください。 」 ご指摘の件の注意の必要性が今一つ理解できていないので お手数ですが補足説明頂けると大変助かります 以上 （かず） 2018/04/06(金) 06:36 ---- WDはワードオブジェクトであり、MS-Wordです。とはいえ、Excel2010と違ってWord2010はSDIアプリなので、GetObjectで既にWordが起動済みならば、これを得る事ができます。 得られないとエラーになるのですが、そこをOn Error で隠しています。 WDが得られたとして、複数のWordがそれぞれ開いているドキュメントは、Documentsプロパティに格納されています。例えば、手動でMS-Wordを2つ新規起動するとどうなるか、実験してみてください。 まず、1つ目を起動した段階では WD.Documents.Count = 1 であり、WD.Documents(1).Name = "文書 1" が得られます。 次に2つ目を新規起動すると、WD.Documents.Count = 2 になる訳ですが、WD.Documents(1).Name = "文書 2"、WD.Documents(2).Name = "文書 1" のように、後から開いた方が1番目になります。 ここまで確認した段階で、私は後から追加で開いたドキュメントを、iNo = 1 とした訳です。 しかしながら、複数起動した後にどれかを閉じて、また新しいドキュメントを開いて、という確認までは行っていないので、そういう運用をされると追加で開いたものが1番でない場合があるのかも?、という可能性を懸念したのです。 また、普通にWord2010のアイコンをダブルクリックすると、空の文書が開いた状態になりますが、CreateObjectした場合はWordは起動しても、ブックは開いていない状態になります。 この場合は、WD.Documents.Count は増えません。 こういうのが混在するとどうなるかなぁ?、とかまでは思いつきました。 他にも、ドキュメントをクリックしてアクティブにすると変わるのか?、とか。 最初から、新しいドキュメントを追加した後で、開いたファイル名を探すコードを書けば確実ですが、それは直前のコードで全く同じ事をやっているので、格好悪いなぁ、と感じました。 そして、追加分は必ず1なのならば、ループしてまで探すのも無駄ですし。 「必ず」なのかどうかまでは、調べていない、という事です。 ちなみに、ExcelからWord内のオブジェクトへの移動とか、Webを調べても、良い情報は得られなかったと思います。 外部オブジェクトの操作は、他人の情報よりも、自分で試行錯誤してみる事が大事です。 マクロの編集画面で、ローカルウィンドウを開いたり、ウォッチ式を使って、オブジェクト変数内のツリーを追ってみるのも有効ですよ。 （???） 2018/04/06(金) 09:53 ---- ???さん 間が空いてすいません。 マクロを実行してリストを作成した後 ・Wordのアイコンをダブルクリックし空の文書を作る ・データのある文書と混在させた状態でE列をダブルクリック しイベントを発生させてみました。 WD.Documents.Count は空の文書の文もカウントしました 特に問題ではないのですが、マクロ本体の動作で wk.Cells(iR, "G").Value = x.Name としてG列に、見つけた図形の名前を書き出していますが AutoShape 2 AutoShape 19 ・・・ という感じになりユニークにはなっていて図形を特定できる けれすべてAutoShape NNなので利用する人にとっても少し 改善したいなと思いました x.Name → x.Alternative.Textとすると、例えば 四角形吹き出し おはよう 雲形吹き出し こんばんは ・・・ と言う風に、吹き出しの形+吹き出しの中に書いた文言とな るので、わかりやすい と思いましたが シートモジュールに書くロジックの最後の所 WD.Documents(iNo).Shapes(Target.Offset(0, 2).Value).Select で Shapes(Target.Offset(0, 2) の所が Shapesを一意に決めきれない のでだめなようです parent とかのプロパティでオブジェクトの階層をさかのぼって 図形の特定がし易くなる方法についてご存じあれば押しえてください。 以上 何かできる すべて （かず） 2018/04/11(水) 01:42 ---- 親オブジェクトから日本人が理解しやすい文字列を得るのは無理と思いますよ。 それが可能なのは、例えば図形の名前を付ける（普通は勝手に命名されるだけなので、マクロでボタンを押すと吹き出しが貼られるようにする）とか、グループ化して名前を付けるとかしないといけなくなり、可用性が落ちます。しかも、吹き出しを貼っているのはWordですから、Wordマクロになりますし、手作業で普通の吹き出しを貼られてしまうと駄目ですし。 オブジェクト名は人間が見ても意味ないので、シートに抜き出すだけにして、列を隠してしまっても良いでしょう。そして、ダブルクリックさせるのは表示する文字列にすれば良いですし。（全く同じ文字列だと区別付かないですが、仕方なし…。文字列先頭に必ず丸数字を付けるとか工夫する余地はありますが） そして、少し判りやすくする、凄く難しい案ならあります。 図形オブジェクトを得られるのだから、吹き出しの位置やサイズ、色なんかも判ります。 これを元に、Excelシート上に図形だけで文字を消した、小さめのページレイアウトを作成。文字列をダブルクリックなり右クリックすると、対象の図形の色を変えるとか点滅させて強調するのです。 かなりコーディングが大変な割に、有効じゃないかもですけどね。 （???） 2018/04/11(水) 09:15... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201803/20180321131232.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97057 documents and 608292 words.
訪問者：