李洪根大哥,帮帮忙

参考
http://support.microsoft.com/default.aspx?scid=kb;EN-US;282474

就是这个：
http://support.microsoft.com/default.aspx?scid=kb;EN-US;282474

如果在win98 ，可以用
http://search.csdn.net/Expert/topic/384/384306.xml?temp=.2904474

这是小弟写的自定义纸张的代码
模块:
'由於本人對API不甚熟悉,所以有些地方可能會有錯誤,如果您知道,肯請斧正
Option ExplicitPublic Declare Function EnumForms Lib "winspool.drv" Alias "EnumFormsA" _
    (ByVal hPrinter As Long, ByVal Level As Long, ByRef pForm As Any, _
    ByVal cbBuf As Long, ByRef pcbNeeded As Long, _
    ByRef pcReturned As Long) As Long     '枚舉出當前打印機的所有頁形Public Declare Function AddForm Lib "winspool.drv" Alias "AddFormA" _
    (ByVal hPrinter As Long, ByVal Level As Long, pForm As Byte) As Long
                                            '添加一個頁形
Public Declare Function OpenPrinter Lib "winspool.drv" _
    Alias "OpenPrinterA" (ByVal pPrinterName As String, _
    phPrinter As Long, ByVal pDefault As Long) As Long
                                            '打開一個打印機並獲得它的句柄
Public Declare Function ClosePrinter Lib "winspool.drv" _
    (ByVal hPrinter As Long) As Long        '關閉打印機Public Declare Function DocumentProperties Lib "winspool.drv" _
    Alias "DocumentPropertiesA" (ByVal hwnd As Long, _
    ByVal hPrinter As Long, ByVal pDeviceName As String, _
    pDevModeOutput As Any, pDevModeInput As Any, ByVal fMode As Long) _
    As Long                                 '設置控制打印機的一些屬性和結構,可以取得打印機的Devmode結構
Public Declare Function ResetDC Lib "gdi32" Alias "ResetDCA" _
    (ByVal hdc As Long, lpInitData As Any) As Long
                                            '根據提供的Devmode結構,對一個設備場景進行重設(重新指定[**當前打印**]的頁形等),僅對當前打印進程有效!
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
                                            '拷貝指定長度的內存,用於對一個有用數據的備份(一般用於結構(c語言用語,vb中叫自定義類型))
Public Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" _
    (ByVal lpString1 As String, ByRef lpString2 As Long) As Long '字符串拷貝,可以根據一個字符串的地址來獲得它的內容
'DEVMODE結構要用的常量
Public Const CCHFORMNAME = 32
Public Const CCHDEVICENAME = 32
Public Const DM_FORMNAME As Long = &H10000
Public Const DM_ORIENTATION = &H1&' Constants for PRINTER_DEFAULTS.DesiredAccess
Public Const PRINTER_ACCESS_ADMINISTER = &H4
Public Const PRINTER_ACCESS_USE = &H8
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const PRINTER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or _
  PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE)'定義DocumentProperties()調用所需的常量
Public Const DM_MODIFY = 8
Public Const DM_IN_BUFFER = DM_MODIFY
Public Const DM_COPY = 2
Public Const DM_OUT_BUFFER = DM_COPY' 定義selectform()返回的結果常量
Public Const FORM_NOT_SELECTED = 0
Public Const FORM_SELECTED = 1'下面是這些API中所需要的自定義類型
Public Type RECTL
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End TypePublic Type SIZEL
        cx As Long
        cy As Long
End TypePublic Type SECURITY_DESCRIPTOR
        Revision As Byte
        Sbz1 As Byte
        Control As Long
        Owner As Long
        Group As Long
        Sacl As Long  ' ACL
        Dacl As Long  ' ACL
