Word Macro - set orientation of selected page - vba

I'm trying to make a macro where users can select a table within a document and switch the orientation of the specific page it's on to landscape. I've tried both recording doing the action and writing the macro myself but it never seems to work properly. This is as close as I've gotten but it makes the page the table is on and everything before it landscape.
Sub TableLandscape()
'
' TableLandscape Macro
'
'
'Selection.Collapse Direction:=wdCollapseEnd
'Selection.InsertBreak Type:=wdSectionBreakContinuous
'ActiveDocument.Range(Start:=Selection.Start, End:=Selection.Start).Collapse Direction:=wdCollapseStart
'Selection.InsertBreak _
Type:=wdSectionBreakNextPage
Selection.Start = Selection.Start + 1
ActiveDocument.Range(Start:=Selection.End, End:=Selection.End).InsertBreak _
Type:=wdSectionBreakNextPage
With Selection.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientLandscape
.TopMargin = InchesToPoints(1)
.BottomMargin = InchesToPoints(1)
.LeftMargin = InchesToPoints(1)
.RightMargin = InchesToPoints(1)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.6)
.FooterDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(11)
.PageHeight = InchesToPoints(8.5)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionContinuous
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
'ActiveDocument.Range(Start:=Selection.End, End:=Selection.End).InsertBreak _
'Type:=wdSectionBreakNextPage
End Sub

Here's how to do that:
Sub RotatePage()
Dim TableRange As Range, TableStart As Range, TableEnd As Range
Set TableRange = Selection.Tables(1).Range
Set TableStart = TableRange.Duplicate
With TableStart
.SetRange Start:=TableStart.Start - 1, End:=TableStart.End
.Collapse Direction:=wdCollapseStart
.InsertBreak Type:=wdSectionBreakNextPage
End With
Set TableEnd = TableRange.Duplicate
With TableEnd
.SetRange Start:=TableEnd.Start, End:=TableEnd.End + 1
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdSectionBreakNextPage
End With
TableRange.PageSetup.Orientation = wdOrientLandscape
End Sub

Related

Configuring my radiobuttons so they import text from a UserForm to a bookmark

I am doing a document using a userform. In the userform I setup radiobuttons when clicked I want the text from a macro that I did to be inserted at a specific bookmark in my document. Help please
This is my macro:
Sub ordonnance()
'
' ORDONNANCE Macro
'
'
Dim bmSignet As Bookmark
Dim rgPlageDuSignet As Range
Set bmSignet = ActiveDocument.Bookmarks("ORDONNANCE_DE")
Set rgPlageDuSignet = bmSignet.Range
rgPlageDuSignet.Select
ActiveDocument.Tables.Add rgPlageDuSignet, 1, 1
With Selection.Tables(1)
If .Style <> "Grille du tableau" Then
.Style = "Grille du tableau"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="ORDONNANCE DE NON-PUBLICATION ..."
Set bmSignet = Nothing
Set rgPlageDuSignet = Nothing
End Sub
This is my radiobutton:
Private Sub OptionButton3_Click()
If Me.OptionButton3.Value = True Then
Call RemplaceSignet("ORDONNANCE_DE", "ORDONNANCE DE NON-PUBLICATION ...")
Else
Call RemplaceSignet("ORDONNANCE_DE", " ")
End If
End Sub
Try:
Sub ordonnance(StrBkMk As String, StrTxt As String)
'
' ORDONNANCE Macro
'
'
Dim Tbl As Table
With ActiveDocument
Set Tbl = .Tables.Add(.Bookmarks(StrBkMk).Range, 1, 1)
With Tbl
.Style = "Grille du tableau"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
With .Cell(1, 1).Range
With .Font
.Name = "Arial"
.Size = 12
.Bold = True
End With
.Text = StrTxt
End With
End With
End With
Set Tbl = Nothing
End Sub
Note that there is no need to select anything.

How to check orientation of each consecutive section?

