Word (VBA)

Word VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Home Premium : Word 2007)
Shapeのコピー
投稿日時: 17/12/25 14:32:05
投稿者: bornkiller

 みなさんいつもお世話になります。
 葉書の宛名印刷プログラムをつくりました。まず葉書一枚分を作成します。
 
Function 葉書Template2(Optional FLG1 As Integer = 0) '葉書作成
  Dim cnt1 As Integer, cnt2 As Integer, num1 As Long, num2 As Long, txt1 As String
  Dim myFSO As Object, doc1 As Document, doc2 As Document, myRange1 As Range, myRange2 As Range, Var1 As Variant
  Dim myTBL1 As Table, myPTY As Office.DocumentProperty, myShape As Shape
  On Error GoTo myErr
  Set doc1 = ActiveDocument
  Set doc2 = Documents.Add
  With doc2
    .Content.Font.Name = "MS ゴシック"
    .Content.Font.Size = 10.5
    With .PageSetup
      .LineNumbering.Active = False
      .Orientation = 1
      .TopMargin = MillimetersToPoints(10)
      .BottomMargin = MillimetersToPoints(10)
      .LeftMargin = MillimetersToPoints(10)
      .RightMargin = MillimetersToPoints(6)
      .Gutter = MillimetersToPoints(0)
      .HeaderDistance = MillimetersToPoints(0)
      .FooterDistance = MillimetersToPoints(0)
      .PageWidth = MillimetersToPoints(100)
      .PageHeight = MillimetersToPoints(148.5)
      .FirstPageTray = wdPrinterDefaultBin
      .OtherPagesTray = wdPrinterDefaultBin
      .SectionStart = wdSectionNewPage
      .OddAndEvenPagesHeaderFooter = False
      .DifferentFirstPageHeaderFooter = False
      .VerticalAlignment = wdAlignVerticalTop
      .SuppressEndnotes = False
      .MirrorMargins = False
      .TwoPagesOnOne = False
      .BookFoldPrinting = False
      .BookFoldRevPrinting = False
      .BookFoldPrintingSheets = 1
      .GutterPos = 0
      .CharsLine = 12
      .LinesPage = 20
      .LayoutMode = wdLayoutModeLineGrid
    End With
    Set myShape = .Shapes.AddTextbox(msoTextOrientationHorizontal, 125.05, _
                    36.55, 57.95, 22.7)
    With myShape
      .Name = "郵便番号1"
      '.Line.Visible = msoFalse
      With .TextFrame
        .MarginLeft = 0
        .MarginRight = 0
        .MarginTop = 0
        .MarginBottom = 0
        .TextRange.Font.Name = "MS 明朝"
        .TextRange.Font.Size = 14
      End With
    End With
    Set myShape = .Shapes.AddTextbox(msoTextOrientationHorizontal, 187.65, _
                    36.65, 75.2, 23.2)
    With myShape
      .Name = "郵便番号2"
      '.Line.Visible = msoFalse
      With .TextFrame
        .MarginLeft = 0
        .MarginRight = 0
        .MarginTop = 0
        .MarginBottom = 0
        .TextRange.Font.Name = "MS 明朝"
        .TextRange.Font.Size = 14
      End With
    End With
    Set myShape = .Shapes.AddTextbox(msoTextOrientationVerticalFarEast, 200, _
                    87.35, 62.55, 284.9)
    With myShape
      .Name = "宛先住所"
      '.Line.Visible = msoFalse
      With .TextFrame
        .MarginLeft = 0
        .MarginRight = 0
        .MarginTop = 0
        .MarginBottom = 0
        .TextRange.Font.Name = "MS 明朝"
        .TextRange.Font.Size = 16
      End With
    End With
    Set myShape = .Shapes.AddTextbox(msoTextOrientationVerticalFarEast, 115, _
                    95, 70, 250)
    With myShape
      .Name = "宛名"
      '.Line.Visible = msoFalse
      With .TextFrame
        .MarginLeft = 0
        .MarginRight = 0
        .MarginTop = 0
        .MarginBottom = 0
        .TextRange.Font.Name = "MS 明朝"
        .TextRange.Font.Size = 20
      End With
    End With
    Set myRange1 = .Range(0, 0)
  End With
  Set 葉書Template2 = doc2
  Exit Function
myErr:
  txt1 = Err.Description
  MsgBox txt1
  Stop
  Resume 0
 
End Function
 
 
 次に葉書一枚につき1Sectionを割り当て、Sectionを増やしながら最初のShapeをコピーしていきます。
 
    myShapeRange1.Select
    Selection.Copy
    Selection.EndKey unit:=wdStory
    Selection.InsertBreak Type:=wdSectionBreakNextPage
    Selection.EndKey unit:=wdStory
    Selection.PasteAndFormat (wdPasteDefault)
    'doc1.Sections(doc1.Sections.Count).Range.PageSetup = doc1.Sections(1).Range.PageSetup
    Set myShapeRange2 = doc1.Sections(doc1.Sections.Count).Range.ShapeRange
    For Each myShape1 In myShapeRange1
      For Each myShape2 In myShapeRange2
        If myShape1.Name = myShape2.Name Then
          myShape2.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
          myShape2.left = myShape1.left
          myShape2.RelativeVerticalPosition = wdRelativeVerticalPositionPage
          myShape2.Height = myShape1.Height
          Exit For
        End If
      Next
    Next
 
 それに宛名を書き込み最後は1ページ目を削除して終わるという順序です。これで一応動くのですが、印刷がうまくいきません。原因はPageSetUpが崩壊しているからだと思われます。出来上がりの状態を調べると下記のようになります。
 
PageSetup
LineNumbering.Active = True
Orientation =
TopMargin = 3527778mm
BottomMargin = 3527778mm
LeftMargin = 3527778mm
RightMargin = 3527778mm
Gutter = 3527778mm
HeaderDistance = 3527778mm
FooterDistance = 3527778mm
PageWidth = 3527778mm
PageHeight = 3527778mm
FirstPageTray =
OtherPagesTray =
SectionStart =
OddAndEvenPagesHeaderFooter = False
DifferentFirstPageHeaderFooter = True
VerticalAlignment =
SuppressEndnotes = True
MirrorMargins = False
TwoPagesOnOne = False
BookFoldPrinting = False
BookFoldRevPrinting = False
BookFoldPrintingSheets = 1
GutterPos = wdGutterPosLeft(左側)
CharsLine = -32767
LinesPage = -32767
LayoutMode =
 
 これを修正しようと最後にPageSetUpの設定を入れるとエラーで動きません。PageSetUpを変えずにShapeを増やすのにはどうすればいいんでしょうか。

投稿日時: 17/12/27 16:51:34
投稿者: bornkiller

 お騒がせしましたが結局自己解決しました。SetUpが崩壊する点はSection毎をPage毎に変えて維持できました。印刷がうまくいかなかったのはOrientationの設定が違っていただけで、SetUpの崩壊とは関係なかったようです。