End Type' The two definitions for FORM_INFO_1 make the coding easier.
'上面那句注釋是它原來的注釋,本人不甚理解,只知道大概意思,所以不敢譯成中文
'它的意思是說本來要用FORM_INFO_1,加一個sFORM_INFO_1是為了使編碼簡單一些
'FORM_INFO_1中pName表示指向頁形名的指針(Long),sFORM_INFO_1中則將它變為了string類型
Public Type FORM_INFO_1
        flags As Long
        pName As Long   ' String
        Size As SIZEL
        ImageableArea As RECTL
End TypePublic Type sFORM_INFO_1
        flags As Long
        pName As String
        Size As SIZEL
        ImageableArea As RECTL
End Type
Public Type DEVMODE
        dmDeviceName As String * CCHDEVICENAME
        dmSpecVersion As Integer
        dmDriverVersion As Integer
        dmSize As Integer
        dmDriverExtra As Integer
        dmFields As Long
        dmOrientation As Integer
        dmPaperSize As Integer
        dmPaperLength As Integer
        dmPaperWidth As Integer
        dmScale As Integer
        dmCopies As Integer
        dmDefaultSource As Integer
        dmPrintQuality As Integer
        dmColor As Integer
        dmDuplex As Integer
        dmYResolution As Integer
        dmTTOption As Integer
        dmCollate As Integer
        dmFormName As String * CCHFORMNAME
        dmUnusedPadding As Integer
        dmBitsPerPel As Long
        dmPelsWidth As Long
        dmPelsHeight As Long
        dmDisplayFlags As Long
        dmDisplayFrequency As Long
End TypePublic Type PRINTER_DEFAULTS
        pDatatype As String
        pDevMode As Long    ' DEVMODE
        DesiredAccess As Long
End TypePublic Type PRINTER_INFO_2
        pServerName As String
        pPrinterName As String
        pShareName As String
        pPortName As String
        pDriverName As String
        pComment As String
        pLocation As String
        pDevMode As DEVMODE
        pSepFile As String
        pPrintProcessor As String
        pDatatype As String
        pParameters As String
        pSecurityDescriptor As SECURITY_DESCRIPTOR
        Attributes As Long
        Priority As Long
        DefaultPriority As Long
        StartTime As Long
        UntilTime As Long
        Status As Long
        cJobs As Long
        AveragePPM As Long
End Type

模块:'***查找指定頁形,若找到則將它指定給當前打印設備上下文,若成功則返回1,若找不到,則添加指定頁形,***
'***如果添加成功,則也將它指定給當前打印設備上下文,若成功則返回1.如果添加不成功,則返回0*********Public Function SelectForm(ByVal MyhWnd As Long, FormSize As SIZEL, Formname As String) As Integer
Dim nSize As Long           ' DEVMODE結構大小
Dim pDevMode As DEVMODE
Dim PrinterHandle As Long   ' 打印機句柄
Dim hPrtDC As Long          ' Printer DC的句柄
Dim PrinterName As String
Dim aDevMode() As Byte      '  用於拷貝DEVMODE結構,用數組取地址
Dim hprint As Long
Dim hdc    As Long
PrinterName = Printer.DeviceName  ' 當前打印機名稱
hPrtDC = Printer.hdc              ' 當前打印機的hdc,用於resetdc()
hprint = OpenPrinter(PrinterName, PrinterHandle, 0&) '打開打印機並獲得打印機句柄
If hprint = 0 Then  '打開打印機失敗
    MsgBox "Open Printer Error,Please Check Your Printer.Make Sure" & vbCrLf & " The Printer Connecting The Computer And The Driver is OK!", vbCritical, "ERROR"
    SelectForm = FORM_NOT_SELECTED
    Exit Function
End If
' 獲得Devmode結構
nSize = DocumentProperties(MyhWnd, PrinterHandle, PrinterName, 0&, 0&, 0&)
' 獲得Devmode結構的實際大小
ReDim aDevMode(1 To nSize)
' 從打印機填充DEVMODE結構
nSize = DocumentProperties(MyhWnd, PrinterHandle, PrinterName, _
            aDevMode(1), 0&, DM_OUT_BUFFER)