I am working on a macro that would plot through currently opened document sections one by one, check whether they are portrait or landscape, and set their margins (incl. header and footer) to given dimensions (which are different depending on the page orientation).
How do I detect the page orientation of each section and make it the current "selection" or put the cursor on its beginning, so the next line could set its margins and skip to the next section?
This is what I got so far:
Sub Margins()
Dim nOriginalPagination As Integer
Dim objSection As Section
Dim nPaperSize As Integer
Dim ContinueOn As Boolean
ContinueOn = False
nNumSects = ActiveDocument.Sections.Count
ActiveWindow.View.Type = wdPageView
If ActiveWindow.View.SeekView <> wdSeekMainDocument Then
ActiveWindow.View.SeekView = wdSeekMainDocument
End If
Selection.HomeKey wdStory, wdMove
For Each objSection In objDocument.Sections
iSecNum = Selection.Information(wdActiveEndSectionNumber)
With objSection.PageSetup
nPaperSize = PAPERLETTER
End With
Next
For Each objSection In objDocument.Sections
iSecNum = Selection.Information(wdActiveEndSectionNumber)
With objSection.PageSetup
'Set the margins, depending on the page orientation
If .Orientation = wdOrientPortrait Then
.TopMargin = CentimetersToPoints(2.23)
.BottomMargin = CentimetersToPoints(2.21)
.LeftMargin = CentimetersToPoints(3.17)
.RightMargin = CentimetersToPoints(3.17)
.HeaderDistance = CentimetersToPoints(0.96)
.FooterDistance = CentimetersToPoints(0.94)
Else
.TopMargin = CentimetersToPoints(3.17)
.BottomMargin = CentimetersToPoints(3.17)
.LeftMargin = CentimetersToPoints(2.21)
.RightMargin = CentimetersToPoints(2.23)
.HeaderDistance = CentimetersToPoints(1.9)
.FooterDistance = CentimetersToPoints(1.9)
End If
End With
Application.ScreenUpdating = True
Options.Pagination = nOriginalPagination
Selection.GoTo what:=wdGoToSection, Which:=wdGoToNext
Next
End Sub
Error says I am missing as object.
Your code has several issues:
undeclared variables
unnecessary use of the Selection object
ScreenUpdating being turned on without having been turned off
The line that is causing the error is:
For Each objSection In objDocument.Sections
This is because the undeclared variable objDocument is not set to anything.
The code you need is below:
Sub Margins()
Dim objDocument as Document
Dim objSection As Section
Application.ScreenUpdating = False
Set objDocument = ActiveDocument
For Each objSection In objDocument.Sections
With objSection.PageSetup
'Set the margins, depending on the page orientation
If .Orientation = wdOrientPortrait Then
.TopMargin = CentimetersToPoints(2.23)
.BottomMargin = CentimetersToPoints(2.21)
.LeftMargin = CentimetersToPoints(3.17)
.RightMargin = CentimetersToPoints(3.17)
.HeaderDistance = CentimetersToPoints(0.96)
.FooterDistance = CentimetersToPoints(0.94)
Else
.TopMargin = CentimetersToPoints(3.17)
.BottomMargin = CentimetersToPoints(3.17)
.LeftMargin = CentimetersToPoints(2.21)
.RightMargin = CentimetersToPoints(2.23)
.HeaderDistance = CentimetersToPoints(1.9)
.FooterDistance = CentimetersToPoints(1.9)
End If
End With
Next
Application.ScreenUpdating = True
End Sub

VBA print macro to set page in specific manner

I've been working on a print macro that I think is probably simple. I've tried recording a macro and have been researching for a few hours looking at other peoples code. What I would like is for the macro to:
1) select all cells in the active worksheet
2) set print scale to fit all columns to one page
3) print landscape mode
4) Open print preview (if possible)
5) If #4 is not possible then execute print job.
When I run my current code my excel worksheet gets split into tons of page (checker board style) and then I get an error code. Thanks for reading.
This is my current code:
Sub PrintNOPAsheet()'
' PrintNOPAsheet Macro
Cells.Select
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$A$1:$H$346"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
Selection.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
End Sub
'
Here's what I usually use, then I made it to match your question. Within the With you can add as many of the properties you have from the recorded macro to suit your code.
Sub printIt()
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
Dim rng as Range
Dim printRange as String
Set rng = ws.Range("A1:J11")
''''For Dynamic Ranges'''''
With ws
Set rng = .Range(.Range("A1"),.Range("J11").End(xlDown))
End With
''''Range from User Highlighted Cells''''
Set rng = Selection
''''This method is not the best way''''
printRange = ws.Name & "!" & rng.Address
With ws.PageSetup
.PrintArea = printRange
.Zoom = False
.FitToPagesWide = 1 'Question 2
.Orientation = xlLandscape 'Question 3
End With
ws.PrintOut preview:=True 'Question 4
End Sub

Word macro error - Runtime Error 4608, Value out of range

