VFP 在操作系统（WIN2K及以上）上增加、删除、修改自定义纸张

[蓝海]

记得以前有个同事拿过一本 VFP6 的书，那里有增、删、改操作系统中纸张类型的示例，当时没将示例输到电脑里，有谁有那个书或例子啊？

分享一下呗？100分敬上。。。

[wwwwb]

是这个 ？
*--------------------------------------------------------------------

关于自定义打印纸的问题，论坛上有很多讨论，我知道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

[十豆三]

推荐使用 木瓜 的 MyFll.fll 中的 PaperAdd() 等函数

[蓝海]

多谢，十豆三老师！

愿意再行奉上100分！十豆三老师可否接受啊？

如同意请回复，小可补个百分贴上来便是了。。。