単語内からコピーして貼り付ける絵として名前を付ける範囲

Question

単語用のコマンドボタンをコーディングしています。ボタン（ワードドキュメント内）は、Excelワークブックのファイル名を指定するためのダイアログを呼び出し、名前付き範囲をコピーして絵としてワードに戻す必要があります。コピー＆ペーストの部分はかなり簡単ですが、ファイル名のダイアログが表示されません。 、試行錯誤の多くはかなり私が見つけたすべての例がない（可能な限りそれをクリーンアップしようとしたこれまでのダイアログ

私のコードから、コード内のExcelファイル名を指定し

がありましたWordのVBAで）

Sub CRA_copy() 

Dim oXL As Excel.Application 
Dim oWB As Excel.Workbook 
Dim oSheet As Excel.Worksheet 
Dim oRng As Excel.Range 
Dim ExcelWasNotRunning As Boolean 
Dim WorkbookToWorkOn As String 
Dim dlgOpen As FileDialog 
Dim crabook As String 

oName = ActiveDocument.Name 

'If Excel is running, get a handle on it; otherwise start a new instance of Excel 
On Error Resume Next 
Set oXL = GetObject(, "Excel.Application") 

If Err Then 
    ExcelWasNotRunning = True 
    Set oXL = New Excel.Application 
End If 

On Error GoTo Err_Handler 

'Open the workbook  
crabook = Application.GetOpenFilename(_ 
     filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=False) 

'Process each of the spreadsheets in the workbook 
oXL.ActiveWorkbook.Range("CRA").Copy 

If ExcelWasNotRunning Then 
    oXL.Quit 
End If 

oName.Activate 

Selection.EndKey Unit:=wdStory 
Document.InsertBreak Type:=wdPageBreak 

Selection.Paste 
'Make sure you release object references. 
Set oRng = Nothing 
Set oSheet = Nothing 
Set oWB = Nothing 
Set oXL = Nothing 

'quit 
Exit Sub 

Err_Handler: 
    MsgBox WorkbookToWorkOn & " caused a problem. " & Err.Description, vbCritical, _ 
    "Error: " & Err.Number 
If ExcelWasNotRunning Then 
    oXL.Quit 
End If 

End Sub 

Answer 1

ExcelのApplication.GetOpenFilenameに相当Application.FileDialogです。

以下のコードを試してみてください。

Set dlgOpen = Application.FileDialog(msoFileDialogFilePicker) 

' modify the FileDialog settings 
With dlgOpen 
    'Add a filter that includes .xl* (.xls, .xlsx, .xlsm) 
    .Filters.Add "Excel Files (*.xl*)", "*.xl*" 
    .AllowMultiSelect = False 
    .Show 

    crabook = .SelectedItems(1) 
End With