We have a macro we run to format the page for our publisher. There are several documents that use this macro. For smaller documents the macro runs without error, for larger documents we receive the error in the subject line of this thread.
Small document - <= 256KB
Large document - >= 500KB
For the documents that have the error I can open them in Word and manually make the settings without a problem.
Here is the second version of the macro
Function pagestuffB() As String
'
' Format for Publisher
'
'
Dim rv As String
rv = ""
On Error GoTo ErrorHndlr:
With Application
.Options.Pagination = False
.ScreenUpdating = False
With .ActiveDocument.PageSetup
.PaperSize = wdPaperLetter
' .PageWidth = InchesToPoints(8.5)
' .PageHeight = InchesToPoints(11)
.Orientation = wdOrientPortrait
.MirrorMargins = True 'ERROR HERE
.TopMargin = InchesToPoints(1.34)
.HeaderDistance = InchesToPoints(0.98)
.BottomMargin = InchesToPoints(1)
.FooterDistance = InchesToPoints(0.8)
.LeftMargin = InchesToPoints(1.61)
.RightMargin = InchesToPoints(1.4)
.Gutter = InchesToPoints(0)
.SectionStart = wdSectionContinuous
.OddAndEvenPagesHeaderFooter = True
.DifferentFirstPageHeaderFooter = True
.LineNumbering.Active = False
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
End With
pagestuffB = rv
Exit Function
ErrorHndlr:
If rv = "" Then
rv = "Macro error " & Err.Number
Select Case Err.Number
Case Else
End Select
End If
Resume Next
End Function
Version info: Word 2010, VS 2012.
I have the document that failed and will provide it if needed.
EDIT: The documents are here
This is the latest version of the macro, which actually runs, but.... It took .5 hours to format the two documents, two of the smallest, in the link above.
Function pagestuffB() As String
'
' Format for Publisher
'
'
Dim rv As String
rv = ""
On Error GoTo ErrorHndlr:
With Application
.Options.Pagination = False
.ScreenUpdating = False
.WindowState = wdWindowStateMinimize
End With
Dim oSec As Section
For Each oSec In Selection.Sections
With oSec.PageSetup
.Orientation = wdOrientPortrait 'moved per macropod
.PaperSize = wdPaperLetter
.MirrorMargins = True
.TopMargin = InchesToPoints(1.34)
.HeaderDistance = InchesToPoints(0.98)
.BottomMargin = InchesToPoints(1)
.FooterDistance = InchesToPoints(0.8)
.LeftMargin = InchesToPoints(1.61)
.RightMargin = InchesToPoints(1.4)
.Gutter = InchesToPoints(0)
.SectionStart = wdSectionContinuous
.OddAndEvenPagesHeaderFooter = True
.DifferentFirstPageHeaderFooter = True
.LineNumbering.Active = False
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
Next oSec
pagestuffB = rv
Exit Function
ErrorHndlr:
If rv = "" Then
rv = "Macro error " & Err.Number
Select Case Err.Number
Case Else
End Select
End If
Resume Next
End Function
So I removed these three lines of code and the macro worked very quickly on my computer for those two documents. It seems like you used a recorded macro to build this code. It's certainly hard to grasp what exactly you want this code to do since there are no comments describing what your code does :). Comment underneath if this suggestion does not fix your problem.
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1

Word Vba Input Box to set Document Orientation - IF with OR

In my macro I want to prompt for the page Orientation -- P or p for portrait, L or l for landscape.
Here is what I developed. It works - but want to know if there is a better/more efficient way to develop If statements for "OR" --- do I have to use a "nested" If??
Dim i As Integer
Dim oTbl As Table
Dim rng As Range
Dim Orientation As String
With Selection.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = InchesToPoints(1)
.BottomMargin = InchesToPoints(1)
.LeftMargin = InchesToPoints(0.4)
.RightMargin = InchesToPoints(0.4)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.6)
.PageWidth = InchesToPoints(8.5)
.PageHeight = InchesToPoints(11)
.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
End With
' set Orientation
Orientation = InputBox(Prompt:="Enter P for Portriait, L for Landscape")
If Orientation = "L" Then
With Selection.PageSetup
.Orientation = wdOrientLandscape
End With
ElseIf Orientation = "l" Then
With Selection.PageSetup
.Orientation = wdOrientLandscape
End With
Else
With Selection.PageSetup
.Orientation = wdOrientPortrait
End With
End If
I'm not sure is there a better (more efficient) way to develop MS Word page orientation... I would not use InputBox, but if you want to use it i'd do something like this:
AskAgain:
Orientation = InputBox(Prompt:="Enter P for Portriait, L for Landscape")
Select Case UCase(Orientation)
Case "L"
Selection.PageSetup.Orientation = wdOrientLandscape
Case "P"
Selection.PageSetup.Orientation = wdOrientPortrait
Case Else
GoTo AskAgain
End Select
To be honest... leave the decision to the user and do not prevent user to set page orientation from VBA code, but call print preview window. This is best way - in my opinion.