在ＶＦＰ中用程序向操作系统添加自定义纸张

[yinj12488]

我正在编写一个收费管理程序,要打印发票(以填充的方式),请问：在ＶＦＰ中用程序代码向操作系统添加自定义纸张？
不是“win2000 或XP 请通过，打印机-->服务器属性－－>格式-->创建新格式-->保存格式，转到VFP，报表－－>页面设置－选择自定义的纸张格式”这种方式添加自定义纸张。
望大侠们多多指点，谢谢！！！！

[十豆三]

转帖：

Windows 2000/XP下添加/删除自定义纸张的过程（可返回添加纸的id）
*--------------------------------------------------------------------

关于自定义打印纸的问题，论坛上有很多讨论，我知道mihu版主曾经发表过如何返回添加自定义纸的id的讨论。但都是没有比较完整的解决方法，我因为客户的需要，经过研究摸索，终于找到以下的方法解决，首先说明以下这段代码不是我的原创，我参考了网上收集回来的资料，加以整理，做成一个过程，使其可以带参数调用和返回添加纸的id（原来的代码没有返回值及不带参数）有了这个id号，那么在Win2000/xp下控制即打即停就可以解决了，我们可以根据打印的记录数计算出需要的打印纸长度，宽度一般是固定的，打印前调用该过程先添加自定义的打印纸（添加前会删除相同名称的打印纸），然后将报表的PAPERSIZE设为新添加的打印纸id即可。至于在Win98系统下更加简单，只需将报表的PAPERSIZE设为256，PAPERLENGTH设为需要的打印纸长度即可
你可以复制/粘贴以下代码，如有问题欢迎发贴讨论
*------------------------------------------------
*在 Windows 2000/XP 下添加/删除自定义纸张的示例代码
*调用方法：addpaper("自定义纸名",纸的宽度,纸的长度) 单位为0.1毫米
*返回值：如果添加成功则返回一个大于0的数值，这就是添加纸的id号.
Lpara lcformname,lnWidth,lnLength
Local lcformname,lnWidth,lnLength,oldalias ,lcstr,lcprinter,lcport
If pcount()<3
*msg("参数缺少！")
Return -1
Endif
lnLength=lnLength*100
lnWidth=lnWidth*100
Clea Dlls
Set Safety Off
oldalias = Alias()
Create Table killyou Free (dummy cdbuf(1))
Create Report killyou From killyou.Dbf
Use killyou.frx Alias killyou
lcstr = Expr
If Empty(lcstr)
Use In killyou
Delete File killyou.frx
Delete File killyou.frt
Delete File killyou.Dbf
If !Empty(oldalias)
Select (oldalias)
Endif
*msg("你的系统中没有安装打印机！")
Return -2
Endif
Store Memlines(Expr) To gnnumlines
lcprinter = ""
lcport = ""
For gncount = 1 To gnnumlines
If At("DEVICE=",Mline(Expr,gncount))<>0
lcprinter = Substr(Mline(Expr,gncount),8)
Endif
If At("OUTPUT",Mline(Expr,gncount))<>0
lcport = Substr(Mline(Expr,gncount),8)
Endif
Next
If Empty(lcport)
Use In killyou
Delete File killyou.frx
Delete File killyou.frt
Delete File killyou.Dbf
If !Empty(oldalias)
Select (oldalias)
Endif
*msg("当前打印机不是本地打印机！")
Return -3
Endif
Use In killyou
Delete File killyou.frx
Delete File killyou.frt
Delete File killyou.Dbf
*----------------------------------------------------------------
Declare Integer OpenPrinter In WinSpool.Drv As WS_OpenPrinter ;
string pPrinterName, ;
integer @phPrinter, ;
string pDefault
Declare Integer DocumentProperties In WinSpool.Drv ;
integer, ;
integer, ;
string, ;
string, ;
string, ;
integer
Declare Integer ClosePrinter In WinSpool.Drv As WS_ClosePrinter ;
integer hPrinter
Declare Integer EnumForms In WinSpool.Drv ;
Integer, ;
Integer, ;
String @, ;
Integer , ;
Integer @, ;
Integer @
Declare Integer AddForm In WinSpool.Drv ;
integer, ;
integer, ;
string
Declare Integer DeleteForm In WinSpool.Drv ;
integer, ;
string
Declare Long CreateDC In gdi32.Dll ;
string @cDriver, ;
string @cDevice, ;
string cOutput, ;
string cInitData
Declare Long DeleteDC In gdi32.Dll ;
declare Long ResetDC In gdi32.Dll ;
integer, ;
string
Declare RtlMoveMemory In kernel32 As CopyMemory;
string @ Destination,;
integer Source,;
integer nLength
Declare Integer lstrcpy In kernel32.Dll ;
integer lpString1, String @lpString2
Declare Integer GetForm In WinSpool.drv ;
integer,;
string, ;
integer,;
string, ;
integer,;
integer
Declare Integer SetForm In WinSpool.drv ;
integer,;
string,;
integer,;
string
oheap = Createobj("Heap")
*----------------------------------------------------
revalue = getprintersettings(lcprinter,lcformname,lnWidth,lnLength)
Clear Dlls
Return revalue
*----------------------------------------------------
Function getprintersettings
Lpara lcprinter,lcformname,lnLength,lnWidth
Local lcprinter,lcformname,lnLength,lnWidth,hprinter ,nsize ,bytesneeded ,numforms, formname,retval
Local nstringbase , ns,bc,temp
hprinter = 0
nsize = 0
bytesneeded = 0
numforms = 0
If ws_openprinter(lcprinter, @hprinter, 0) <> 0 Then
formname=lcformname + Chr(0) + Chr(0)
* 删除自定义纸张
retval = deleteform(hprinter,lcformname)
If retval = 0 Then
*msg("删除自定义纸张时了生错误!")
Endif
nstringbase = oheap.allocblob(formname)
* 添加自定义纸张
retval = addform(hprinter,1,numtodword(0)+numtodword(nstringbase)+numtodword(lnLength)+numtodword(lnWidth)+numtodword(0)+numtodword(0)+numtodword(lnLength)+numtodword(lnWidth))
If retval = 0 Then
*msg("添加自定义纸张时发生了错误！")
Return 0
Endif
*------------------------------------
ns=Replicate(Chr(0), 32)
retval = enumforms(hprinter, 1, @ns, 0, @bytesneeded, @numforms)
*Return iif(retval = 0,retval,numforms)
bc=bytesneeded
temp=Replicate(Chr(0), bc)
retval = enumforms(hprinter, 1, @temp, bc , @bytesneeded, @numforms)
*-------------------------------------
=ws_closeprinter(hprinter)

