Option Explicit
Sub SettingAndHeader()
Dim k As Long, start As Long, end_ As Long, PagesCount As Long, currPage As Long
Dim hf As HeaderFooter, sec As Section, bd As Border, tabl As Table, text As String, text2 As String, orient
PagesCount = ThisDocument.Range.Information(wdNumberOfPagesInDocument)
For k = 1 To PagesCount
' nhay toi cac trang lien tiep
Selection.GoTo wdGoToPage, wdGoToAbsolute, k
With Selection.PageSetup
If .Orientation = wdOrientPortrait Then
.LeftMargin = Application.InchesToPoints(1.2)
' .TopMargin = Application.InchesToPoints(0.6)
.RightMargin = Application.InchesToPoints(0.9)
.BottomMargin = Application.InchesToPoints(0.6)
Else
.LeftMargin = Application.InchesToPoints(1)
.TopMargin = Application.InchesToPoints(1.2)
.RightMargin = Application.InchesToPoints(0.7)
.BottomMargin = Application.InchesToPoints(0.8)
End If
End With
Next k
' them section
currPage = 1
PagesCount = ThisDocument.Range.Information(wdNumberOfPagesInDocument)
Do Until currPage >= PagesCount
If currPage = PagesCount Then
Selection.End = ActiveDocument.Range.End
Selection.start = start
Else
Selection.GoTo wdGoToPage, wdGoToAbsolute, currPage + 1
Selection.start = start
end_ = Selection.End
End If
' xoa page break
Selection.Find.Execute Findtext:="^m", ReplaceWith:=""
Selection.End = end_
' neu chua co section break thi them
If Not Selection.Find.Execute("^b") Then
Selection.start = Selection.End
If Not Selection.Information(wdWithInTable) Then Selection.InsertBreak wdSectionBreakNextPage
End If
currPage = currPage + 1
start = Selection.End
Loop
Selection.End = 0
' them Header
ThisDocument.PageSetup.DifferentFirstPageHeaderFooter = True
'
Set hf = ThisDocument.Sections(1).Headers(wdHeaderFooterFirstPage)
Set tabl = ThisDocument.Tables.Add(hf.Range, 1, 2, wdWord9TableBehavior, wdAutoFitFixed)
For Each bd In tabl.Borders
bd.LineStyle = wdLineStyleNone
Next bd
For k = 1 To ThisDocument.Sections.Count
Set sec = ThisDocument.Sections(k)
On Error Resume Next
orient = sec.PageSetup.Orientation
Do While Err.Number
Err.Clear
orient = sec.PageSetup.Orientation
Loop
On Error GoTo 0
If orient = wdOrientPortrait Then
text = "V" & ChrW(259) & "n b" & ChrW(7843) & "n ph" & ChrW(225) & "p lu" & ChrW(7853) & _
"t" & vbCr & "Ban h" & ChrW(224) & "nh: Ng" & ChrW(224) & "y " & ChrW(8230)
text2 = "B" & ChrW(7897) & " ph" & ChrW(225) & "t h" & ChrW(224) & "nh:" & vbCr & "H" & _
ChrW(236) & "nh Th" & ChrW(7913) & "c ph" & ChrW(225) & "t h" & ChrW(224) & "nh:"
Else
text = "B" & ChrW(7843) & "ng " & ChrW(272) & ChrW(225) & "nh Gi" & ChrW(225) & " t" & ChrW(225) & _
"c " & ChrW(273) & ChrW(7897) & "ng ng" & ChrW(224) & "nh" & vbCr & "Th" & ChrW(244) & _
"ng tin " & ChrW(273) & ChrW(432) & ChrW(7907) & "c cung c" & ChrW(7845) & "p b" & ChrW(7903) & "i: ..."
text2 = "V" & ChrW(259) & "n b" & ChrW(7843) & "n ph" & ChrW(225) & "p lu" & ChrW(7853) & "t" & _
vbCr & "Ban h" & ChrW(224) & "ng: Ng" & ChrW(224) & "y " & ChrW(8230)
End If
With sec
Set hf = .Headers(wdHeaderFooterFirstPage)
If k > 1 Then hf.LinkToPrevious = False
Set tabl = hf.Range.Tables(1)
tabl.Cell(1, 1).Range.text = text
tabl.Cell(1, 2).Range.text = text2
Set hf = .Headers(wdHeaderFooterPrimary)
If k > 1 Then hf.LinkToPrevious = False
On Error Resume Next
Set tabl = hf.Range.Tables(1)
If Err.Number Then
Set hf = sec.Headers(wdHeaderFooterPrimary)
Set tabl = ThisDocument.Tables.Add(hf.Range, 1, 2, wdWord9TableBehavior, wdAutoFitFixed)
For Each bd In tabl.Borders
bd.LineStyle = wdLineStyleNone
Next bd
End If
On Error GoTo 0
tabl.Cell(1, 1).Range.text = text
tabl.Cell(1, 2).Range.text = text2
End With
Next k
k = InStrRev(ThisDocument.FullName, ".")
text = Left(ThisDocument.FullName, k - 1) & "_result" & Mid(ThisDocument.FullName, k)
ThisDocument.SaveAs2 text
End Sub
