Zoom (!)

[w00t]

Не получается. Нужно для выделенной области показать предпросмотр. При этом выделенный текст вписать на 1 страницу. При этом, если вписываемая табличка меньше размера листа - нужно ее растянуть на лист. Если больше - то просто вписать (это проще). Вот не получается с маленькими табличками выделенными, как их растянуть на экран. Зум задать не фиксированный, а чтобы он подбирался, в зависимости от области выделения.

Как это можно осуществить?

Option Explicit 
 
Sub PrintIt() 
     '
    Dim ans As String, rPrintArea As Range 
    On Error Resume Next 
    Application.DisplayAlerts = False 
    Set rPrintArea = Application.InputBox(Prompt:="Use Mouse to select area to Print.", Title:="Select Print Area", Type:=8) 
    On Error Goto 0 
    Application.DisplayAlerts = True 
    If rPrintArea Is Nothing Then Exit Sub 
    With ActiveSheet.PageSetup 
        .PrintTitleRows = "" 
        .PrintTitleColumns = "" 
    End With 
     
    ActiveSheet.PageSetup.PrintArea = rPrintArea.Address 
    Application.PrintCommunication = False 
    With ActiveSheet.PageSetup 
        .CenterVertically = False 
        .Orientation = xlPortrait 
        .PaperSize = xlPaperA4 
        .Zoom = True 
        .FitToPagesWide = 1 
        .FitToPagesTall = 1 
    End With 
    ans = MsgBox(Prompt:="Yes to Print." & vbCrLf & "No to Preview." & vbCrLf & "Cancel To Abort", Buttons:=vbYesNoCancel, Title:="Print?") 
    If ans = vbCancel Then Exit Sub 
    If ans = vbYes Then 
        rPrintArea.PrintOut 
    Else 
        rPrintArea.PrintOut Preview:=True, Collate:=True 
    End If 
End Sub

[DiemonStar]

вот такой код выставляет по выделенной области:

Sub Zoom()
    W = 0: For Each Cl In Selection.Columns: W = W + Cl.Width + Cl.Borders(xlEdgeLeft).Weight + Cl.Borders(xlEdgeRight).Weight: Next Cl
    H = 0: For Each Rw In Selection.Rows: H = H + Rw.Height + Rw.Borders(xlEdgeTop).Weight + Rw.Borders(xlEdgeBottom).Weight: Next Rw
    With ActiveSheet.PageSetup
        M1 = Round(Application.InchesToPoints(21 / 2.54) - (.LeftMargin + .RightMargin)) / W
        M2 = Round(Application.InchesToPoints(29.7 / 2.54) - (.TopMargin + .BottomMargin)) / H
        .PrintArea = Selection.Address
        .Zoom = IIf(M1 < M2, M1, M2) * 100
    End With
End Sub

upd. немного поправил

[w00t]

Ругается на переменные, начиная с "W". (Cl, H, Rw). Подскажите, пожалуйста, как их правильно объявить, ширину, высоту, строчку, столбец.

[DiemonStar]

например так:

Dim H, W, Cl, Rw, M1, M2

[w00t]

Извините, что вас пытаю, но у меня как-то пока не выходит, наверное, нужно больше кофе... Найду решение - приложу.

[w00t]

Все было ок.. это я ошибся. Немного иной вариант того же

Option Explicit
Sub PrintIt()
    Dim H, W, Cl, Rw, M1, M2
    Dim ans As String, rPrintArea As Range
    Application.DisplayAlerts = False
    Set rPrintArea = Application.InputBox(Prompt:="Use Mouse to select area to Print.", Title:="Select Print Area", Type:=8)
    On Error GoTo 0
    W = 0: For Each Cl In rPrintArea.Columns: W = W + Cl.Width + Cl.Borders(xlEdgeLeft).Weight + Cl.Borders(xlEdgeRight).Weight: Next Cl
    H = 0: For Each Rw In rPrintArea.Rows: H = H + Rw.Height + Rw.Borders(xlEdgeTop).Weight + Rw.Borders(xlEdgeBottom).Weight: Next Rw
    Application.DisplayAlerts = True
    If rPrintArea Is Nothing Then Exit Sub
    Application.PrintCommunication = False  'Can only be used in xl2010
    With ActiveSheet.PageSetup
        On Error GoTo ErrorHandler
        M1 = Round(Application.InchesToPoints(21 / 2.54) - (.LeftMargin + .RightMargin)) / W
        M2 = Round(Application.InchesToPoints(29.7 / 2.54) - (.TopMargin + .BottomMargin)) / H
        .Orientation = xlLandscape
        .PaperSize = xlPaperA4
        .LeftMargin = 27                     '72 points per inch
        .RightMargin = 27
        .PrintArea = rPrintArea.Address
        .Zoom = IIf(M1 < M2, M1, M2) * 100
        '.FitToPagesTall = False
        '.FitToPagesWide = 1
    End With
    Application.PrintCommunication = True
    ans = MsgBox(Prompt:="Yes to Print." & vbCrLf & "No to Preview." & vbCrLf & "Cancel To Abort", Buttons:=vbYesNoCancel, Title:="Print?")
    If ans = vbCancel Then Exit Sub
    If ans = vbYes Then
        rPrintArea.PrintOut
    Else
        rPrintArea.PrintOut Preview:=True, Collate:=True
    End If
    Exit Sub
ErrorHandler:
    ActiveSheet.PageSetup.Zoom = 400
    rPrintArea.PrintOut Preview:=True, Collate:=True
End Sub