Call CopyMemory(pDevMode, aDevMode(1), Len(pDevMode))
'如果找不到就添加
If GetFormName(PrinterHandle, FormSize, Formname) = 0 Then
    If AddNewForm(PrinterHandle, FormSize, Formname) = 0 Then
        'If GetFormName(PrinterHandle, FormSize, Formname) = 0 Then
        '微軟的文檔中有這句,在下覺得微軟實在是太謹慎了,添加成功可以從函數
        '返回值知道,可微軟還要再找指定頁形存不存在,搞不懂微軟這麼謹慎怎麼操作系統還是那麼多BUG
        ClosePrinter (PrinterHandle)
        SelectForm = FORM_NOT_SELECTED   '添加頁形失敗返回
        MsgBox "The PrintForm Not Exists,Please Add a Appropriate PrintForm For The Printer!", vbInformation + vbOKOnly, "INFORMATION!"
        Exit Function
    End If
End If
pDevMode.dmFormName = Formname & Chr(0) '加上chr(0)字符,這是c需要的
pDevMode.dmFields = DM_FORMNAME
Call CopyMemory(aDevMode(1), pDevMode, Len(pDevMode))
nSize = DocumentProperties(MyhWnd, PrinterHandle, PrinterName, _
        aDevMode(1), aDevMode(1), DM_IN_BUFFER Or DM_OUT_BUFFER)
hdc = ResetDC(hPrtDC, aDevMode(1))   '將該頁指定為當前打印設備上下文,僅對當前打印進程有效
ClosePrinter (PrinterHandle)
If hdc = 0 Then
    SelectForm = FORM_NOT_SELECTED
Else
    SelectForm = FORM_SELECTED
End If
End Function'--------------------------------------------------------------------
'***查找當前打印機的所有頁形中是否存在指定的頁形,***
'***若找到,則返回1,並且將頁形名賦值給Formname傳回,找不到返回0,******
'--------------------------------------------------------------------
Public Function GetFormName(ByVal PrinterHandle As Long, FormSize As SIZEL, Formname As String) As Integer
Dim NumForms As Long, i As Long
Dim FI1 As FORM_INFO_1
Dim aFI1() As FORM_INFO_1           ' 定義一個有關打印機信息類型的數組
Dim Temp() As Byte                  ' 字節數組,用於傳址
Dim BytesNeeded As Long
Dim RetVal As LongFormname = "NONE"
ReDim aFI1(1)
' 第一次調用來取得BytesNeeded(緩沖區的大小)
RetVal = EnumForms(PrinterHandle, 1, aFI1(0), 0&, BytesNeeded, NumForms)
ReDim Temp(BytesNeeded)
ReDim aFI1(BytesNeeded / Len(FI1))
' 第二次調用列舉出實際支持的所有頁形
RetVal = EnumForms(PrinterHandle, 1, Temp(0), BytesNeeded, BytesNeeded, _
         NumForms)
Call CopyMemory(aFI1(0), Temp(0), BytesNeeded)
For i = 0 To NumForms - 1
    With aFI1(i)
        '判斷頁形是否為所希望的格式(這里不是從名稱來找,因為擔心用戶定義的名稱可能不一樣)
        If .Size.cx = FormSize.cx And .Size.cy = FormSize.cy Then
            Formname = PtrCtoVbString(.pName)
            GetFormName = 1     '若找到則返回1
            Exit Function
        End If
    End With