Return iif(retval = 0,retval,numforms)
Else
*msg("打开打印机出错！")
Return -4
Endif
*----------------------------------------------------

[十豆三]

接上：
Define Class heap As Custom
Protected inhandle, innumallocsactive,iaallocs[1,3]
inhandle = Null
innumallocsactive = 0
iaallocs = Null
Name = "heap"
Procedure alloc
Lparameter nsize
Declare Integer HeapAlloc In WIN32API As HAlloc Integer hHeap, Integer dwFlags, Integer dwBytes
Declare Integer HeapSize In WIN32API As HSize Integer hHeap, Integer dwFlags, Integer lpcMem
Local nptr
With This
nptr = halloc(.inhandle, 0, @nsize)
If nptr # 0
.innumallocsactive = .innumallocsactive + 1
Dimension .iaallocs[.inNumAllocsActive,3]
.iaallocs[.inNumAllocsActive,1] = nptr
.iaallocs[.inNumAllocsActive,2] = hsize(.inhandle, 0, nptr)
.iaallocs[.inNumAllocsActive,3] = .T.
Else
nptr = Null
Endif
Endwith
Return nptr
Endproc
Function allocblob
Lparameter cbstringtocopy
Local nallocptr
With This
nallocptr = .alloc(Len(cbstringtocopy))
If ! Isnull(nallocptr)
.copyto(nallocptr,cbstringtocopy)
Endif
Endwith
Return nallocptr
Endfunc
Function allocstring
Lparameter cstring
Return This.allocblob(cstring + Chr(0))
Endfunc
Function allocinitas
Lparameter nsizeofbuffer, nbytevalue
If Type("nBytevalue") # "N" Or ! Between(nbytevalue,0,255)
nbytevalue = 0
Endif
Return This.allocblob(Replicate(Chr(nbytevalue),nsizeofbuffer))
Endfunc
Procedure dealloc
Lparameter nptr
Declare Integer HeapFree In WIN32API As HFree ;
integer hHeap, ;
integer dwFlags, ;
integer lpMem
Local nctr
nctr = Null
With This
nctr = .findallocid(nptr)
If ! Isnull(nctr)
=hfree(.inhandle, 0, nptr)
.iaallocs[nCtr,3] = .F.
Endif
Endwith
Return ! Isnull(nctr)
Endproc
Procedure copyto
Lparameter nptr, csource
Declare RtlMoveMemory In WIN32API As RtlCopy ;
integer nDestBuffer, ;
string @pVoidSource, ;
integer nLength
Local nctr
nctr = Null
If Type("nPtr") = "N" And Type("cSource") $ "CM" ;
and ! (Isnull(nptr) Or Isnull(csource))
With This
nctr = .findallocid(nptr)
If ! Isnull(nctr)
=rtlcopy((.iaallocs[nCtr,1]), ;
csource, ;
min(Len(csource),.iaallocs[nCtr,2]))
Endif
Endwith
Endif
Return ! Isnull(nctr)
Endproc
Procedure copyfrom
Lparameter nptr
Declare RtlMoveMemory In WIN32API As RtlCopy ;
string @DestBuffer, ;
integer pVoidSource, ;
integer nLength
Local nctr, ubuffer
ubuffer = Null
nctr = Null
If Type("nPtr") = "N" And ! Isnull(nptr)
With This
nctr = .findallocid(nptr)
If ! Isnull(nctr)
ubuffer = Repl(Chr(0),.iaallocs[nCtr,2])
=rtlcopy(@ubuffer, ;
(.iaallocs[nCtr,1]), ;
(.iaallocs[nCtr,2]))
Endif
Endwith
Endif
Return ubuffer
Endproc
Protected Function findallocid
Lparameter nptr
Local nctr
With This
For nctr = 1 To .innumallocsactive
If .iaallocs[nCtr,1] = nptr And .iaallocs[nCtr,3]
Exit
Endif
Endfor
Return Iif(nctr <= .innumallocsactive,nctr,Null)
Endwith
Endproc
Procedure sizeofblock
Lparameters nptr
Local nctr, nsizeofblock
nsizeofblock = Null
With This
nctr = .findallocid(nptr)
Return Iif(Isnull(nctr),Null,.iaallocs[nCtr,2])
Endwith
Endproc
Procedure Destroy
Declare HeapDestroy In WIN32API As HDestroy ;
integer hHeap
Local nctr
With This
For nctr = 1 To .innumallocsactive
If .iaallocs[nCtr,3]
.dealloc(.iaallocs[nCtr,1])
Endif
Endfor
hdestroy[.inHandle]
Endwith
DoDefault()
Endproc
Procedure Init
Declare Integer HeapCreate In WIN32API As HCreate ;
integer dwOptions, ;
integer dwInitialSize, ;
integer dwMaxSize
#Define swapfilepagesize 4096
#Define blockallocsize 2 * swapfilepagesize
With This
.inhandle = hcreate(0, blockallocsize, 0)
Dimension .iaallocs[1,3]
.iaallocs[1,1] = 0
.iaallocs[1,2] = 0
.iaallocs[1,3] = .F.
.innumallocsactive = 0
Endwith
Return (This.inhandle # 0)
Endproc
Enddefine
Function setmem
Lparameters nptr, csource
Declare RtlMoveMemory In WIN32API As RtlCopy ;
integer nDestBuffer, ;
string @pVoidSource, ;
integer nLength
rtlcopy(nptr, ;
csource, ;
len(csource))
Return .T.
Function getmem
Lparameters nptr, nlen
Declare RtlMoveMemory In WIN32API As RtlCopy ;
string @DestBuffer, ;
integer pVoidSource, ;
integer nLength
Local ubuffer
ubuffer = Repl(Chr(0),nlen)
=rtlcopy(@ubuffer, ;
nptr, ;
nlen)
Return ubuffer
Function getmemstring
Lparameters nptr, nsize
Declare Integer lstrcpyn In WIN32API As StrCpyN ;
string @ lpDestString, ;
integer lpSource, ;
integer nMaxLength
Local ubuffer
If Type("nSize") # "N" Or Isnull(nsize)
nsize = 512
Endif
ubuffer = Repl(Chr(0), nsize)
If strcpyn(@ubuffer, nptr, nsize-1) # 0
ubuffer = Left(ubuffer, Max(0,At(Chr(0),ubuffer) - 1))
Else
ubuffer = Null
Endif
Return ubuffer
Function shorttonum
Lparameter tcint
Local b0,b1,nretval
b0=Asc(tcint)
b1=Asc(Subs(tcint,2,1))
If b1<128
nretval=b1 * 256 + b0
Else
b1=255-b1
b0=256-b0
nretval= -( (b1 * 256) + b0)
Endif
Return nretval
Function numtoshort
Lparameter tnnum
Local b0,b1,x
If tnnum>=0
x=Int(tnnum)
b1=Int(x/256)
b0=Mod(x,256)
Else
x=Int(-tnnum)
b1=255-Int(x/256)
b0=256-Mod(x,256)
If b0=256
b0=0
b1=b1+1
Endif
Endif
Return Chr(b0)+Chr(b1)
Function dwordtonum
Lparameter tcdword
Local b0,b1,b2,b3
b0=Asc(tcdword)
b1=Asc(Subs(tcdword,2,1))
b2=Asc(Subs(tcdword,3,1))
b3=Asc(Subs(tcdword,4,1))
Return ( ( (b3 * 256 + b2) * 256 + b1) * 256 + b0)
Function numtodword
Lparameter tnnum
Return numtolong(tnnum)
Function wordtonum
Lparameter tcword
Return (256 * Asc(Subst(tcword,2,1)) ) + Asc(tcword)
Function numtoword
Lparameter tnnum
Local x
x=Int(tnnum)
Return Chr(Mod(x,256))+Chr(Int(x/256))
Function numtolong
Lparameter tnnum
Declare RtlMoveMemory In WIN32API As RtlCopyLong ;
string @pDestString, ;
integer @pVoidSource, ;
integer nLength
Local cstring
cstring = Space(4)
=rtlcopylong(@cstring, Bitor(tnnum,0), 4)
Return cstring
Function longtonum
Lparameter tclong
Declare RtlMoveMemory In WIN32API As RtlCopyLong ;
integer @ DestNum, ;
string @ pVoidSource, ;
integer nLength
Local nnum
nnum = 0
=rtlcopylong(@nnum, tclong, 4)
Return nnum
Function allocnetapibuffer
Lparameter nsize
If Type("nSize") # "N" Or nsize <= 0
Return Null
Endif
If ! "NT" $ Os()
Return Null
Endif
Declare Integer NetApiBufferAllocate In NETAPI32.Dll ;
integer dwByteCount, ;
integer lpBuffer
Local nbufferpointer
nbufferpointer = 0
If netapibufferallocate(Int(nsize), @nbufferpointer) # 0
nbufferpointer = Null
Endif
Return nbufferpointer
Function deallocnetapibuffer
Lparameter nptr
If Type("nPtr") # "N"
Return .F.
Endif
If ! "NT" $ Os()
Return .F.
Endif
Declare Integer NetApiBufferFree In NETAPI32.Dll ;
integer lpBuffer
Return (netapibufferfree(Int(nptr)) = 0)
Function copydoubletostring
Lparameter ndoubletocopy
Declare RtlMoveMemory In WIN32API As RtlCopyDbl ;
string @DestString, ;
double @pVoidSource, ;
integer nLength
Local cstring
cstring = Space(8)
=rtlcopydbl(@cstring, ndoubletocopy, 8)
Return cstring
Function doubletonum
Lparameter cdoubleinstring
Declare RtlMoveMemory In WIN32API As RtlCopyDbl ;
double @DestNumeric, ;
string @pVoidSource, ;
integer nLength
Local nnum
nnum = 0.000000000000000000
=rtlcopydbl(@nnum, cdoubleinstring, 8)
Return nnum

[sdycy]

我自已写了个DLL,非常好用的,可以直接新增自定义纸张,并且返回ID

[sdycy]

如果需要发EMAIL给我[e-mail]

[十豆三]

vfp9解決了自定义纸张设置的大问题
*********************************************************
*********************************************************
* vfp9终结一直以来关于打印纸张设置
* 过程名称：MyReport.prg
* 调用方式：MyReport(ReportName, Height, Width)
* 当 Height和Width为空时，默认A4纸
* 程序原创：dupeiji
* 最后修改：pnyjq
* 修改日期：2005-03-23
* 待解决问题：当ListenerType = 1时无法正常预览
*********************************************************
PARAMETERS lcFRX, nHeight, nWidth

LOCAL loReportListener

IF EMPTY(lcFRX)
RETURN
ENDIF

loReportListener = CREATEOBJECT("Test")

#DEFINE A4_Height 29.7
#DEFINE A4_Width 21

loReportListener.sHeight=ICASE(EMPTY(nHeight), A4_Height, nHeight)
loReportListener.sWidth=ICASE(EMPTY(nWidth), A4_Width, nWidth)

REPORT FORM (lcFRX) OBJECT loReportListener

DEFINE CLASS Test AS REPORTLISTENER
LISTENERTYPE = 0
sHeight=0
PROCEDURE GETPAGEHEIGHT()
IF THIS.sHeight >0
RETURN THIS.sHeight * 377.95
ELSE
RETURN DODEFAULT()
ENDIF
ENDPROC

sWidth=0
PROCEDURE GETPAGEWIDTH()
IF THIS.sWidth >0
RETURN THIS.sWidth * 377.95
ELSE
RETURN DODEFAULT()
ENDIF
ENDPROC

PROCEDURE OUTPUTPAGE(nPageNo, eDevice, nDeviceType, nleft, nTop, nWidth, nHeight)
t_sHeight=THIS.sHeight
THIS.sHeight=0
nHeight=t_sHeight * 377.95 * nHeight/THIS.GETPAGEHEIGHT()
THIS.sHeight=t_sHeight

t_sWidth=THIS.sWidth
THIS.sWidth=0
nWidth=t_sWidth * 377.95 * nWidth/THIS.GETPAGEWIDTH()
THIS.sWidth=t_sWidth

DODEFAULT(nPageNo, eDevice, nDeviceType,nleft, nTop, nWidth, nHeight)
NODEFAULT
ENDPROC
ENDDEFINE

[dfwxj]

sdycy ,麻烦你发个自定义纸张的DLL给我

[e-mail]

[sdycy]

我把DLL发放到资源上去,让你们共享用吧

[sdycy]

不好意思,我没分不能上传的资源,还是EMAIL吧

[ap7676]

作个记号！学习了
最近被自定义纸张困扰