Tenho aqui uma rotina de impressao que tirei não sei bem se foi neste forum ou se da net mas já adaptei ao meu caso.
O que eu precisava e que não encontro é fazer o cabeçalho em todas as páginas e sempre que faz 67 registos impressos o programa imprimisse na outra folha na linha 20 e que tambem tivesse o logotipo.
Se alguém me puder ajudar agradecia
Aqui vai o codigo
Código: Selecionar todos
Func mv_ip()
sele 3
OrdSetFocus("cprod")
SetImpressora("ON")
@ 8,26 say "Agrupamento de Escolas de Lagoa"
@ 10,30 say "Listagem de Fotocopias"
@ 19,19 say "Codigo Produto Esc Cor Preco"
z:= 20
skip
While !eof()
@ z+1, 20 Say codigoprod+' '+prod+' '+str(precov)
skip
z++
EndDo
SetImpressora("OFF")
Return
***************************************************
Func SetImpressora(cSI)
// possiveis cSI = ON -> para iniciar a gravar o arquivo texto
// OFF -> para jogar na impressora
Local mImpr:= {}, aPrn:= {}, mTexto:= {}
Local nPrn:= 0, cPrinter:= Space(0)
Local TelaPrn:= SaveScreen(00,00,24,79)
Local cLinha:= Space(0)
xcorjane="W/B" //Estas variaveis tem que ser declaradas
xcorletra="GR+/RD" //sao as cores usadas na funcao
xcorcursor="N/W" //Menu( )
cSI:= UPPER(cSI)
If cSI = "ON"
Clear Screen
Public cModoImp:= Space(10)
opc=1
tel_si=SAVESCREEN(0,0,24,79)
DO WHILE .T.
v_m:={{"1 - IMPRES. PADRAO "," "},;
{"2 - IMPRES. NA REDE "," "},;
{"3 - GRAVAR ARQUIVO "," "},;
{"4 - VOLTAR"," "}}
l_m:="1234"
opc=Menu(v_m,10,22,l_m,TelaPrn,"- PARA IMPRIMIR -",opc,0)
IF opc=0
EXIT
ENDIF
Do Case
Case opc = 1
cModoImp:= "PADRAO"
Exit
Case opc = 2
cModoImp:= "NA REDE"
Exit
Case opc = 3
cModoImp:= "GRAVAR ARQUIVO"
Exit
Case opc = 4 .OR. opc = 0
cModoImp:= "VOLTAR"
Exit
EndCase
RestScreen(0, 0, 24, 79, Tel_opc)
EndDo
Aguarde(19,06,1)
SET PRINTER TO "ARQUIVO.TXT"
SET DEVICE TO PRINTER
OK:= 0
EndIf
If cSI = "OFF"
SET PRINTER TO
SET DEVICE TO SCREEN
Aguarde(19,06,1)
mTexto:= LerArqTxt("ARQUIVO.TXT")
nPrn:= 1
Do Case
Case cModoImp = "NA REDE"
aPrn:= GetPrinters()
@ 04, 04 Clear To 20, 70
@ 04, 04 To 20, 70
IF EMPTY(aPrn)
Alert("No printers installed - Cannot continue")
QUIT
ENDIF
@ 05, 06 Say " escolha a impressora : "
cPrinter:= AllTrim(SelAchoice(aPrn,@cPrinter,30))
Aguarde(19,06,1)
Case cModoImp = "GRAVAR ARQUIVO"
cNomeArq:= GravArqTxt("ArqImp",mTexto,"TXT")
Case cModoImp = "PADRAO"
cPrinter:= GetDefaultPrinter()
EndCase
If LastKey() <> 27 .AND. !Empty(cPrinter) .AND. Len(mTexto) > 0
PrinterArquivo(mTexto,cPrinter)
EndIf
RETURN
EndIf
RestScreen(00,00,24,79,TelaPrn)
Return NIL
***********************************************
Func GravTexto(wLocal,w_ArqTxt,mTexto)
* esta fun‡ao grava um arquivo .txt a partir da array
* ex: wlocal := "f:\nfe"
* ex: warqtxt := "&wlocal\nota.txt"
If !Empty(wLocal)
warqtxt:= AllTrim(wLocal)+"\"+AllTrim(w_ArqTxt)
Else
warqtxt:= AllTrim(w_ArqTxt)
EndIf
ret_line := "chr(13)+chr(10)"
errhandle := FCREATE("&warqtxt" + ".txt")
For z:=1 To Len(mTexto)
cLinha:= mTexto[z][1]
FWRITE(errhandle,cLinha+&ret_line.)
Next
FCLOSE(errhandle)
FCLOSE("&warqtxt" + ".txt")
nREG := recco()
Return
**************************************************************
Func LerArqTxt(cArquivo)
* esta fun‡ao grava uma array a partir de um arquivo .txt
Local aStruct:= {}, mTexto:= {}
cArqTxt:= cArquivo
If (!File("ArqImp.dbf"))
aStruct:={}
AAdd(aStruct, {"Txtlinha", "C",250, 0})
DBCreate("ArqImp.dbf",aStruct)
EndIf
USE ArqImp New
ArqImp->(__DBZap())
ArqImp->(DBCloseArea())
USE ArqImp New
APPEND FROM "&cArqTxt" SDF
ArqImp->(DbGoTop())
Do While !ArqImp->(Eof())
AAdd(mTexto,{ArqImp->Txtlinha})
Skip
EndDo
ArqImp->(__DBZap())
Delete File &cArqTxt
Return mTexto
**************************************************************
#define FORM_A4 9
#define RGB( nR,nG,nB ) ( nR + ( nG * 256 ) + ( nB * 256 * 256 ) )
#define PS_SOLID 0
STATIC FUNC PrinterArquivo(mTexto,cPrinter)
LOCAL oPrinter:= WIN32PRN():New(cPrinter), aFonts, x, nColFixed, nColTTF, ;
nColCharSet, aForms
oPrinter:Landscape:= .F.
oPrinter:FormType := FORM_A4
oPrinter:Copies := 1
oPrinter:SetFont('courier new',12,{1,12}, 0,.F.,.F.)
c_string:= " teste "
IF !oPrinter:Create()
Alert("Cannot Create Printer")
ELSE
IF !oPrinter:startDoc( c_string )
Alert("IMPRESSORA NAO ESTA PRONTA ")
ELSE
FOR N = 1 TO 2
oPrinter:NewLine()
NEXT N
lin:= nFim:= 1
For z:=1 To Len(mTexto)
lin:= oPrinter:Prow()
oPrinter:TextOut(mTexto[z][1],.T.)
If lin > 60 .AND. nFim = 1
oPrinter:NewPage()
oPrinter:NewLine()
lin:= 1
EndIf
Next
*======================= Aqui come‡a a impressÆo de Imagens ===================
oBmp := Win32Prn():new()
cFileName := "\ca6\espamol.bmp"
oBmp := Win32Bmp():new()
IF .NOT. oBmp:loadFile( cFileName )
Alert( cFileName + " N’o encontrado..." )
ELSE
oBmp:draw( oPrinter, { 120, 120, 900, 400 } )
oPrinter:SetFont('Courier New',14,{1,14}, 0, .F., .F.)
oPrinter:SetPrc(oPrinter:Prow()+08, 40 )
* oPrinter:TextOut("Öcone impresso nas coordenadas: horizontal 1200, vertical 7500", .T.)
oPrinter:SetPrc(oPrinter:Prow()+01, 40 )
* oPrinter:TextOut("Tamanho do ¡cone: horizontal 1800, vertical 1500", .T.)
ENDIF
*====================== Usando sub-rotina para a impressÆo da imagem ========
cBmpFile := "\ca6\espamol.bmp"
PrintBitMap( oPrinter, cBMPFile )
oPrinter:EndDoc()
oPrinter:Destroy()
RETURN(NIL)
*
/* *------------------------------------------------------------------------------
procedure PrintBitMap( oPrn, cBitFile )
LOCAL oBMP
IF EMPTY( cBitFile )
&& Pode-se incluir aqui uma imagem alternativa.
ELSEIF !FILE( cBitFile )
Alert( "Arquivo " + cBitFile + " nÆo encontrado." )
ELSE
oBMP:= Win32BMP():new()
IF oBmp:loadFile( cBitFile )
oBmp:Draw( oPrn, { 200,10000, 1000, 750 } )
&& Esta alternativa abaixo que tamb‚m pode ser usada.
oBmp:Rect:= { 2000,10000, 1000, 750 }
oPrn:DrawBitMap( oBmp )
ENDIF
oBMP:Destroy()
ENDIF */
oPrinter:EndDoc()
ENDIF
oPrinter:Destroy()
ENDIF
Return
****************************************************************
Func Aguarde(nLin,nCol,nModo)
Local AntSC:= SetColor()
SetColor("b+*/gr+*")
If nModo = 1
Public TelMens:= SaveScreen(nLin-1,nCol-2,nLin+1,79)
@ nLin-1,nCol Clear to nLin+1,nCol+32
@ nLin-1,nCol to nLin+1,nCol+32
@ nLin,nCol+1 Say "Aguarde por favor .......... "
Else
RestScreen(nLin-1,nCol-2,nLin+1,79,TelMens)
EndIf
SetColor(AntSC)
Return
*************************************************************
Func SelAchoice(dir1,cSelec,xLen)
Local cTela
Local opc:= nLin1:= nLin2:= nCol1:= nCol2:= 0
Set Color To ("w+/bg+, w+/r+, bg+, ,w+/bg+")
If Len(dir1) < 22
nLin1:= INT((24 - (Len(dir1))) / 2)
nLin2:= (nLin1 + (Len(dir1)))
Else
nLin1:= 2
nLin2:= 22
EndIf
nCol1:= Round(((78 - (xLen)) / 2),2)
nCol2:= nCol1 + xLen + 1
If nCol2 > 78
nCol2:= 78
EndIf
cTela:= SaveScreen((nLin1-1),(nCol1-1),(nLin2+1),(nCol2+1))
@ (nLin1-1), (nCol1-1) Clear To (nLin2+1),(nCol2+1)
@ (nLin1-1), (nCol1-1) To (nLin2+1),(nCol2+1)
@ nLin1,nCol1 Say Padc("SELECIONE",(nCol2-nCol1))
While opc = 0 .AND. Lastkey() <> 27
opc:= achoice((nLin1+1),nCol1,nLin2,nCol2,dir1,.T.,"")
EndDo
If Lastkey() = 27
cSelec:=""
Else
cSelec:= dir1[opc]
EndIf
RestScreen((nLin1-1),(nCol1-1),(nLin2+1),(nCol2+1),cTela)
Return cSelec
**********************************************************************
Func GravArqTxt(NomeArq,mTexto,cModo)
* esta funcao escolhe um caminho apara gravar um arquivo .txt
Local TelAT:= SaveScreen(00,00,24,79)
Local cNomeArq:= Padr(NomeArq,8), SetCorAnt:= SetColor()
Local cUnid:= cCriar:= Space(1)
Local aDirx:= {}
cPasta:= Space(40)
Set Color To ("w+/bg+, w+/r+, bg+, ,w+/bg+")
@ 06,04 Clear To 12,50
@ 06,04 To 12,50
While cModo = "TXT"
@ 08,10 Say "Gravar na unidade: " Get cUnid Picture "@!"
@ 08,31 Say ":\"
@ 09,10 Say "Gravar na PASTA: " Get cPasta Picture "@S20!"
Read
cPasta:= AllTrim(cPasta)
cPasta:= cUnid + ":\" + cPasta + "\*."
aDirx:= Directory(cPasta,"D")
cPasta:= Left(cPasta,(Len(cPasta)-2))
If Len(aDirx) = 0
Alert(" pasta nÆo existe ")
@ 10,10 Say "Deseja criar esta pasta ? (S/N) " Get cCriar Picture "@!" Valid cCriar $"SN"
Read
If cCriar = "S"
RUN MD &cPasta
Else
Exit
EndIf
EndIf
@ 11,10 Say "Nome do Arquivo: " Get cNomeArq Picture "@S20!"
Read
Exit
EndDo
If LastKey() <> 27 .AND. cCriar <> "N"
GravTexto(AllTrim(cPasta),cNomeArq,mTexto)
EndIf
SetColor(SetCorAnt)
RestScreen(00,00,24,79,TelAT)
Return cNomeArq
*********************************************************************
FUNC Menu(v_msg,ylin,ycol,ldest,tel,tit,pos,PrimMenu,moldu)
*************************************************************
LOCAL vlen:=op_t:=pos_t:=1, ti:=ARRAY(6),cor_ant:=SETCOLOR(),;
yi, m_tam, col_i, lin_i, vti, tcol, tlin, op_n
IF PCOUNT() < 3
SETCOLOR(cor_ant)
RETURN(NIL)
ENDIF
tit = IF( VALTYPE(tit)="U","",tit)
op_n = IF( VALTYPE(pos)="U",1,pos)
moldu = IF( VALTYPE(moldu)="U","ÚÄ¿³ÙÄÀ³ ",moldu)
SET CURSOR OFF
If LastKey() = 27 // incluido por Rosalvo Rosa
KeyBoard Chr(0) // para quando uma funcao volta com ESC
EndIf
AFILL(ti," ")
IF LEN(v_msg) > 1
FOR yi = 1 TO LEN(v_msg)
IF vlen < LEN(v_msg[yi,1])
vlen=LEN(v_msg[yi,1])
ENDIF
NEXT
ELSE
vlen=LEN(v_msg[1,1])
ENDIF
IF !EMPTY(tit)
IF "|" $ tit
ti[op_t] = SUBSTR(tit,pos_t,yi-pos_t)
vti=SUBSTR(tit,pos_t-1,yi-(pos_t-1))
IF vlen < LEN(vti)
vlen=LEN(vti)
ENDIF
pos_t=yi
ELSE
ti[1]=tit
IF vlen < LEN(tit)
vlen=LEN(tit)
ENDIF
ENDIF
m_tam=ycol+vlen+3
IF m_tam > 80
ycol=INT((80 - (vlen+4)) / 2)
ENDIF
lin_i=ylin+op_t+LEN(v_msg)+2
col_i=ycol+vlen+2
tcol=vlen+2
tlin=LEN(v_msg)+op_t+1
SETCOLOR(xcorjane)
caixa(moldu,ylin,ycol,lin_i,col_i,.T.)
FOR yi=1 TO op_t
SETCOLOR(xcorjane)
@ ylin+yi, ycol+1 SAY PADC(ti[yi],vlen+1)
NEXT
@ ROW()+1,YCOL+1 SAY REPLICATE("Ä",vlen+1)
ylin=ylin+op_t+1
ELSE
m_tam=ycol+vlen+3
IF m_tam > 80
ycol=INT((80 - (vlen+4)) / 2)
ENDIF
lin_i=ylin+LEN(v_msg)+1
col_i=ycol+vlen+3
tcol=vlen+2
tlin=LEN(v_msg)+1
SETCOLOR(xcorjane)
caixa(moldu,ylin,ycol,lin_i,col_i,.T.)
vlen+=1
ENDIF
While .T.
SETCOLOR(xcorjane)
SET MESSAGE TO 24
SET WRAP ON
FOR yi = 1 TO LEN(v_msg)
@ ylin+yi, ycol+1 PROMPT " "+v_msg[yi,1]+REPLIC(" ",((vlen)-LEN(V_MSG[yi,1])));
MESSAGE v_msg[yi,2]+REPLIC(" ",68-LEN(v_msg[yi,2]))
NEXT
MENU TO op_n
SET CURSOR ON
SETCOLOR(cor_ant)
If op_n = 0 .AND. PrimMenu = 1
Loop
EndIf
Exit
EndDo
RETURN(op_n)
***************************************
Func caixa(ymoldura,ls,cs,li,ci,ysombra,ysom)
LOCAL vtela,cor_a:=SETCOLOR(), yi:=j:=k:=w:=x:=0, iouj:=1, yfim:=.f.
vtela:=SAVESCREEN(ls+1,cs+1,li+1,ci+2)
IF PCOUNT() < 6
SETCOLOR(cor_a)
RETURN
ENDIF
ysom = IF( VALTYPE( ysom ) = "U", 0, ysom)
IF ysombra
IF LEN(vtela)>3192 //2048
vtela:=TRANSFORM(SUBSTR(vtela,1,2048),REPLICATE("X"+CHR(6),1000))+;
TRANSFORM(SUBSTR(vtela,2049),REPLICATE("X"+CHR(6),1000))
ELSE
vtela:=TRANSFORM(vtela,REPLICATE("X"+CHR(6),LEN(vtela)/2))
ENDIF
ENDIF
yi:=INT((li-ls)/2+ls)
j:=INT((ci-cs)/2+cs)
k:=yi
w:=j+1
IF yi<j
iouj:=1
ELSE
iouj:=2
ENDIF
yfim=.f.
DO WHILE .t.
IF iouj=1
IF j=cs
yfim=.T.
ENDIF
ELSE
IF yi=ls
yfim=.T.
ENDIF
ENDIF
IF yfim
RESTSCREEN(ls+1,cs+1,li+1,ci+2,vtela)
@ ls,cs,li,ci BOX ymoldura+" "
EXIT
ELSE
@ yi,j,k,w BOX ymoldura+" "
IF yi!=ls
yi--
ELSE
yi=ls
ENDIF
IF j>cs
j--
ELSE
j=cs
ENDIF
IF k!=li
k++
ELSE
k=li
ENDIF
IF w<ci
w++
ELSE
w=ci
ENDIF
ENDIF
ENDDO
IF ysom!=0
IF xsom
TONE(ysom)
ENDIF
ENDIF
SETCOLOR(cor_a)
RETURN
*************************************************
*------------------------------------------------------------------------------
procedure PrintBitMap( oPrn, cBitFile )
LOCAL oBMP
IF EMPTY( cBitFile )
&& Pode-se incluir aqui uma imagem alternativa.
ELSEIF !FILE( cBitFile )
Alert( "Arquivo " + cBitFile + " nÆo encontrado." )
ELSE
oBMP:= Win32BMP():new()
IF oBmp:loadFile( cBitFile )
oBmp:Draw( oPrn, { 200,10000, 1000, 750 } )
&& Esta alternativa abaixo que tamb‚m pode ser usada.
oBmp:Rect:= { 2000,10000, 1000, 750 }
oPrn:DrawBitMap( oBmp )
ENDIF
oBMP:Destroy()
ENDIF
RETURN
*
*---------------------------------------------------------------------------------------------------