Next i
GetFormName = 0 '如果找不到則返回0
End Function'***當找不到希望的頁形時,添加一個頁形,其中PrinterHandle為打印机句柄***
'***FormSize為頁形的大小(長,寬),FormName為頁形名稱,返回0表示添加頁****
'***形不成功,1表示成功***
Public Function AddNewForm(PrinterHandle As Long, FormSize As SIZEL, Formname As String) As Integer
Dim FI1 As sFORM_INFO_1   '定義打印機信息的結構
Dim aFI1() As Byte        '字節數組用於得到結構的地址,以便於傳址
Dim RetVal As LongWith FI1
    .flags = 0
    .pName = Formname
    With .Size
        .cx = FormSize.cx
        .cy = FormSize.cy
    End With
    With .ImageableArea
        .Left = 0
        .Top = 0
        .Right = FI1.Size.cx
        .Bottom = FI1.Size.cy
    End With
End With
ReDim aFI1(Len(FI1))
Call CopyMemory(aFI1(0), FI1, Len(FI1))
RetVal = AddForm(PrinterHandle, 1, aFI1(0))
If RetVal = 0 Then   '若增加不成功
    AddNewForm = 0
Else
    AddNewForm = 1
End If
End Function'***根據頁形名存放的地址來獲得頁形的名稱***
Public Function PtrCtoVbString(ByVal Addr As Long) As String
Dim sTemp As String * 512, X As Long
X = lstrcpy(sTemp, ByVal Addr)          '拷貝地址所指向的字符串到stemp中
If (InStr(1, sTemp, Chr(0)) = 0) Then   '找不到字符串結束符(判斷是否字符串)
     PtrCtoVbString = ""
Else
     PtrCtoVbString = Left(sTemp, InStr(1, sTemp, Chr(0)) - 1) '返回頁形名,去掉stemp后面的空白
End If
End Function

在窗体中调用:
Private Sub cmdPr_Click(Index As Integer)
Dim rstmp As New ADODB.Recordset, strSQL As String
Dim intReprint As Integer
Dim strDeliDate As String
Dim strSotype As String
Dim strTrans As String
Dim strDoNoFm As String
Dim strDoNoTo As String
Dim hwind As Long
Dim pformsize As SIZEL
Dim pformname As String
Dim printform As Integer
'On Error Resume Next
On Error GoTo ShowErr
If Chk.Value = 0 Then
  If ChkDate(txtdate.Text, txtdate.Value) = False Then
     MsgBox "Invalid Date!"
     txtdate.SetFocus
     Exit Sub
  End If
  If Left(cmbSto.Text, 1) <> "G" And Left(cmbSto.Text, 1) <> "C" Then
     MsgBox "Invalid Storage Type!"
     cmbSto.SetFocus
     Exit Sub
  End If
  intReprint = 0
  strDeliDate = IIf(Trim(txtdate.Text) = "/  /", " ", txtdate.Text)
  strSotype = UCase(Left(Trim(cmbSto.Text), 1))
  strTrans = IIf(Trim(txtTrans.Text) = "", " ", Trim(txtTrans.Text))
  strDoNoFm = " "
  strDoNoTo = " "strSQL = "SELECT o13m.do_no,o13m.Deli_to1, o13m.Deli_to2,o13m.Transporter," & _
    "o13m.Deli_no,o13m.dn_print_num,o13m.Deli_date " & _
    "from o13m WHERE o13m.Deli_date = '" & strDeliDate & "' and " & _
    "o13m.so_type = '" & strSotype & "' and " & _
    "('" & strTrans & "' = '' or o13m.Transporter = '" & strTrans & "') and o13m.deli_print=0"
Else
  intReprint = 1
  strDeliDate = " "
  strSotype = "A"
  strTrans = " "
  strDoNoFm = IIf(Trim(txtDnFr.Text) = "", " ", Trim(txtDnFr.Text))
  strDoNoTo = IIf(Trim(txtDnTo.Text) = "", " ", Trim(txtDnTo.Text))strSQL = "SELECT o13m.do_no,o13m.Deli_to1, o13m.Deli_to2,o13m.Transporter," & _
    "o13m.Deli_no,o13m.dn_print_num,o13m.Deli_date " & _
    "FROM o13m WHERE (o13m.Deli_no between '" & strDoNoFm & "' and '" & strDoNoTo & "') and o13m.deli_print=1"End If
