自定义报表纸张大小的函数

时　间:2017-05-07 08:58:28
作　者:MDZZ   ID：47512  城市：南京
摘　要:自定义报表纸张大小
正　文:

Option Compare Database
Option Explicit

'--------------------------------------------------------------------------------------
'数据类型定义
Private Type str_DEVMODE
    RGB As String * 1172 '(148+1024)
End Type
Private Type type_DEVMODE
    strDeviceName(1 To 32) As Byte
    intSpecVersion As Integer
    intDriverVersion As Integer
    intSize As Integer
    intDriverExtra As Integer
    lngFields As Long
    intOrientation As Integer
    intPaperSize As Integer
    intPaperLength As Integer
    intPaperWidth As Integer
    intScale As Integer
    intCopies As Integer
    intDefaultSource As Integer
    intPrintQuality As Integer
    intColor As Integer
    intDuplex As Integer
    intResolution As Integer
    intTTOption As Integer
    intCollate As Integer
    strFormName(1 To 32) As Byte
    intLogPixels As Integer
    lngBitsPerPixel As Long
    lngPelsWidth As Long
    lngPelsHeight As Long
    lngDisplayFlags As Long
    lngDisplayFrequency As Long

    lngICMMethod As Long
    lngICMIntent As Long
    lngMediaType As Long
    lngDitherType As Long
    lngICCManufacturer As Long
    lngICCModel As Long
    bytDriverExtra(1 To 1024) As Byte

End Type

Private Type str_PRTMIP
    strRGB As String * 28
End Type

Private Type type_PRTMIP
    xLeftMargin As Long
    yTopMargin As Long
    xRightMargin As Long
    yBottomMargin As Long
    fDataOnly As Long
    xWidth As Long
    yHeight As Long
    fDefaultSize As Long
    cxColumns As Long
    yColumnSpacing As Long
    xRowSpacing As Long
    rItemLayout As Long
    fFastPrint As Long
fDatasheet As Long
End Type

Private Const glrcDMOrientation = &H1
Private Const glrcDMPaperSize = &H2
Private Const glrcDMPaperLength = &H4
Private Const glrcDMPaperWidth = &H8
Private Const glrcDMScale = &H10
Private Const glrcDMCopies = &H100
Private Const glrcDMDefaultSource = &H200
Private Const glrcDMPrintQuality = &H400
Private Const glrcDMColor = &H800
Private Const glrcDMDuplex = &H1000
Private Const glrcDMYResolution = &H2000
Private Const glrcDMTTOption = &H4000

'--------------------------------------------------------------------------------------
'SetCustomPaperSize()

'为报表设置指定大小的纸张，边距，成功返回255，失败返回0
'参数说明：
'strRptname   必须，报表名，字符串
'PaperWidth   必须，纸张宽度，整数，单位mm
'PaperLength  必须，纸张长度，整数，单位mm

'Orientation  可选，纸张方向，整数，，默认 1 纵向，2为横向
'TopMargin    可选，上边距，整数，单位mm，默认 10mm
'BottomMargin     可选，下边距，整数，单位mm，默认 10mm
'LeftMargin   可选，左边距，整数，单位mm，默认 10mm
'RightMargin  可选，右边距，整数，单位mm，默认 10mm

'调用实例:SetCustomPaperSize"报表名",50,50

'--------------------------------------------------------------------------------------
Public Function SetCustomPaperSize(ByVal strRptname As String, PaperWidth As Integer, _
        PaperLength As Integer, Optional orientation As Integer = 1, _
        Optional TopMargin As Integer = 10, Optional BottomMargin As Integer = 10, _
        Optional LeftMargin As Integer = 10, Optional RightMargin As Integer = 10) As Integer

On Error GoTo Err_SetConstPaperSize
    
    Dim DevString As str_DEVMODE
    Dim DM As type_DEVMODE
    Dim strDevModeExtra As String
    Dim rpt As Report
    Dim intResponse As Integer
    
    Dim PrtMipString As str_PRTMIP
    Dim PM As type_PRTMIP
    
    
    ' Opens report in Design view.
    DoCmd.OpenReport strRptname, acDesign
    Set rpt = Reports(strRptname)
    
    If Not IsNull(rpt.PrtDevMode) Then
        
        strDevModeExtra = rpt.PrtDevMode
        ' Gets current DEVMODE structure.
        DevString.RGB = strDevModeExtra
        LSet DM = DevString
        
        ' Set custom page.
        DM.intPaperSize = 256
        ' Prompt for length and width. unit 1/10mm
        DM.intPaperLength = PaperLength * 10
        DM.intPaperWidth = PaperWidth * 10
        ' 纵向
        DM.intOrientation = orientation
        '这一句是关键：通知驱动程序对那些作了修改，要不就会不起作用，帮助中忽略了这一点
        DM.lngFields = DM.lngFields or glrcDMPaperSize or glrcDMPaperLength _
                                    or glrcDMPaperWidth or glrcDMOrientation
        ' Update property.
        LSet DevString = DM
        Mid(strDevModeExtra, 1, 94) = DevString.RGB
        rpt.PrtDevMode = strDevModeExtra
    End If
    
    PrtMipString.strRGB = rpt.PrtMip
    LSet PM = PrtMipString
    'MsgBox PM.yTopMargin / 56.7 & "cm " & PM.yBottomMargin / 56.7 & "cm " _
        & PM.xLeftMargin / 56.7 & "cm " & PM.xRightMargin / 56.7 & "cm "
    
    PM.xLeftMargin = LeftMargin * 56.7 '边距设置为 10 mm -> TWIPE
    PM.xRightMargin = RightMargin * 56.7
    PM.yTopMargin = TopMargin * 56.7
    PM.yBottomMargin = BottomMargin * 56.7
    PM.fDefaultSize = False
    ' Update property.
    LSet PrtMipString = PM
    rpt.PrtMip = PrtMipString.strRGB
    'DoCmd.OpenReport rptname, acViewPreview '预览
    'DoCmd.PrintOut acPages, 1, 1
    'DoCmd.OpenReport Rptname, acViewNormal
    DoCmd.Close acReport, strRptname, acSaveYes
    SetCustomPaperSize = 255
    
Exit_SetConstPaperSize:
    Exit Function
Err_SetConstPaperSize:
    'MsgBox "错误：：" & Err.Number & vbNewLine & Err.Description
    SetCustomPaperSize = 0
    Resume Exit_SetConstPaperSize
End Function