access的papersize命令_自定义报表纸张大小的函数

时　间:2017-05-07 08:58:28

作　者:摘　要:自定义报表纸张大小

正　文:

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

Access软件网QQ交流群(群号:39785885)

Access源码网店