Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


33776 / 76738 ←次へ | 前へ→

【48178】Re:開くファイルの制御
発言  tomo  - 07/4/6(金) 19:18 -

引用なし
パスワード
   ▼ウッシ さん:

「実行時エラー '462'
 リモートサーバがないか、使用できる状態ではありません。」

とメッセージが出ます。

TEXT_LEFT = Cells(7, 5) = 8
TEXT_TOP = Cells(7, 6) = 20
であり,イミディエイトウィンドウには
「TEXT_LEFT=8 :: TEXT_TOP=20」と表示されています。
値としては問題ないのですが・・・

Forスーテトメントで繰り返し作業を行っている影響なのでしょうか?
長くなってしまいますが,全文を記載します。
大変ご面倒をおかけしますが,よろしくお願いします。

Option Explicit
  Dim objWord As Object, objWordDoc As Object
  Dim WkSht As Worksheet
  Dim WkBk As Workbook
  Dim myPath As String, MACROBOOK As String, BOOK As String, _
    FName As String, WordFileName As String, SHT As String, _
    OPENBOOK As String
  Dim Judge As Integer, SectNum As Integer, myCount As Integer, _
    SCT As Integer, TEXT_LEFT As Integer, TEXT_TOP As Integer, _
    TEXT_SIZE As Integer
  Dim i As Integer, j As Integer, n As Integer
  Dim RNG As Variant
  
Sub CopyPasteWordGeneral()
  i = 1
  n = 6
'
'-------------------------------------------------
'  Wordファイルを開く
'-------------------------------------------------
'
  Set WkSht = ThisWorkbook.Sheets("MENU")
  With Application
    .AskToUpdateLinks = False
    .DisplayAlerts = False
  End With 'Application
  WkSht.Activate
  Judge = WorksheetFunction.CountIf(Range("A:A"), 1)
  SectNum = WorksheetFunction.Max(Range("D:D"))
  WordFileName = Application.GetOpenFilename _
        (Title:="ファイルを開く", _
         FileFilter:="Word 文書(*.doc),*doc")
  If VarType(WordFileName) = vbBoolean Then Exit Sub
  On Error Resume Next
  Set objWord = GetObject(, "Word.Application")
  If objWord Is Nothing Then
    Set objWord = CreateObject("Word.Application")
    Set objWordDoc = objWord.Documents.Open(WordFileName)
  Else
    Set objWordDoc = GetObject(WordFileName)
  End If
  On Error GoTo 0
  With objWord
    .Visible = True 'Wordの表示
    .WindowState = 1 'wdWindowStateMaximize, 表示最大化
  End With 'objWord
