Export to word

[thpwn]

Hello!
I cant fix that code to export every active sheet to one word page, i mean to be autofitted.
Thanks!

Sub BubbleSort(ByRef list() As String)
'   Sorts an array using bubble sort algorithm
    Dim First As Long, Last As Long
    Dim i As Long, j As Long
    Dim Temp As String
    Dim fso As New Scripting.FileSystemObject
    First = CLng(Trim(fso.GetBaseName(LBound(list))))
    Last = CLng(Trim(fso.GetBaseName(UBound(list))))
    For i = First To Last - 1
        For j = i + 1 To Last
            If CLng(Trim(fso.GetBaseName(list(i)))) > CLng(Trim(fso.GetBaseName(list(j)))) Then
                Temp = list(j)
                list(j) = list(i)
                list(i) = Temp
            End If
        Next j
    Next i
End Sub
Sub BrowseSourceFolder()
    Dim FldrPicker As FileDialog
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FldrPicker
      .Title = "Select a Source Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
         ThisWorkbook.Sheets(1).Range("C6").Value = .SelectedItems(1)
        If Right(ThisWorkbook.Sheets(1).Range("C6").Value, 1) <> "" Then
            ThisWorkbook.Sheets(1).Range("C6").Value = .SelectedItems(1) & ""
        End If
    End With
End Sub


Sub Wsh_Print_Setting_OnePage(WshTrg As Worksheet, ePaperSize As XlPaperSize)
On Error Resume Next
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.984252)
        .RightMargin = Application.InchesToPoints(0.19685)
        .TopMargin = Application.InchesToPoints(0.19685)
        .BottomMargin = Application.InchesToPoints(0.19685)
        .Orientation = xlPortrait
        .PaperSize = ePaperSize
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    Application.PrintCommunication = True
End Sub




Sub SavetoWord()
    If ThisWorkbook.Sheets("Interface").Range("C6").Value = "" Then
        MsgBox "Please choose a source folder."
        Exit Sub
    End If
    If Len(Dir(Trim(ThisWorkbook.Sheets("Interface").Range("C6").Value), vbDirectory)) = 0 Then
        MsgBox "The specified source folder does not exist."
        Exit Sub
    End If
    Dim objWordApp As Word.Application
    Dim objWordDocument As Word.Document


    Set objWordApp = CreateObject("Word.Application")
    Set objWordDocument = objWordApp.Documents.Add
    Dim r
    Set r = objWordDocument.GoTo(wdGoToPage, wdGoToAbsolute, 1)
    objWordDocument.PageSetup.Orientation = wdOrientLandscape
    Dim b As Bookmark
    Set b = objWordDocument.Bookmarks.Add("here", r)
    ActiveWorkbook.CheckCompatibility = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Dim interfacesheet As Worksheet
    Set interfacesheet = ThisWorkbook.Worksheets("Interface")
    Dim oldStatusBar As Variant
    oldStatusBar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    Dim wb As Workbook
    Dim rr As Range
    Dim filecount, i, k, m, p, q, t As Integer
    Dim FNames() As String
    ReDim FNames(1000)
    Dim sourcefolderpath, extension, allfiles As String
    sourcefolderpath = Trim(interfacesheet.Range("C6").Value)
    extension = "*.xls*"
    allfiles = Dir(sourcefolderpath & extension)
    filecount = 0
    Do While allfiles <> ""
        FNames(filecount) = allfiles
        filecount = filecount + 1
        allfiles = Dir
    Loop
    ReDim Preserve FNames(filecount - 1)
    BubbleSort FNames
    i = 1
    For j = LBound(FNames) To UBound(FNames)
        Application.StatusBar = "Progress: Processing excel file " & FNames(j) & " (" & i & " of " & filecount & ")..."
        'On Error GoTo NextFile
        Set wb = Workbooks.Open(fileName:=sourcefolderpath & FNames(j), UpdateLinks:=False, ReadOnly:=True, CorruptLoad:=XlCorruptLoad.xlRepairFile)
        ''''''''''''
        Call Wsh_Print_Setting_OnePage(wb.Sheets(1), xlPaperA4)
        DoEvents
        'wb.Sheets(1).UsedRange.Copy
        Set tbl = wb.Sheets(1).UsedRange
        tbl.Copy
        objWordDocument.Select
        b.Range.PasteExcelTable LinkedToExcel:=False, _
        WordFormatting:=False, RTF:=False
        'b.Range.PasteAndFormat wdPasteDefault
        objWordApp.Selection.EndKey Unit:=wdStory
        b.Delete
        Set b = objWordDocument.Bookmarks.Add("here")
        DoEvents
        b.Range.InsertBreak wdPageBreak
        objWordApp.Selection.EndKey Unit:=wdStory
        b.Delete
        Set b = objWordDocument.Bookmarks.Add("here")
        DoEvents
        wb.Close
        DoEvents
NextFile:
        i = i + 1
    Next
    With objWordDocument.PageSetup
        .LeftMargin = Application.InchesToPoints(0.984252)
        .RightMargin = Application.InchesToPoints(0.19685)
        .TopMargin = Application.InchesToPoints(0.19685)
        .BottomMargin = Application.InchesToPoints(0.19685)
    End With
    objWordApp.Browser.Target = wdBrowseTable
    For Each tbl In objWordDocument.Tables
        tbl.AutoFitBehavior (wdAutoFitWindow)
    Next
    objWordDocument.SaveAs Trim(ThisWorkbook.Sheets("Interface").Range("C6").Value) & "Fise.docx"
    i = MsgBox("Conversie terminata. Doriti sa deschideti fisierul Fise.docx acum?", vbYesNo + vbQuestion, "Conversie terminata")
    If i = vbYes Then
        objWordDocument.Select
        objWordApp.Selection.HomeKey Unit:=wdStory
        objWordApp.Visible = True
        objWordApp.Activate
    Else
        objWordDocument.Close
        objWordApp.Quit
    End If
    Application.StatusBar = False
    Application.DisplayStatusBar = oldStatusBar
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
End Sub

 

[Macropod]

Your pasting/sizing issues are related to this code:

        b.Range.PasteExcelTable LinkedToExcel:=False, _
        WordFormatting:=False, RTF:=False

You might try changing the RTF parameter to True, or you might use a different paste method entirely.

PS: When posting code, please use the code tags, indicated by the # button on the posting menu. Without them, your code loses much of whatever structure it had.

 

[thpwn]

Thank you Macropod!
It looks that i have to change the copy paste method, but i don't know.
Can someone help me to copy the worksheet and that to be fitted into one page.

 

[Macropod]

You might, for example, use one of:

  b.Range.PasteSpecial Link:=False, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
  b.Range.PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, Placement:=wdInLine, DisplayAsIcon:=False
  b.Range.PasteSpecial Link:=False, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False

The first gives you an editable Excel worksheet embedded in the document that can also be resized; the others paste in the image formats indicated.

 

[thpwn]

Thank you!
I chose OLE, but it still don't fit automatically

 

[Macropod]

As I said, you can resize such an object. Naturally, you'd have to add the code that does that. For example:

With b
  .Range.PasteSpecial Link:=False, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False
  With .InlineShapes(1)
    .LockAspectRatio = True
    .Width = objWordApp.InchesToPoints(6)
  End With
End With