vbnet
复制代码
Public xlPaperA2%
Sub 填满页面排版()
xlPaperA2 = 66 'A2编号66
Dim ws As Worksheet: Set ws = ActiveSheet
Dim FirstCol As Long, LastCol As Long, LastRow As Long
Dim TargetRange As Range
Dim UsablePageWidth As Double
Dim CurrentWidth As Double
Dim StartFontSize As Double, BestFontSize As Double
Dim TestSize As Double
Dim StepSize As Double: StepSize = 0.05 ' 精细步长
Dim MaxFontSize As Double: MaxFontSize = 48
Dim OriginalView As Long
' ===== 1. 获取数据范围 =====
On Error Resume Next
With ws
LastCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
FirstCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
On Error GoTo 0
If LastCol = 0 Then Exit Sub
If FirstCol > LastCol Then Exit Sub
If LastRow = 0 Then LastRow = 1
Set TargetRange = ws.Range(ws.Cells(1, FirstCol), ws.Cells(LastRow, LastCol))
' ===== 2. 保存并切换到普通视图（防死机）=====
On Error Resume Next
OriginalView = ws.Parent.Windows(1).View
ws.Parent.Windows(1).View = xlNormalView
On Error GoTo 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' ===== 3. 安全获取当前字体大小 =====
Dim Temp As Variant
Temp = TargetRange.Font.Size
If IsNull(Temp) Or Temp <= 0 Or Temp > 100 Then
StartFontSize = 10
Else
StartFontSize = Temp
End If
' ===== 4. 计算页面可用宽度（磅）=====
UsablePageWidth = GetPageWidthInPoints(ws) - ws.PageSetup.LeftMargin - ws.PageSetup.RightMargin
If UsablePageWidth <= 0 Then UsablePageWidth = 400
' ===== 5. 核心：递增逼近最大填充字体 =====
BestFontSize = StartFontSize ' 至少用原始字体
TestSize = StartFontSize
Do While TestSize <= MaxFontSize
' 设置字体
TargetRange.Font.Size = TestSize
' 重新 AutoFit 列宽
TargetRange.EntireColumn.AutoFit
' 获取当前总宽度
CurrentWidth = TargetRange.Width
' 检查是否超出页面
If CurrentWidth > UsablePageWidth Then
' 超了，退出（上一个 TestSize 是合法的最大值）
Exit Do
Else
' 未超，记录为当前最佳
BestFontSize = TestSize
End If
TestSize = TestSize + StepSize
Loop
' ===== 6. 应用最佳字体 =====
TargetRange.Font.Size = BestFontSize
TargetRange.EntireColumn.AutoFit
CurrentWidth = TargetRange.Width ' 最终宽度
' ===== 7. 恢复视图 =====
On Error Resume Next
ws.Parent.Windows(1).View = OriginalView
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error GoTo 0
' ===== 8. 显示结果 & 列宽补偿 =====
Dim FillRatio As Double
FillRatio = CurrentWidth / UsablePageWidth
' ? 如果填充率太低，则用二分法拉宽
If CurrentWidth < UsablePageWidth * 0.99 Then
Dim TargetTotalWidth As Double
TargetTotalWidth = UsablePageWidth * 0.995 ' 目标填满 99.5%
' 调用二分法调整
AdjustToTargetWidth_Binary TargetRange, TargetTotalWidth
' 更新 CurrentWidth 用于后续判断
CurrentWidth = TargetRange.Width
End If
MsgBox "排版完成！" & vbCrLf & _
"最终字体：" & Format(BestFontSize, "0.1") & " pt" & vbCrLf & _
"可用宽度：" & Format(UsablePageWidth, "0.1") & " 磅" & vbCrLf & _
"实际宽度：" & Format(CurrentWidth, "0.1") & " 磅" & vbCrLf & _
"填充比例：" & Format(FillRatio * 100, "0.1") & "%" & vbCrLf & _
IIf(FillRatio >= 0.98, "? 几乎填满", "?? 接近填满"), vbInformation
End Sub
' ===== 二分法调整整体列宽（容忍 0.5cm 误差，稳定退出）=====
' 输入：
' TargetRange: 要调整的区域
' TargetWidth: 目标总宽度（磅）
' 输出：列宽被等比放大，总宽度逼近目标
Sub AdjustToTargetWidth_Binary(TargetRange As Range, TargetWidth As Double)
Dim Low As Double, High As Double, Mid As Double
Dim i As Long
Dim OriginalWidths() As Double
Dim CurrentTotalWidth As Double
Dim Tolerance As Double
Dim Iteration As Long
Dim ws As Worksheet: Set ws = TargetRange.Worksheet
' ===== 参数设置 =====
Tolerance = 14 ' ±0.5 cm ≈ 14 磅（28.35 pt/cm）
Low = 0.8 ' 最小缩小到 80%
High = 3 ' 最大放大到 300%
Iteration = 0
' ===== 保存原始列宽 =====
ReDim OriginalWidths(1 To TargetRange.Columns.Count)
On Error GoTo RestoreAndExit
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For i = 1 To TargetRange.Columns.Count
OriginalWidths(i) = TargetRange.Columns(i).ColumnWidth
Next i
' ===== 二分法逼近 =====
Do While Iteration < 50 ' 防止死循环
Mid = (Low + High) / 2
Iteration = Iteration + 1
' 应用缩放
For i = 1 To TargetRange.Columns.Count
TargetRange.Columns(i).ColumnWidth = OriginalWidths(i) * Mid
Next i
' 获取当前总宽度
On Error Resume Next
CurrentTotalWidth = TargetRange.Width
On Error GoTo 0
' 安全检查
If CurrentTotalWidth <= 0 Then
CurrentTotalWidth = 1
End If
' ===== 判断是否满足精度 =====
If Abs(CurrentTotalWidth - TargetWidth) <= Tolerance Then
Exit Do
End If
' 调整区间
If CurrentTotalWidth < TargetWidth Then
Low = Mid
Else
High = Mid
End If
' 区间足够小，退出
If (High - Low) < 0.0001 Then
Exit Do
End If
Loop
' ===== 输出结果 =====
Debug.Print "? 二分法完成："
Debug.Print " 迭代次数: " & Iteration
Debug.Print " 最终内容宽度: " & Format(CurrentTotalWidth, "0.0") & " 磅 ≈ " & Format(CurrentTotalWidth / 28.35, "0.1") & " cm"
Debug.Print " 目标宽度: " & Format(TargetWidth, "0.0") & " 磅 ≈ " & Format(TargetWidth / 28.35, "0.1") & " cm"
Debug.Print " 剩余误差: " & Format(Abs(CurrentTotalWidth - TargetWidth), "0.0") & " 磅 ≈ " & Format(Abs(CurrentTotalWidth - TargetWidth) / 28.35, "0.2") & " cm"
RestoreAndExit:
' 恢复设置
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Err.Clear
End Sub
' ===== 工具函数：获取页面实际打印宽度（磅） =====
' 输入：Worksheet
' 输出：横向时返回长边，纵向时返回短边（已考虑方向）
' 特点：只认 PaperSize 数值，不依赖 xlPaperXXX 枚举
Function GetPageWidthInPoints(ws As Worksheet) As Double
Dim PaperSize As Long
Dim WidthCm As Double ' 纸张宽度（纵向时的宽度）
Dim HeightCm As Double ' 纸张高度（纵向时的高度）
PaperSize = ws.PageSetup.PaperSize
' ===== 统一用厘米定义纸张尺寸（纵向时） =====
Select Case PaperSize
Case 66, 18 ' A2
WidthCm = 42#
HeightCm = 59.4
Case 11 ' A3
WidthCm = 29.7
HeightCm = 42#
Case 9 ' A4
WidthCm = 21#
HeightCm = 29.7
Case 13 ' A5
WidthCm = 14.8
HeightCm = 21#
Case 14 ' A6
WidthCm = 10.5
HeightCm = 14.8
Case 12 ' B4
WidthCm = 25#
HeightCm = 35.3
Case 15 ' B5
WidthCm = 17.6
HeightCm = 25#
Case 1 ' Letter
WidthCm = 21.59 ' 8.5 in
HeightCm = 27.94 ' 11 in
Case 4 ' Legal
WidthCm = 21.59
HeightCm = 35.56 ' 14 in
Case 50 ' B5 (JIS)
WidthCm = 18.2
HeightCm = 25.7
Case 51 ' A4 Narrow
WidthCm = 21#
HeightCm = 28.4
Case Else
' 默认：A4
WidthCm = 21#
HeightCm = 29.7
End Select
' ===== 根据方向决定返回哪个维度 =====
On Error Resume Next
If ws.PageSetup.Orientation = xlLandscape Then
' 横向：页面宽度 = 纸张高度（长边）
GetPageWidthInPoints = Application.CentimetersToPoints(HeightCm)
Else
' 纵向：页面宽度 = 纸张宽度（短边）
GetPageWidthInPoints = Application.CentimetersToPoints(WidthCm)
End If
' ===== 安全兜底 =====
If Err.Number <> 0 Or GetPageWidthInPoints <= 0 Then
GetPageWidthInPoints = Application.CentimetersToPoints(21) ' A4 宽
Err.Clear
End If
On Error GoTo 0
End Function
'' ===== 辅助函数：根据 PaperSize 数值返回纸张高度（英寸）=====
'' 说明：直接使用数字，不依赖 xlPaperXXX 枚举，避免未定义问题
'Function GetPageHeightInInches(PaperSize As Long) As Double
' Select Case PaperSize
' Case 66, 18 ' A2: 42.0 cm × 59.4 cm → 高度 59.4 cm = 23.39 英寸
' GetPageHeightInInches = 23.39 ' 59.4 cm
' Case 11 ' A3: 29.7 × 42.0 cm → 高度 42.0 cm
' GetPageHeightInInches = 16.54 ' 42.0 cm
' Case 9 ' A4: 21.0 × 29.7 cm → 高度 29.7 cm
' GetPageHeightInInches = 11.69 ' 29.7 cm
' Case 13 ' A5: 14.8 × 21.0 cm
' GetPageHeightInInches = 8.27 ' 21.0 cm
' Case 14 ' A6: 10.5 × 14.8 cm
' GetPageHeightInInches = 5.83 ' 14.8 cm
' Case 12 ' B4: 25.0 × 35.3 cm
' GetPageHeightInInches = 13.89 ' 35.3 cm
' Case 15 ' B5: 17.6 × 25.0 cm
' GetPageHeightInInches = 9.84 ' 25.0 cm
' Case 1 ' Letter: 8.5 × 11 in
' GetPageHeightInInches = 11
' Case 4 ' Legal: 8.5 × 14 in
' GetPageHeightInInches = 14
' Case 50 ' B5 (JIS): 常见打印机选项
' GetPageHeightInInches = 9.84
' Case 51 ' A4 小（窄）: 21.0 × 28.4 cm
' GetPageHeightInInches = 11.18
' Case Else
' ' 默认返回 A4 高度
' GetPageHeightInInches = 11.69
' End Select
'End Function
Sub 检查页面参数()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim FirstCol As Long, LastCol As Long, LastRow As Long
Dim TargetRange As Range
Dim UsablePageWidth As Double
Dim ContentWidth As Double
Dim LeftMarginPt As Double, RightMarginPt As Double
Dim PagePrintableStartX As Double ' 可打印区域起始X（距左边）
Dim ContentEndX As Double ' 内容结束位置（距左边）
Dim PagePrintableEndX As Double ' 可打印区域结束位置（距左边）
Dim RightGap As Double ' 右侧剩余空白（磅）
Dim RightGapCm As Double ' 右侧剩余空白（厘米）
Dim TEM_S As String
With ws.PageSetup
TEM_S = TEM_S & vbCrLf & "=== 页面设置参数 ==="
TEM_S = TEM_S & vbCrLf & "纸张大小代码:" & .PaperSize
TEM_S = TEM_S & vbCrLf & "方向:" & IIf(.Orientation = xlPortrait, "纵向", "横向")
LeftMarginPt = .LeftMargin
RightMarginPt = .RightMargin
TEM_S = TEM_S & vbCrLf & "左页边距:" & LeftMarginPt & "磅 ≈" & Format(LeftMarginPt / 28.35, "0.0") & "cm"
TEM_S = TEM_S & vbCrLf & "右页边距:" & RightMarginPt & "磅 ≈" & Format(RightMarginPt / 28.35, "0.0") & "cm"
End With
' ===== 计算页面总宽度（打印区域宽度）=====
Dim PageTotalPrintableWidth As Double
PageTotalPrintableWidth = GetPageWidthInPoints(ws) - LeftMarginPt - RightMarginPt
TEM_S = TEM_S & vbCrLf & "页面可用宽度（计算）:" & PageTotalPrintableWidth & "磅"
TEM_S = TEM_S & vbCrLf & "页面可用宽度（厘米）:" & Format(PageTotalPrintableWidth / 28.35, "0.1") & "cm"
' ===== 获取内容范围 =====
On Error Resume Next
With ws
LastCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
FirstCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
On Error GoTo 0
If LastCol = 0 Or FirstCol > LastCol Or LastRow = 0 Then
TEM_S = TEM_S & "?? 未找到数据"
Exit Sub
End If
Set TargetRange = ws.Range(ws.Cells(1, FirstCol), ws.Cells(LastRow, LastCol))
ContentWidth = TargetRange.Width
TEM_S = TEM_S & vbCrLf & "内容实际宽度:" & ContentWidth & "磅 ≈" & Format(ContentWidth / 28.35, "0.1") & "cm"
' ===== 计算右侧剩余边距 =====
' 可打印区域起始 X 坐标（从页面左边开始）
PagePrintableStartX = LeftMarginPt
' 可打印区域结束 X 坐标
PagePrintableEndX = LeftMarginPt + PageTotalPrintableWidth
' 内容结束位置（从页面左边开始）
ContentEndX = LeftMarginPt + ContentWidth
' 右侧剩余空白
RightGap = PagePrintableEndX - ContentEndX
RightGapCm = RightGap / 28.35
TEM_S = TEM_S & vbCrLf & "右侧剩余边距:" & RightGap & "磅 ≈" & Format(RightGapCm, "0.1") & "cm"
If RightGapCm > 0 Then
TEM_S = TEM_S & vbCrLf & "? 右边还能再挤进" & Format(RightGapCm, "0.1") & "cm"
Else
TEM_S = TEM_S & "? 内容已超出可用区域！" & Format(RightGapCm, "0.1") & "cm"
End If
T_CHECK_PAGES.Text = TEM_S
End Sub
' ===== 按钮事件 =====
Private Sub CMD_AUTO_COL_WIDTH_Click()
填满页面排版
End Sub
Private Sub cmd_checkpage_Click()
检查页面参数
End Sub