'
'-------------------------------------------------
'  コピー&ペースト
'-------------------------------------------------
'
  With WkSht
    For j = 1 To Judge
      If .Cells(i + n, 1) = "end" Then Exit Sub
      If .Cells(i + n, 8) = "" Then
        j = j - 1
        GoTo KAIGYO
      End If
      If .Cells(i + n, 1) = 1 Then
        If .Cells(i + n, 2) <> "" Then
          FName = .Cells(i + n, 2)
          BOOK = FName
          OPENBOOK = ThisWorkbook.Path + "\" + BOOK
          Workbooks.Open OPENBOOK
          If Len(Dir(OPENBOOK)) = 0 Then
            MsgBox "ファイルが見つかりません!"
            Exit Sub
          End If
        Else
          BOOK = FName
        End If
        SHT = .Cells(i + n, 3)      ' シート名称
        SCT = .Cells(i + n, 4)      ' セクション番号
        TEXT_LEFT = .Cells(i + n, 5)   ' 余白横
        TEXT_TOP = .Cells(i + n, 6)    ' 余白縦
        TEXT_SIZE = .Cells(i + n, 7)   ' スケースサイズ
        RNG = .Cells(i + n, 8)      ' セル範囲
        Set WkBk = Workbooks(BOOK)
        With WkBk
          If RNG = 1 Then
            .Charts(SHT).ChartArea.Copy
          Else
            .Worksheets(SHT).Range(RNG).Copy
          End If
        End With 'WkBk
        With objWord.Selection
          objWord.Documents(WordFileName).Activate
          myCount = objWordDoc.Sections.Count
          .EndKey Unit:=wdStory 'Word最終セクションに移動
          If SectNum > myCount Then
            While SectNum <> myCount 'セクション数の追加制御
              .InsertBreak Type:=wdSectionBreakNextPage
              myCount = objWordDoc.Sections.Count
            Wend
          End If
          objWordDoc.Range(Start:=objWordDoc.Sections _
                    (SCT).Range.End - 1, _
                   End:=objWordDoc.Sections _
                    (SCT).Range.End - 1).Select
          .ParagraphFormat.Alignment = wdAlignParagraphLeft
          With .Font
            .Size = 12
            .Name = "MS ゴシック"
          End With '.Font
          .PasteSpecial Link:=False, _
             DataType:=wdPasteEnhancedMetafile, _
             Placement:=wdFloatOverText, _
             DisplayAsIcon:=False  '図(拡張メタファイル)で貼付
          With .ShapeRange
            .RelativeHorizontalPosition = _
               wdRelativeHorizontalPositionMargin
            .RelativeVerticalPosition = _
               wdRelativeVerticalPositionMargin
            .ScaleWidth TEXT_SIZE, True
            .ScaleHeight TEXT_SIZE, True
            Debug.Print "TEXT_LEFT=" & TEXT_LEFT & " :: _
                   TEXT_TOP=" & TEXT_TOP
            'On Error Resume Next
            If TEXT_TOP <> 0 Then
              .Left = MillimetersToPoints(TEXT_LEFT)
              .Top = MillimetersToPoints(TEXT_TOP)
            End If
            'On Error GoTo 0
          End With
          .MoveLeft
          Application.CutCopyMode = False
        End With 'objWord.Selection
        ThisWorkbook.Activate
      Else
        j = j - 1
      End If
KAIGYO:
      i = i + 1
      Set WkBk = Nothing
    Next j
  End With 'WkSht
  With Application
    .AskToUpdateLinks = True
    .DisplayAlerts = True
  End With 'Application
  Set objWord = Nothing
  Set objWordDoc = Nothing
  Set WkSht = Nothing
  Set WkBk = Nothing
End Sub

1 hits

【48152】開くファイルの制御 tomo 07/4/5(木) 13:18 質問
【48154】Re:開くファイルの制御 ウッシ 07/4/5(木) 13:53 発言
【48161】Re:開くファイルの制御 tomo 07/4/5(木) 16:14 お礼
【48162】Re:開くファイルの制御 ウッシ 07/4/5(木) 16:29 発言
【48163】Re:開くファイルの制御 tomo 07/4/5(木) 17:31 質問
【48164】Re:開くファイルの制御 ウッシ 07/4/5(木) 17:42 発言
【48167】Re:開くファイルの制御 tomo 07/4/5(木) 18:34 お礼
【48175】Re:開くファイルの制御 tomo 07/4/6(金) 14:04 質問
【48176】Re:開くファイルの制御 ウッシ 07/4/6(金) 15:24 発言
【48177】Re:開くファイルの制御 ウッシ 07/4/6(金) 15:42 発言
【48178】Re:開くファイルの制御 tomo 07/4/6(金) 19:18 発言
【48179】Re:開くファイルの制御 ウッシ 07/4/6(金) 20:39 発言
【48221】Re:開くファイルの制御 tomo 07/4/9(月) 9:05 発言
【48222】Re:開くファイルの制御 ウッシ 07/4/9(月) 9:43 発言
【48223】Re:開くファイルの制御 tomo 07/4/9(月) 9:48 お礼
【48235】Re:開くファイルの制御 りん 07/4/9(月) 17:52 発言
【48251】Re:開くファイルの制御 tomo 07/4/10(火) 8:18 お礼

33776 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free