Word (VBA)

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

 
(Windows 7 Home Premium : Word 2007)
Section区切りの位置
投稿日時: 17/07/25 11:13:33
投稿者: bornkiller

 みなさんいつもお世話になります。後記のマクロを作りました。問題は Sub Module記録簿作成() のコメントアウトした部分です。
 
    'sng3 = .Range(1, 1).Information(wdHorizontalPositionRelativeToPage)
    'With myTBL1.Rows
      '.RelativeHorizontalPosition = _
           wdRelativeHorizontalPositionPage
       '.HorizontalPosition = sng3
    'End With
 これはTableの位置を本文領域に合わせるもので、これは問題なく動作します。ところがこれを入れるとSection区切がTableの中にきます。希望はTableの後ろです。どうすればTableの後ろにくるんでしょうか。
 
 
Sub Module記録()
  'Module記録簿に記録
  Dim cnt1 As Integer, cnt2 As Integer, cnt3 As Integer, EFLG1 As Integer
  Dim sng1 As Single, sng2 As Single, sng3 As Single
  Dim num1 As Long, num2 As Long, txt1 As String, txt2 As String
  Dim Var3() As Variant, myFSO As Object, myFL As Object, mySB1 As Object, doc1 As Document, doc2 As Document
  Dim myRange1 As Range, myRange2 As Range
  Dim myTBL1 As Table, myTBL2 As Table, myCell As Cell, myBor As Border
  Dim VBProj As VBIDE.VBProject
  Dim VBComp As VBIDE.VBComponent
  Dim CodeMod As VBIDE.CodeModule
  Dim ProcKind As VBIDE.vbext_ProcKind
  Const dp As Single = 10.5
  On Error GoTo myErr
  txt1 = "C:\Data\Word\BackUp\Module記録簿"
  For Each doc1 In Documents
    txt2 = doc1.FullName
    If left(txt2, Len(txt1)) = txt1 And right(txt2, 5) = ".docx" Then Exit For
  Next doc1
  If doc1 Is Nothing Then
    Set myFSO = CreateObject("Scripting.FileSystemObject")
    txt1 = "C:\Data"
    If Not myFSO.FolderExists(txt1) Then myFSO.CreateFolder (txt1)
    txt1 = "C:\Data\Word"
    If Not myFSO.FolderExists(txt1) Then myFSO.CreateFolder (txt1)
    txt1 = "C:\Data\Word\BackUp"
    If Not myFSO.FolderExists(txt1) Then myFSO.CreateFolder (txt1)
    txt2 = "Module記録簿"
    'Set myFL = CreateObject("Scripting.File")
    'Set mySB1 = CreateObject("Scripting.Folder")
    Set mySB1 = myFSO.GetFolder(txt1)
    For Each myFL In mySB1.Files
      txt1 = myFL.Name
      If left(txt1, Len(txt2)) = txt2 And right(txt1, 5) = ".docx" Then Exit For
    Next myFL
    If myFL Is Nothing Then
      Call Module記録簿作成
      Set doc1 = ActiveDocument
    Else
      Set doc1 = Documents.Open(FileName:=mySB1.Path & "\" & txt1)
    End If
  End If
  'ここから目次欄に書き込み
  EFLG1 = 3
  If doc1.Tables.Count = 0 Then
    MsgBox "このModule記録簿には目次欄のTableがありません。"
    GoTo myErr
  End If
  Set myTBL1 = doc1.Tables(1)
  If myTBL1.Cell(1, 1).Range.Start >= doc1.Sections(1).Range.Start And myTBL1.Cell(1, 1).Range.End <= doc1.Sections(1).Range.End Then
    num2 = 0 '通し番号の調査
    For cnt3 = 1 To myTBL1.Rows.Count
      txt1 = Replace(Replace(myTBL1.Cell(cnt3, 1).Range.Text, Chr(13), ""), Chr(7), "")
      If txt1 = "番号" Then
      ElseIf IsNumeric(txt1) Then
        If CLng(txt1) > num2 Then num2 = CLng(txt1)
      ElseIf txt1 = "" Then
        num2 = num2 + 1
        myTBL1.Cell(cnt3, 1).Range.Text = num2
        myTBL1.Cell(cnt3, 2).Range.Text = Format(Now, "gggee\年mm\月dd\日AM/PMhh\時nn\分ss\秒")
        num2 = -1
        Exit For
      End If
    Next cnt3
    If cnt3 > myTBL1.Rows.Count And num2 >= 0 Then
      myTBL1.Rows.Add
        num2 = num2 + 1
        myTBL1.Cell(cnt3, 1).Range.Text = num2
        myTBL1.Cell(cnt3, 2).Range.Text = Format(Now, "gggee\年mm\月dd\日AM/PMhh\時nn\分ss\秒")
    End If
  End If
  myTBL1.Cell(cnt3, 3).LeftPadding = 0
  Set myTBL2 = doc1.Tables.Add(Range:=myTBL1.Rows(cnt3).Cells(3).Range, NumRows:=1, NumColumns:=3, _
                              DefaultTableBehavior:=wdWord8TableBehavior)
  With myTBL2
    .PreferredWidthType = wdPreferredWidthPoints
    .PreferredWidth = myTBL1.Cell(cnt3, 3).Width
  End With
  sng1 = myTBL1.Rows(1).Height
  myTBL2.Rows(1).Height = sng1
  myTBL2.Rows(1).HeightRule = wdRowHeightExactly 'wdRowHeightAuto
  For cnt2 = 1 To myTBL2.Columns.Count
    Set myCell = myTBL2.Cell(1, cnt2)
    Select Case cnt2
      Case 1
        myCell.Width = 4 * dp
      Case 2
        myCell.Width = myTBL1.Cell(cnt3, 3).Width - 11 * dp
      Case 3
        myCell.Width = 7 * dp
    End Select
    myCell.Range.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
    myCell.Range.ParagraphFormat.LineSpacing = 10.5
    myCell.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
    myCell.VerticalAlignment = wdCellAlignVerticalCenter
    With myCell.Borders(wdBorderTop)
      .LineStyle = wdLineStyleNone
    End With
    With myCell.Borders(wdBorderLeft)
      If cnt2 = 1 Then
        .LineStyle = wdLineStyleNone
      Else
        .Color = wdColorBlack
        .LineStyle = wdLineStyleSingle
        .LineWidth = wdLineWidth025pt
      End If
    End With
    With myCell.Borders(wdBorderRight)
      If cnt2 = myTBL2.Columns.Count Then
        .LineStyle = wdLineStyleNone
      Else
      End If
    End With
    With myCell.Borders(wdBorderBottom)
      .LineStyle = wdLineStyleNone
    End With
  Next cnt2
  Set VBProj = NormalTemplate.VBProject
  cnt1 = 0
  For Each VBComp In VBProj.VBComponents
    If VBComp.Type = vbext_ct_StdModule Or VBComp.Type = vbext_ct_ClassModule Or _
          VBComp.Type = vbext_ct_MSForm Then
      cnt1 = cnt1 + 1
      Select Case cnt1
        Case 1
          'myTBL1.Rows(2).Cells(3).Split numrows:=1, numcolumns:=3
          If VBComp.CodeModule.CountOfLines > 0 Then
            txt1 = ""
            For num1 = 1 To VBComp.CodeModule.CountOfLines
              txt1 = txt1 & VBComp.CodeModule.Lines(num1, 1) & vbCr
            Next num1
            Set myRange1 = doc1.Range
            myRange1.Collapse Direction:=wdCollapseEnd
            doc1.Sections.Add myRange1
            Set myRange1 = doc1.Sections(doc1.Sections.Count).Range
            myRange1.InsertAfter txt1
            myRange1.Collapse
            num2 = 1
            Do While doc1.Bookmarks.Exists("Proc" & num2)
              num2 = num2 + 1
            Loop
            doc1.Bookmarks.Add "Proc" & num2, myRange1
            doc1.Hyperlinks.Add Anchor:=myTBL2.Rows(1).Cells(1).Range, Address:="", SubAddress:="Proc" & num2, TextToDisplay:=CStr(cnt1)
            myTBL2.Rows(1).Cells(2).Range.Text = VBComp.Name
            myTBL2.Rows(1).Cells(3).Range.Text = "行数:" & VBComp.CodeModule.CountOfLines
          Else
            myTBL2.Rows(1).Cells(1).Range.Text = cnt1
            myTBL2.Rows(1).Cells(2).Range.Text = VBComp.Name
          End If
        Case Else
          myTBL2.Rows.Add
          myTBL1.Rows(cnt3).Height = sng1 * cnt1
          With myTBL2.Rows(cnt1).Borders(wdBorderTop)
            .Color = wdColorBlack
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth025pt
          End With
          If VBComp.CodeModule.CountOfLines > 0 Then
            txt1 = ""
            For num1 = 1 To VBComp.CodeModule.CountOfLines
              txt1 = txt1 & VBComp.CodeModule.Lines(num1, 1) & vbCr
            Next num1
            Set myRange1 = doc1.Range
            myRange1.Collapse Direction:=wdCollapseEnd
            doc1.Sections.Add myRange1
            Set myRange1 = doc1.Sections(doc1.Sections.Count).Range
            myRange1.InsertAfter txt1
            myRange1.Collapse
            num2 = 1
            Do While doc1.Bookmarks.Exists("Proc" & num2)
              num2 = num2 + 1
            Loop
            doc1.Bookmarks.Add "Proc" & num2, myRange1
            doc1.Hyperlinks.Add Anchor:=myTBL2.Rows(cnt1).Cells(1).Range, Address:="", SubAddress:="Proc" & num2, TextToDisplay:=CStr(cnt1)
            myTBL2.Rows(cnt1).Cells(2).Range.Text = VBComp.Name
            myTBL2.Rows(cnt1).Cells(3).Range.Text = "行数:" & VBComp.CodeModule.CountOfLines
          Else
            myTBL2.Rows(cnt1).Cells(1).Range.Text = cnt1
            myTBL2.Rows(cnt1).Cells(2).Range.Text = VBComp.Name
          End If
      End Select
    End If
  Next VBComp
  If cnt1 = 0 Then
    myTBL1.Rows(cnt3).Cells(3).Range.Text = "Moduleはありません。"
  End If
  Exit Sub
myErr:
  Select Case EFLG1
    Case 1, 2
      If Err.Number = 4608 Then
        cnt1 = cnt1 - 1
        Resume 0
      Else
        txt1 = Err.Description
        MsgBox txt1
        Stop
        Resume Next
      End If
    Case 3
      If Err.Number = 6068 Then
        txt1 = "Optionsでセキュリティーの設定をしてください。"
        MsgBox txt1
      Else
        txt1 = Err.Description
        MsgBox txt1
        Stop
        Resume Next
      End If
    Case Else
      txt1 = Err.Description
      MsgBox txt1
      Stop
      Resume Next
  End Select
End Sub
 
Sub Module記録簿作成()
  'Module記録簿作成
  Dim cnt1 As Integer, cnt2 As Integer, cnt3 As Integer, EFLG1 As Integer
  Dim sng1 As Single, sng2 As Single, sng3 As Single
  Dim num1 As Long, num2 As Long, txt1 As String, txt2 As String
  Dim Var3() As Variant, myFSO As Object, doc1 As Document, doc2 As Document, myRange1 As Range, myRange2 As Range
  Dim myTBL1 As Table, myTBL2 As Table, myCell As Cell, myBor As Border
  Const dp As Single = 10.5
  On Error GoTo myErr
  Set doc1 = Documents.Add
  With doc1
    .Content.Font.Name = "MS 明朝"
    .Content.Font.Size = 10.5
    With .PageSetup
      .LineNumbering.Active = False
      .Orientation = wdOrientPortrait
      .TopMargin = MillimetersToPoints(10)
      .BottomMargin = MillimetersToPoints(6)
      .LeftMargin = MillimetersToPoints(18)
      .RightMargin = MillimetersToPoints(10)
      .Gutter = MillimetersToPoints(0)
      .HeaderDistance = MillimetersToPoints(5)
      .FooterDistance = MillimetersToPoints(0)
      .PageWidth = MillimetersToPoints(210)
      .PageHeight = MillimetersToPoints(297)
      .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 = wdGutterPosLeft
      'ここから行数と1行の字数の設定
      sng1 = .PageWidth - .LeftMargin - .RightMargin
      cnt1 = CInt(sng1 / dp)
      EFLG1 = 1
      .CharsLine = cnt1
      EFLG1 = 2
      sng1 = .PageHeight - .TopMargin - .BottomMargin
      cnt1 = CInt(sng1 / dp)
      .LinesPage = cnt1
      .LayoutMode = wdLayoutModeLineGrid
      EFLG1 = 0 '元に戻す
    End With
    .Range.InsertAfter "NormalTemplateModule一覧"
    .Range.InsertParagraphAfter
    Set myRange1 = .Paragraphs(.Paragraphs.Count).Range
    myRange1.Collapse
    sng1 = (.PageSetup.PageHeight - (.PageSetup.TopMargin + .PageSetup.BottomMargin)) / _
              .PageSetup.LinesPage
    Set myTBL1 = .Tables.Add(Range:=myRange1, NumRows:=2, NumColumns:=3, _
                                DefaultTableBehavior:=wdWord8TableBehavior)
    'sng3 = .Range(1, 1).Information(wdHorizontalPositionRelativeToPage)
    'With myTBL1.Rows
      '.RelativeHorizontalPosition = _
           wdRelativeHorizontalPositionPage
       '.HorizontalPosition = sng3
    'End With
    myTBL1.AutoFitBehavior wdAutoFitFixed
    myTBL1.Rows(1).HeadingFormat = True
    sng2 = .PageSetup.PageWidth - (.PageSetup.LeftMargin + .PageSetup.RightMargin)
    For cnt2 = 1 To myTBL1.Columns.Count
      Select Case cnt2
        Case 1
          myTBL1.Columns(cnt2).Width = dp * 4
        Case 2
          myTBL1.Columns(cnt2).Width = dp * 10
        Case 3
          myTBL1.Columns(cnt2).Width = sng2 - dp * 14
      End Select
    Next cnt2
    For cnt2 = 1 To myTBL1.Rows.Count
      myTBL1.Rows(cnt2).Height = sng1
      myTBL1.Rows(cnt2).HeightRule = wdRowHeightExactly 'wdRowHeightAuto
      For cnt3 = 1 To myTBL1.Columns.Count
        Set myCell = myTBL1.Cell(cnt2, cnt3)
        myCell.Range.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
        myCell.Range.ParagraphFormat.LineSpacing = 10.5
        myCell.VerticalAlignment = wdCellAlignVerticalCenter
        With myCell.Borders(wdBorderLeft)
          .Color = wdColorBlack
          .LineStyle = wdLineStyleSingle
          .LineWidth = wdLineWidth025pt
        End With
        If cnt3 = myTBL1.Columns.Count Then
          With myCell.Borders(wdBorderRight)
            .Color = wdColorBlack
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth025pt
          End With
        End If
        With myCell.Borders(wdBorderTop)
          .Color = wdColorBlack
          .LineStyle = wdLineStyleSingle
          .LineWidth = wdLineWidth025pt
        End With
        If cnt2 = myTBL1.Rows.Count Then
          With myCell.Borders(wdBorderBottom)
            .Color = wdColorBlack
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth025pt
          End With
        End If
        Select Case cnt2
          Case 1
            myCell.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            Select Case cnt3
              Case 1
                myTBL1.Rows(cnt2).Cells(cnt3).Range.Text = "番号"
              Case 2
                myTBL1.Rows(cnt2).Cells(cnt3).Range.Text = "記録日時"
              Case 3
                myTBL1.Rows(cnt2).Cells(cnt3).Range.Text = "明細"
            End Select
          Case Else
            Select Case cnt3
              Case 1
                myCell.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
              Case Else
                myCell.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
            End Select
        End Select
      Next cnt3
    Next cnt2
    Set myFSO = CreateObject("Scripting.FileSystemObject")
    txt1 = "C:\Data"
    If Not myFSO.FolderExists(txt1) Then myFSO.CreateFolder (txt1)
    txt1 = "C:\Data\Word"
    If Not myFSO.FolderExists(txt1) Then myFSO.CreateFolder (txt1)
    txt1 = "C:\Data\Word\BackUp"
    If Not myFSO.FolderExists(txt1) Then myFSO.CreateFolder (txt1)
    txt2 = "Module記録簿.docx"
    EFLG1 = 3
    For cnt1 = 0 To 100
      If myFSO.FileExists(txt1 & "\" & txt2) Then
        Select Case cnt1
          Case 0
            txt2 = "Module記録簿" & "_Temp.docx"
          Case Else
            txt2 = "Module記録簿" & "_Temp" & cnt1 & ".docx"
        End Select
      Else
        Exit For
      End If
    Next cnt1
    If cnt1 > 100 Then
      GoTo myErr
    Else
      .SaveAs FileName:=txt1 & "\" & txt2, FileFormat:=wdFormatDocumentDefault
    End If
  End With
  Exit Sub
myErr:
  Select Case EFLG1
    Case 1, 2
      If Err.Number = 4608 Then
        cnt1 = cnt1 - 1
        Resume 0
      Else
        txt1 = Err.Description
        MsgBox txt1
        Stop
        Resume Next
      End If
    Case 3
      MsgBox "Fileの名前をつけることができません。"
      Stop
    Case Else
      txt1 = Err.Description
      MsgBox txt1
      Stop
      Resume Next
  End Select
End Sub

回答
投稿日時: 17/07/25 15:10:39
投稿者: んなっと

水平方向の位置の基準を「ページ」にしたということは、
 
 表ツール
 レイアウト
→プロパティ
→表
 文字列の折り返し が「する」になっていると思います。
 これを「なし」にしてみてください。
 
ただしこれでは表の左端の位置がうまくいかなくなってしまうので、
 
  sng3 = .Range(1, 1).Information(wdHorizontalPositionRelativeToPage)
  With myTBL1.Rows
    .RelativeHorizontalPosition = _
        wdRelativeHorizontalPositionPage
    .HorizontalPosition = sng3
  End With
 
の部分を以下に変更。
 
  With myTBL1
    .Rows.LeftIndent = .LeftPadding
  End With

投稿日時: 17/07/25 16:05:25
投稿者: bornkiller

 んなっとさん、RESありがとうございます。
 RESの前半部分で TableのPropertyを探しましたが、時間がかかったので、とりあえず後半部分を修正したらうまくいきました。
 どこがどうなっているのかいまいち分かりませんが解決とさせていただきます。