Word macro to resize all .word documents in folder?

[H1SOKA]

Hey guys,

I need a macro to bulk resize all documents in a folder.

The dimensions are 15.24 x 22.86 cm.

Does anyone know how to do this? Thanks a lot!

 

[Macropod]

And when you do that, what's supposed to happen to margins, page headers/footers, etc. and any that doesn't fit the new page size (e.g. images, tabs)?

PS: 15.24 x 22.86 cm = 6in*9in

 

[H1SOKA]

And when you do that, what's supposed to happen to margins, page headers/footers, etc. and any that doesn't fit the new page size (e.g. images, tabs)?

PS: 15.24 x 22.86 cm = 6in*9in

Thanks for the question.

The content should be resized to fit the new page size. The content which does not fit the new page dimensions should be taken care of with additional pages because the pages are smaller in size. There are no images or tabs which need to be resized, only plain text.

 

[Macropod]

In that case, try:

Sub ReformatDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      With .PageSetup
        .PageHeight = InchesToPoints(9)
        .PageWidth = InchesToPoints(6)
      End With
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

 

[H1SOKA]

In that case, try:

Sub ReformatDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      With .PageSetup
        .PageHeight = InchesToPoints(9)
        .PageWidth = InchesToPoints(6)
      End With
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Hi There, thanks a lot for your response.

The code ends here and I get a compile error: Expected End Function
Function GetFolder() As String

It doesn't open a window to browse for a folder. Is there something I need to change?

Thanks again.

 

[Macropod]

Did you copy all the code - including the 'End Function' line? Your post suggests not.

 

[H1SOKA]

Did you copy all the code - including the 'End Function' line? Your post suggests not.

Here's the code that I used with the End Function line appended.

Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
With .PageSetup
.PageHeight = InchesToPoints(9)
.PageWidth = InchesToPoints(6)
End With
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function




Still not working?

I've tried everything and so far haven't a clue how to get it working.

Any help is appreciated!

Thank you

 

[Macropod]

Now you've omitted the first line of the code:
Sub ReformatDocuments()

The macro works just fine if you use ALL of it...

 

[H1SOKA]

Now you've omitted the first line of the code:
Sub ReformatDocuments()

The macro works just fine if you use ALL of it...

Wow I am amazed at my lack of attention to detail haha.

Your macro works perfect. Thanks a lot for your help!