| |
こんにちは
>例えば，開くExcelﾌﾞｯｸ名を間違えてセルに記入した場合，当然，エラーが出るの
>ですが，これを正しく修正
問題はこちらの部分で、存在しないファイ名だった場合や、全く対象でないファイルを
指定してしまった時に、きちんとマクロを終わらせるようにして下さいという意味の
コードを前回は提示しました。
エラーで強制終了したままですとWordのインスタンス等が残ってる場合が発生するかも
知れません。
下記のような感じで試してエラーの際にどのようなエラーメッセージが表示されるのか
提示して下さい。
またその時のイミディエイトウィンドウの「TEXT_LEFT」及び「TEXT_TOP」の値が
どうなっているのか調べて下さい。
Sub CopyPasteWord_1()
Dim objWord As Object
Dim objDoc As Object
Dim WkBook As Workbook
Dim WkSht As Worksheet
Dim BOOK As String
Dim wordfilename As Variant
Dim OPENBOOK As String
BOOK = ThisWorkbook.Sheets(1).Cells(12, 2)
OPENBOOK = ThisWorkbook.Path & "\" & BOOK & ".xls"
If Len(Dir(OPENBOOK)) = 0 Then Exit Sub
With Application
.AskToUpdateLinks = False
.DisplayAlerts = False
Set WkBook = Workbooks.Open(OPENBOOK)
wordfilename = Application.GetOpenFilename _
(Title:="ファイルを開く", _
FileFilter:="Word 文書(*.doc),*doc")
'事情によりWordだけGetOpenFilenameメソッドを利用しています
If VarType(wordfilename) = vbBoolean Then
WkBook.Close False
Set WkBook = Nothing
Exit Sub
End If
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If objWord Is Nothing Then
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.documents.Open(wordfilename)
Else
Set objDoc = GetObject(wordfilename)
End If
On Error GoTo 0
With objWord
.Visible = True
.WindowState = 1 'wdWindowStateMaximize
End With
Set WkSht = WkBook.Worksheets(1)
'コードは省略します。
'ここでExcelからWordにCopyPaste
With objWord.Selection
.ParagraphFormat.Alignment = wdAlignParagraphLeft
With .Font
.Size = 12
.Name = "ＭＳ ゴシック"
End With
.PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
Placement:=wdFloatOverText, DisplayAsIcon:=False
.ShapeRange.RelativeHorizontalPosition = _
wdRelativeHorizontalPositionMargin
.ShapeRange.RelativeVerticalPosition = _
wdRelativeVerticalPositionMargin
.ShapeRange.ScaleWidth TEXT_SIZE, True
'TEXT_SIZEはセルから取得しています。
.ShapeRange.ScaleHeight TEXT_SIZE, True
Debug.Print "TEXT_LEFT=" & TEXT_LEFT & " :: TEXT_TOP=" & TEXT_TOP
If TEXT_LEFT <> "" Then
.ShapeRange.Left = MillimetersToPoints(TEXT_LEFT)
'TEXT_LEFTもセルから取得しています。
.ShapeRange.Top = MillimetersToPoints(TEXT_TOP)
'TEXT_TOPもセルから取得しています。
End If
.MoveLeft
End With
'コードは省略します。
objDoc.Close
If objWord.document.Count = 0 Then
objWord.Quit
End If
WkBook.Close
.DisplayAlerts = True
.AskToUpdateLinks = True
End With
Set objWord = Nothing
Set objDoc = Nothing
Set WkBook = Nothing
Set WkSht = Nothing
End Sub
|
|
ウッシ
- 07/4/6(金) 15:24 -