'strsql = "exec Rpt_O2240R " & intReprint & "," & _
'            Sqv(strDeliDate) & "," & _
'            Sqv(strSotype) & "," & _
'            Sqv(strTrans) & "," & _
'            Sqv(strDoNoFm) & "," & _
'            Sqv(strDoNoTo) & ","
rstmp.Open strSQL, pConn, adOpenKeyset, adLockReadOnly
Me.MousePointer = 11
If rstmp.RecordCount = 0 Then
    MsgBox "No record!", vbInformation, "Information"
    Me.MousePointer = 0
    Exit Sub
End If
    rpt.WindowShowSearchBtn = True
    rpt.WindowState = crptMaximized
    rpt.WindowShowPrintSetupBtn = True
    rpt.WindowBorderStyle = crptSizable
    rpt.WindowAllowDrillDown = True
    rpt.WindowMaxButton = True
    rpt.WindowShowExportBtn = True
    rpt.WindowShowRefreshBtn = True
    rpt.WindowShowPrintBtn = True
    rpt.StoredProcParam(0) = intReprint
    rpt.StoredProcParam(1) = strDeliDate
    rpt.StoredProcParam(2) = strSotype
    rpt.StoredProcParam(3) = strTrans
    rpt.StoredProcParam(4) = strDoNoFm
    rpt.StoredProcParam(5) = strDoNoTo
    rpt.StoredProcParam(6) = 1
    rpt.Connect = strReportConn
    rpt.ReportFileName = ReportPath & "o2240r.rpt"
    If Index = 0 Then
        rpt.Destination = crptToWindow
    Else
        hwind = Me.hWnd
        pformsize.cx = 254000
        pformsize.cy = 152400
        pformname = "DEBITNOTE"
        printform = SelectForm(hwind, pformsize, pformname)
        If printform = FORM_NOT_SELECTED Then
            Me.MousePointer = 0
            Exit Sub
        End If
        rpt.Destination = crptToPrinter
        MsgBox "印表機名稱: " & Printer.DeviceName & vbCrLf & _
               "印表機頁形: " & Printer.PaperSize & vbCrLf & _
               "紙張大小(英寸): " & Printer.ScaleX(Printer.Width, 1, 5) & "X" & Printer.ScaleY(Printer.Height, 1, 5) & vbCrLf & _
               "紙張大小(毫米): " & Printer.ScaleX(Printer.Width, 1, 6) & "X" & Printer.ScaleY(Printer.Height, 1, 6)
'        rpt.PrinterName = DeliNo_Port
'        rpt.PrinterSelect
'        If rpt.PrinterName = "" Then
'            Me.MousePointer = 0
'            Exit Sub
'        End If
'        'pConn.Execute strsql & "1"
'        rpt.Destination = crptToPrinter
    End If
'    rpt.Action = 1
    rpt.PrintReport
'    If printform = FORM_SELECTED Then
'        pConn.Execute strsql & "1"
'    End If
    rpt.Reset
    Me.MousePointer = 0
Exit Sub
ShowErr:
    MsgBox "Error number: " & Err.Number & vbCrLf & "Error Description: " & Err.Description
    Me.MousePointer = 0
    Err.Clear
End Sub

关于在WINDOWS2000\XP中自定义打印纸张的问题我要求的是在程序中自定义,而不是在打印机设置中自定义,
另外,要求随时要改变纸张大小,不是一设置就不变了.同用来打印报表的,如这张报表内容多一点,我就先把纸张设长一点,再打印,如要打印的报表内容少一点,我就把纸张设短一点,再打印.上个月已问李洪根老大,在回复的MSDN上看了标准答案,上面写的好像必须先添加一种自定义纸张,再调动该纸张类型.有没有好的办法,不要添加纸张类型,临时打印临时设置.非常感谢各位前辈

调试易

李洪根大哥,帮帮忙

解决方案 »