regsvr32 C:\WINDOWS\system32\activevfp.dll
soma por group by cliente
*
SET SAFETY OFF
Set date briti
set century on
set dele on
Set Enginebehavior 70
CLOSE DATABASES all
STORE CTOD('') TO VDATA1,VDATA2
VDATA1=ctod('01/02/2021')
VDATA2=ctod('15/02/2021')
IF FILE('obina.dbf')
DELETE FILE obina.dbf
ENDIF
LOCAL valor1,valor2
STORE 0 TO valor1,valor2
SELECT pedidos.motoboy as cliente, SUM(pedidos.VALOR1) as valor FROM pedidos ;
WHERE pedidos.pe_data>=VDATA1 AND pedidos.pe_data <=VDATA2 GROUP BY pedidos.motoboy ORDER BY pedidos.motoboy INTO table obina
SUM valor TO valor2
SELECT cliente, SUM(pe_valor) as valor From pedidos ;
WHERE pedidos.pe_data>=VDATA1 AND pedidos.pe_data <=VDATA2 GROUP BY pedidos.cliente ORDER BY Cliente INTO CURSOR TESTE READWRITE
IF RECCOUNT()>0
SUM valor TO valor1
GO bottom
INSERT INTO teste(CLIENTE,valor) VALUES ('Periodo de: '+DTOC(Vdata1)+' a '+DTOC(Vdata2),0)
INSERT INTO teste(cliente,valor) values("Soma do Periodo a Receber",valor1)
INSERT INTO teste(cliente,valor) values(" ",0)
INSERT INTO teste(cliente,valor) values("A pagar Pessoas ",0)
ELSE
WAIT WINDOW 'nao enconrei nada' TIMEOUT 1
ENDIF
APPEND FROM obina
INSERT INTO teste(cliente,valor) values("Soma A pagar Pessoas",valor2)
INSERT INTO teste(cliente,valor) values("Resultado ",(valor1-valor2))
BROWSE
copy to fechou.xls type xls
CLOSE DATABASES all
copy to fechou.xls type xls
Video vfp 10 64 bits instalacao
link da instalcao
vfp 9 portable Video Instlar VFP
Grid a linha ficar inteira selecionada ao inves de apenas a celula.
Propriedade da GRID HighLightStyle 2
Inputbox comando
LOCAL WQT
WQT=""
SELECT cliente
SET ORDER TO nome_cli
WQT=INPUTBOX("Nome ", "A Pesquisar", "", 0, "", "FOICANCELADO")
IF WQT = "FOICANCELADO"
MESSAGEBOX("O botão do InputBox foi pressionado")
ENDIF
IF !EMPTY(ALLTRIM(WQT ))
SEEK WQT
IF FOUND()
THISFORM.REFRESH
ELSE
WAIT WINDOW 'NAO ENCONTREI ' TIMEOUT 1
ENDIF
ENDIF
cor do form
newcolor=GETCOLOR()
Thisformset.SetAll("Backcolor",newcolor,"Form")
cor da letra do form
newcolor=GETCOLOR()
Thisformset.SetAll("Forecolor",newcolor,"Label")
Thisformset.Setall("DisabledForecolor",newcolor,"Textbox")
01-)Abrir 1 arquivo do MS Word VFP
Declare INTEGER ShellExecute IN SHELL32.DLL INTEGER, String CDIR, String CFILE, ;
STRING , STRING, INTEGER
cArqDoc=getfile('DOC','Selecione o arquivo','Selecione' , 1,'Escolha 1 Arq DOC')
If File(cArqDoc) && *p/ imprimr arq. "print" no lugar do open,p/imprimir direto
ShellExecute(0, "Open", cArqDoc,"", Fullpath(""),0)
Else
Wait Window ' O arquivo nao esta na pasta!! ' Timeout 2
EndifLink para gerar um arquivo MsWord no Vfp
Link baixar os fontes
**Mais uma forma de abrir Doc do Ms-word
loShell = CREATEOBJECT("Shell.Application")
arqui=getfile('doc','Escolha o arquivo','Selecione' , 1,'Escolha 1 Arq doc')
loShell.ShellExecute(arqui)
RELEASE loShell
01-a) Impressora padrao
cPrinter = SET('PRINTER', 2)
? cprinter
1-b** chamar uma class dentro de um form
PUBLIC oForm1 as Form
oForm1 = NEWOBJECT("editor","comandos.vcx")
oForm1.Show()
** debug comando= set step on **seek //set near on antes
1-A) pegar o maior codigo em uma tabela
SELECT MAX(cl_codigo) as num FROM clientes INTO CURSOR Sei READWRITE
select Sei
if _tally>0
wnum=sei num+1
else
wnum=1
endif
1-C***backup NECESSERIO O 7Z.EXE E 7-Z.DLL link download 7zip
local warq
warq='bkpdbf'+LEFT(DTOC(DATE()),2)+LTRIM(STR(YEAR(DATE())))+'.zip'
close tables all
CD e:\ct
CD GETDIR()
IF FILE('7z.exe')
* RUN /n 7z a -t7z back.7z ..\backup
RUN /n 7z a -r &warq *.scx *.sct *.cdx *.pj* *.vc* *.prg *.MNT *.MPX *.dbf *.png *.bmp
CLOSE TABLES all
** COPY FILE &warq TO \ct\backup\&warq
WAIT WINDOW 'Fiz a copia 7z.exe ' TIMEOUT 2
else
WAIT WINDOW 'Nao achei compactador 7z.exe ' TIMEOUT 1
ENDIF
Como usar a Tecla Enter para sair ? de 1 browse last normal nodelete noedit
ON KEY LABEL ENTER KEYBOARD '{CTRL+W}'
USE suaTabela
BROWSE
ON KEY LABEL ENTER
1-D PEGAR O MAX VALOR EM UM CAMPO DE UM TABELA
*Crie um metodo com o nome prox_cod e coloque:
SELECT MAX(NR) FROM CLIENTE INTO ARRAY M_Temp
lcRetVal = IIF(!ISNULL(M_Temp(1)), M_Temp(1)+1, "1")
*THISFORM.txtCampo.VALUE = lcRetVal
OU
TEMPO='B'+SYS(2015)
SELECT MAX(PE_NUMERO) as numero2 FROM PEDIDOS INTO CURSOR TEMPO
IF _TALLY>0
WVRNR=TEMPO.NUMERO2
ENDIF
1- E- Comando Getdir() abrir 1 Dbf
Set safety off
gcTable = GETFILE('DBF')
DO CASE
CASE EMPTY(gcTable)
RETURN
CASE LASTKEY()=27
QUIT
OTHERWISE
SELE 0
USE &gcTable ALIAS TABLA
SELECT tabla
DEFINE WINDOW wBrowse FROM 02,10 TO 48,100 CLOSE GROW COLOR SCHEME 20
BROWSE WINDOW WBrowse
USE
RELEASE WINDOW wBrowse
ENDCASE
1-D Verificar se existe um determinado arquivo . dbf ou txt
SET SAFETY OFF
CREATE CURSOR lixos (tabela c(50))
LOCAL lnTab, lnCntA
LOCAL ARRAY laTab(1)
lnTab = ADIR(laTab, 'c:\motos\*.txt')
FOR lnCntA = 1 TO lnTab
*MESSAGEBOX(laTab(lnCntA,1),48,'tabela', 500)
INSERT INTO lixos( tabela) values(laTab(lnCntA,1))
ENDFOR
SELECT lixos
IF RECCOUNT()>0
WAIT WINDOW 'Sim tem arquivo' TIMEOUT 1
endif
browse
1-E) Formatar a coluna da grid tamanho
x=Thisform.txtEditar.Value
y=Thisform.txtEditar.Value
select codforn1,codforn2,codforn3,codforn4,codforn5,;
requisicao,item,qtde,unidade,descricao,data,ano ;
from requisicao into cursor Pesquisa READWRITE ;
where BETWEEN(requisicao,x,y) order by item
Thisform.grid1.recordSource = 'pesquisa'
Thisform.grid1.column1.ControlSource="pesquisa.item"
Thisform.grid1.column2.controlsource="pesquisa.unidade"
Thisform.grid1.column3.controlsource="pesquisa.qtde"
Thisform.grid1.column4.controlsource="pesquisa.descricao"
Thisform.grid1.column1.header1.Caption="Item"
Thisform.grid1.column2.header1.caption="Und"
Thisform.grid1.column3.header1.caption="Quant."
Thisform.grid1.column4.header1.caption="Descrição"
Thisform.grid1.column1.Width=40
Thisform.grid1.column2.width=46
Thisform.grid1.column3.width=106
Thisform.grid1.column4.width=451
Thisform.grid1.refresh()
Thisform.grid1.ReadOnly=.F.
1-F) Gerar um documento novo no Ms Word em VFP
oWord = CreateObject("Word.Application")
oDocument = oWord.Documents.Add() && Use the Normal template
oRange = oDocument.Range()
**chr(13)+chr(10) enter para pular um linha
oRange.InsertAfter('A Primeira linha em Negrito'+CHR(13)+CHR(10))
oRange.Font.Bold = .t.
oRange.Collapse( 0 )
oRange.End = oRange.End + 1 && to allow assignment to font
oRange.InsertAfter(' Segundo Normal'+CHR(13)+CHR(10))
oRange.Font.Bold = .F.
oRange.Collapse( 0 )
oRange.End = oRange.End + 1 && to allow assignment to font
oRange.InsertAfter('Ola mundo negrito e terceirta itálico'+CHR(13)+CHR(10))
oRange.words[1].Font.Bold = .T.
oRange.words[3].Font.italic = .T.
oRange.Collapse( 0 )
oRange.End = oRange.End + 1 && to allow assignment to font
oDocument.SaveAs('c:\teste.doc')
oword.visible=.t.
Abrir um documento ja existente do Ms.Word e inserir uma Palavra "Ola mundo"
SeuArquivoDoc="c:\pedro\doc1.doc"
DECLARE INTEGER SetForegroundWindow IN user32.dll INTEGER
oWord = createobject("Word.Application")
oWord.Visible = .T.
oWord = GetObject(,"word.basic")
oWord.FileOpen(SeuArquivoDoc)
oWord.AppMaximize()
oWord.AppShow()
oWord.Insert("Olá mundo")
*
1-G COMO FAZER O MAPA ENTRE DOIS CEPS PELO GOOGLE
DECLARE INTEGER SetForegroundWindow IN user32.dll INTEGER
origem="02727-000"
destino="02728-090"
oIE = CREATEOBJECT("Internetexplorer.application")
oIE.navigate("http://maps.google.com.br/maps?hl=pt-BR&cp=29&gs_id=5&xhr=t&q=from:+"+origem+"+to:+"+destino)
oIE.Visible = .T.
=SetForegroundWindow(oIE.HWND)
1-h ) LISTAR ARQUIVOS DE 1 PASTA
LOCAL m.diretorios AS STRING
*!* Lê os arquivos contidos na unidade C:\
m.diretorios = filesinfolder("C:\")
SELECT(m.diretorios)
GO TOP
BROWSE
USE IN SELECT(m.diretorios)
RETURN
1-I) o comando iif
condicao IIf
Mvar=MONTH(DATE())
Mvar=iif(Mvar=1,'Janeiro',Iif(Mvar=2,'Fevereiro',IIF(Mvar=3,'Marco', Iif(Mvar=4,'Abril',IIF(Mvar=5,'Maio',Iif(Mvar=6,'JUNHO',IIF(Mvar=7,'JULHO',Iif(Mvar=8,'AGOSTO',IIF(Mvar=9,'SETEMBRO',Iif(Mvar=10,'OUTUBRO',IIF(Mvar=11,'NOVEMBRO','DEZEMBRO')))))))))))
WAIT WINDOW Mvar TIMEOUT 2
***
01-a FLOCK bloquear registro para gravar o registro em Rede
vobina=.t.
Do while vobina
if flock()
update tabela set campos where condicao
unlock all
wobina=.f.
exit
endif
if wobina=.f.
exit
endif
Enddo
FUNCTION filesinfolder AS COLLECTION
* It returns all files, contained in a paste.
LPARAMETERS cpath AS STRING
LOCAL pathdefault AS STRING
LOCAL totalfiles AS INTEGER
LOCAL counter AS INTEGER
LOCAL nomecursor AS STRING
m.cpath = IIF(EMPTY(m.cpath), "", ADDBS(m.cpath))
m.pathdefault = SYS(5)+CURDIR()
m.totalfiles = 0
m.nomecursor = SYS(2015) && Nome do cursor que armazenará os arquivos
CREATE CURSOR (m.nomecursor) (filename c(254), filesize i(4), dateltmodified d(8), timeltmodified c(10), fileattributes c(1))
IF DIRECTORY(m.cpath) THEN
CHDIR (m.cpath)
m.totalfiles = ADIR(myfiles, "*.*","D")
FOR m.counter = 1 TO m.totalfiles
INSERT INTO (m.nomecursor) VALUES ;
(myfiles[m.counter, 1], myfiles[m.counter, 2], myfiles[m.counter, 3], ;
myfiles[m.counter, 4], STRTRAN(myfiles[m.counter, 5], ".", ""))
ENDFOR
SET DEFAULT TO (m.pathdefault)
ENDIF
RETURN m.nomecursor
ENDFUNC
*FIM*
LOCALIZAR UNIDADE DE REDE
IF DISKSPACE("V:") = -1
MESSAGEBOX("Unidade de rede ou Drive Não Localizado...",48,"Aviso ",2800)
RETURN .F.
ENDIF
Se Existe o diretorio
IF directory("H:\teste")
WAIT WINDOW 'existe' timeout 2
ELSE && se nao existir
WAIT WINDOW ' nao existe a unidade, ou nao foi mapeada' timeout 4
endif
1-g- Gerar uma planilha em vfp
CLOSE DATABASES
IF !FILE('CLIENTE.DBF')
CREATE TABLE CLIENTE (NUMERO N(4,0),NOME_CLI C(30), ENDERECO C(40), BAIRRO C(20), CIDADE C(30), UF C(2))
SELECT CLIENTE
INDEX on nome_cli TAG clienteset orde to cliente
FOR I=1 TO 20
INSERT INTO CLIENTE (NUMERO,noME_CLI,ENDERECO) VALUES (I,"CLIENTE "+STR(I), 'RUA ')
ENDFOR
ENDIF
IF !USED("CLIENTE")
USE CLIENTE IN 0 ALIAS CLIENTE SHARED
ENDIF
SELECT CLIENTE
xFinal = RECCOUNT("cliente")
xInicio = 1
WAIT windows "Aguarde, abrindo o excel e montando a Planilia..." NOWAIT NOCLEAR
Oexcel=createobject("Excel.application")
Oexcel.workbooks.add
Oexcel.visible=.t.
x = 1
SELECT cliente
GO TOP
DO WHILE x <= xFinal
IF X = 1
Oexcel.cells(x,1).font.size=10
Oexcel.cells(x,1).font.color=rgb(180,0,0)
Oexcel.cells(x,1).font.bold=.t.
OExcel.Range("B1").Value = 500
Oexcel.cells(x,1).value='Tabela de precos' &&xPedidos
ELSE
Oexcel.cells(x,1).font.size=12
Oexcel.cells(x,1).font.color=rgb(0,0,255)
Oexcel.cells(x,1).font.bold=.f.
Oexcel.cells(x,1).value=cliente.NUMERO
Oexcel.cells(x,2).font.size=12
Oexcel.cells(x,2).font.color=rgb(0,0,255)
Oexcel.cells(x,2).font.bold=.f.
Oexcel.cells(x,2).value=cliente.noME_CLI
Oexcel.cells(x,3).font.size=12
Oexcel.cells(x,3).font.color=rgb(0,0,255)
Oexcel.cells(x,3).font.bold=.f.
Oexcel.cells(x,3).value=cliente.endERECO
ENDIF
SELECT cliente
SKIP
x=x+1
ENDDO
WAIT CLEAR
*****
condicao IIf
Mvar=MONTH(DATE())
Mvar=iif(Mvar=1,'Janeiro',Iif(Mvar=2,'Fevereiro',IIF(Mvar=3,'Marco', Iif(Mvar=4,'Abril',IIF(Mvar=5,'Maio',Iif(Mvar=6,'JUNHO',IIF(Mvar=7,'JULHO',Iif(Mvar=8,'AGOSTO',IIF(Mvar=9,'SETEMBRO',Iif(Mvar=10,'OUTUBRO',IIF(Mvar=11,'NOVEMBRO','DEZEMBRO')))))))))))
WAIT WINDOW Mvar TIMEOUT 2
***
1-j -Conexao mysql con VFP
Conexao Mysql Vfp codigo o seguinte
Private StrConexao,privConexao
privStrConexao="DRIVER={MySQL ODBC 3.51 Driver};
SERVER='http://www.motote.host.sk';
DATABASE='odonto';
USER='galeu';
PASSWORD='45623';
OPTION=3;
";
privConexao = Sqlstringconnect(privStrConexao)
If privConexao > 0
Wait Window 'conectei' Timeout 1
SQLExec(privConexao,'Select * from pacientes ' ,'cur_cat' )
Select cur_cat
Browse Normal
If 6=Messagebox('deseja descontecta',4+32,'perguta')
= SQLDisconnect(privConexao)
Endif
Else
Messagebox( 'Nao foi possivel conectar-se ao Banco de Dados [ondonto], fale com TI !',48,'Atencao' )
Endif
Return .T.
*Obs nao esqueca de instalar o driver odbc Mysql 3.51
* NO BLOG TEM COMO BAIXAR O odbc 3,51
1-L impressaora virual dopdf
Depois apos ter instalado a Impressora
Codigo
IF NOT FILE('BAIRRO.DBF')
CREATE TABLE BAIRRO (CODBAIRRO C(3),NOMBAIRRO C(20))
SELECT BAIRRO
INSERT INTO BAIRRO VALUES('001','VL.CAROLINA')
INSERT INTO BAIRRO VALUES('002','VL.CARMONA')
ENDIF
if not USED('BAIRRO')
USE BAIRRO
endif
Select BAIRRO
if not file('bairros.frx')
Create Report Bairros From BAIRRO && BAIRRO e o DBF
endif
SET PRINTER TO NAME GETPRINTER() &&"novaPDF"
SET PRINTER TO NAME "novaPDF"
REPORT FORM BAIRROS TO PRINTER PROMPT NOCONSOLE
***fim do gerar pdf
01-H) Abrir calculadora do windows com valores.
Local lnHWND, loWSH
DECLARE LONG FindWindow IN WIN32API AS FindWindow STRING @a, STRING @b
DECLARE LONG SetForegroundWindow IN WIN32API LONG
* Buscamos una instancia da aplicación para obtener seu Handler
lnHWND = FindWindow(0, "Calculator")
If lnHWND = 0
Run /N Calc.EXE
lnHWND = FindWindow(0, "Calculator")
Endif
* Instanciamos el Windows Scripting Host
loWSH = CreateObject("WScript.Shell")
* Enviamos la aplicación a primer plano
SetForegroundWindow(lnHWND)
INKEY(0.2)
* Por último enviamos a sequencia de teclas
loWSH.SendKeys("140{+}200")
loWSH.SendKeys("{enter}")
**
FUNCTION ESTALIVRE(cArquivo)
* Retorna se o arquivo está em uso ou não
* USO: ESTALIVRE('c:\nomedoarquivo.dbf')
* RETORNA: .T. ou .F.
LPARAMETERS m.tabela
lnarquivo = FOPEN(m.tabela,1)
IF lnarquivo > 0
FCLOSE(lnArquivo)
ELSE
RETURN .F.
ENDIF
ENDFUNC
*
SELECT vendedor
SET ORDER TO COD_VEND && COD_VEND
SET MULTILOCKS ON
IF NOT EMPTY(ALIAS())
CURSORSETPROP("buffering",3)
ENDIF
IF reccount() > 0
GO bottom
wnr=INT(VAL(vendedor_.Cod_vend)+1 )
WnR=str(WnR,6)
WnR=STRTRAN(WNR,' ', '0')
ELSE
wnr='000001'
ENDIF
***
*I-*gravar campo memo
lckeyWorkorderDetail = vWorkorderDetail.keyWorkorderDetail
SELECT * ;
FROM vWorkorderDetail ;
WHERE keyWorkorderDetail = lckeyWorkorderDetail ;
INTO CURSOR cWorkorderDetail READWRITE
SELECT cWorkorderDetail
SCATTER MEMO MEMVAR
m.CatOrder = ALLTRIM(ThisForm.txtCatOrder.Value)
SELECT vWorkorderDetail
GATHER MEMO MEMVAR
llTestValue=TABLEUPDATE(.T.)
****
J-Grid a linha ficar inteira selecionada ao inves de apenas a celula.
Propriedade da GRID HighLightStyle 2
L-Calculo de horas com datetime()
wdata=DATETIME()-180
WAIT WINDOW wdata TIMEOUT 1
wdata1=DATETIME()
? Dif_HDMS(Datetime(), Dtot(Date()-22))
wre= Dif_HDMS(Datetime(), Dtot(Date()-22))
WAIT WINDOW wre TIMEOUT 1
wfala=dif_hdms(wdata,wdata1)
MESSAGEBOX( wfala,0+0,'aviso') &&,2500)
***
Function Dif_HDMS (tDateTime1, tDateTime2)
Local cRet, nS
cRet = ""
If! Vartype(tDateTime1)= "T" Or !Vartype(tDateTime2)= "T"
cRet = "E"
Endif
If Empty(cRet)
If tDateTime2 > tDateTime1
nS = tDateTime2 - tDateTime1
Else
nS = tDateTime1 - tDateTime2
Endif
nS = Int(nS)
cTime = Transform(Int(nS/86400),"9999")+" dias :"+ ;
Transform(MOD(Int(nS/3600),24),"9999")+" horas :"+ ;
Transform(Mod(Int(nS/60),60),"99")+" min :"+ ;
Transform(Mod(nS,60)," 99")+" seg "
Return cTime
Else
=Messagebox("Valores tem que ser Date e time")
Return ""
Endif
Endfunc
*Fim de calculo de horas
Criar tabela com indice
If ! File('Cidade.Dbf')
Create Table Cidade ( Codigo N(2), Nombre C(25))
Index On Codigo Tag Codigo Unique
Index On Nombre Tag Nombre
ENDIF
set order to nombre
**
4+32+256 opcao como nao
IF 6=MESSAGEBOX('Deseja fazer o backup',4+32+256,'Demora 5 minutos?')
**
Dica ,Tirando os pontos e o traco
WCPF='012.052.418-29'
WCPF=CHRTRAN(WCPF,".", "")
WCPF=CHRTRAN(WCPF,"-", "")
MESSAGEBOX(WCPF)
****pegar dados do xml
CLOSE DATABASES ALL
SET SAFETY off
IF !file('c:\PEDRO\nota.xml')
WAIT WINDOW 'nao encontrei o xml' TIMEOUT 2
RETURN .F.
ENDIF
IF file ('c:\PEDRO\nota.xml')
cfile=FILETOSTR('c:\PEDRO\nota.xml')
cTag=STREXTRACT(cFile,'','',1)
MESSAGEBOX(CTAG,48,'Atencao',1000)
**Pegar so o nome do emitente dentro da arquivo nfe
cTag1=STREXTRACT(cFile,'','',1)
MESSAGEBOX('Emitente '+ CTAG1,48,'Aviso o Emitente',1000)
***aqui vou pegar o endereco do emitente
cTag2=STREXTRACT(cFile,'','',1)
cTag3=STREXTRACT(cFile,'','',1)
endif
***Pegar somente o item 1 do xml
IF STREXTRACT(cfile,'',1)="1"
vrprodutos1=STREXTRACT(cfile,'')
WRE= STREXTRACT(cfile,'',1)
MESSAGEBOX(vrprodutos1+chr(13)+' do item 1',48,'atencao item 1',1500)
ELSE
MESSAGEBOX("1 IF Não tinha itens",48,'atencoa',1000)
ENDIF
***vou comecar pelo item 1 e vou ate o iten 50
n=1
FOR I =1 TO 50
IF STREXTRACT(cfile,'',n)=ALLTRIM(STR(n))
wre=STREXTRACT(cfile,'',n)
* WAIT WINDOW 'item nr '+WRE TIMEOUT 1
vrprodutos2=STREXTRACT(cfile,'',n)
MESSAGEBOX(vrprodutos2,48+0,'Atencao'+wre,900)
n=n+1
ELSE
**se nao encontro n=50 para fechar o loop do for next
n=50
WAIT WINDOW 'Fim dos 50 itens nfe' TIMEOUT 1
EXIT
ENDIF
ENDFOR
*aqui vou inserir as tag que busquei e gravei em uma tabela
CREATE TABLE TAGO( N_CAMPO C(10),CAMPO C(60))
SELECT TAGO
INSERT INTO tago (N_CAMPO,CAMPO) VALUES ('CNPJ',ctag)
INSERT INTO tago (N_CAMPO,CAMPO) VALUES ('nome',ctag1)
INSERT INTO tago (N_CAMPO,CAMPO) VALUES ('lgr',ctag2)
INSERT INTO tago (N_CAMPO,CAMPO) VALUES ('UF',ctag3)
n = 1
FOR n = 1 TO 50
IF STREXTRACT(cfile,'',n)=ALLTRIM(STR(n))
wre=STREXTRACT(cfile,'',n)
VCFOP = STREXTRACT(CFILE,'','',n)
XVCFOP = LEFT(ALLTRIM(VCFOP),2)
VICMSST = IIF(XVCFOP="51","",STREXTRACT(CFILE,'','',n))
INSERT INTO tago (N_CAMPO,CAMPO) VALUES ('iten '+wre, "CFOP="+VCFOP+" SUBTRIB = "+VICMSST )
ELSE
**se nao encontro n=50 para fechar o loop do for next
n=50
WAIT WINDOW 'Fim dos 50 itens nfe' TIMEOUT 0.5
EXIT
ENDIF
ENDFOR
BROWSE LAST normal
SELECT tago
COPY TO arq45.txt sdf
MODIFY COMMAND arq45.txt
IF SEEK(SUA VARIAVEL) && RERTONAR .T. SE ENCONTRAR
SEEK SUAVARIAVEL
IF FOUND() && SE ENCONTROU
COMANDOS....
ENDIF
Dicas para colocar mascara de digitacao nos textboxPara valores numericoss
Ex Valor
Inputmask 9,999,999.99
Value = 0
**
Para Caracter
Ex Telefone
Inputmask = ( ) -
**
Para Date e Datetime
format=RK
INPUTMASK=:
value = {}
**
Para Letras Maiusculas
Fomat = !
CODIGO VFP PARA XLS
LOCAL oExcel
oExcel = Createobject("Excel.Application")
With oExcel
.WorkBooks.Add
.Visible = .T.
VFP2Excel(_samples+'data\testdata.dbc','select * from employee',.ActiveSheet.Range('A10'))
Endwith
function VFP2Excel
lparameters tcDataSource, tcSQL, toRange
Local loConn As AdoDB.Connection, loRS As AdoDB.Recordset,ix
ix=1
loConn = Createobject("Adodb.connection")
loConn.ConnectionString = "Provider=VFPOLEDB;Data Source="+m.tcDataSource
loConn.Open()
loRS = loConn.Execute(m.tcSQL)
FOR ix=1 TO loRS.Fields.Count
toRange.Offset(0,m.ix-1).Value = PROPER(loRs.Fields(m.ix-1).Name)
toRange.Offset(0,m.ix-1).Font.Bold = .t.
ENDFOR
toRange.Offset(1,0).CopyFromRecordSet( loRS )
loRs.Close
loConn.Close
Codigo abrir um arquivo Pdf con VFP
DECLARE INTEGER ShellExecute IN SHELL32.DLL INTEGER, STRING CDIR, STRING CFILE, ;
STRING , STRING, INTEGER
carqpdf=getfile('pdf','Selecione o arquivo','selecionar')
If File(cARQPDF)
ShellExecute(0, "Open", cARQPDF,"", Fullpath(""),0)
Else
Wait Window ' O arquivo nao esta na pasta!! ' Timeout 2
Endif
***Config.fpw
TITLE = Sistema EPR Magic
PATH = Graficos;Dados;Menus;Forms;Libs;Prgs;Relats
Default= EPR
CODEPAGE=AUTO
COLLATE=GENERAL
RESOURCE=OFF
TALK=OFF
Deleted =ON
POINT=","
SEPARATOR="."
TMPFILES=C:\WINDOWS\TEMP
SYSFORMATS = OFF
CENTURY = ON
SYSMENU = OFF
safey=off
Confirm=OFF
DATE = DMY
DELETED=ON
RESOURCE = C:\WINDOWS\TEMP\alteracoes_do_projeto.dbf
**Main.prg***
Close all
Close databases all
Close tables all
Set Deleted On
Set Lock Off
Set Multilocks On
Set Ansi Off
Set Talk Off
Set Safety Off
Set Confirm Off
Set Notify Off
Set Console Off
Set Bell Off
Set Exclusive Off
Set Hours To 24
SET PATH TO Dados
SET DATE TO DMY
Set Date To British
SET CENTURY ON
SET DELETED ON
SET CURRENCY TO 'R$ '
SET POINT TO '.'
SET SEPARATOR TO ','
Set Reprocess To 2 Seconds
SET REPROCESS TO AUTOMATIC
SET REFRESH TO 5
SET EXCLUSIVE OFF
Set Sysmenu To
Set Sysmenu off
Set message on
Set statu bar on
SET CLOCK STATUS
SET DEFAULT TO (ADDBS(JUSTPATH(SYS(16,0))))
SET PATH TO data;forms;progs;reports
_SCREEN .windowstate=2
_SCREEN .CLOSABLE=.T.
_SCREEN.caption='Sitema Versao 25.07 Hoje '+DTOC(DATE())
_screen.Visible = .T.
_screen.icon = 'BRAZIL.ICO'
_screen.FORECOLOR=rgb( 0,0,255)
_screen.backcolor = RGB(255,255,255)
do form main.scx
read events
02-)Codigo para abrir arquivo PDF no VFP
LOCAL loShell as Shell.Application
loShell = CREATEOBJECT("Shell.Application")
arqui=getfile('pdf','Escolha o arquivo','Selecione' , 1,'Escolha 1 Arq Pdf')
**se for xls //arqui=getfile('Xls','Escolha o arquivo','Selecione' , 1,'Escolha 1 Xls')
loShell.ShellExecute(arqui)
RELEASE loShell
*
*Abrir o Internet Explorer com Google em uma pesquisa
DECLARE INTEGER SetForegroundWindow IN user32.dll INTEGER
oIE = CREATEOBJECT("internetexplorer.application")
oIE.navigate("http://www.google.com/search?q="+"erro script IE"+"")
oIE.Visible = .T.
=SetForegroundWindow(oIE.HWND)
**
*Como saber o codigo AscII
=Tecla()
Function Tecla
janela( 01,01,24,79,'Esc->Sair Tecla precione 1 tecla p/ saber o codigo Asc')
do while lastkey () != 27
clear
@ 10, 10 say 'Tecle Algo..:'
inkey (0)
@ 10, 30 say lastkey ()
inkey (0)
if lastkey () = 27
RELEASE WINDOWS xy
WAIT WINDOW 'saindo ' TIMEOUT 1
RETURN
endif
loop
enddo
RETURN
ENDFUNC
FUNCTION janela(LI, CI, LF, CF,CTITLE)
if type('cTitle') != 'C'
cTitle = " "
ENDIF
DEFINE WINDOW XY in desktop AT LI,CI SIZE LF,CF title cTitle ;
Font "MS Sans Serif", 8 STYLE "B" float close SYSTEM color rgb(,,,2402,240,240)
MOVE WINDOW xy center
ACTIVATE WINDOW XY
endfunc
2-browses 2 tabela simultaneas
*Dois (2) BROWSES set relation
CLOSE DATABASES all
SET SAFETY off
CREATE TABLE pedido(codigo c(4),data d(8),codcli c(4),valor n(8,2))
INSERT INTO pedido VALUES ('0001',DATE(),'0001',100)
INSERT INTO pedido VALUES ('0002',DATE()+10,'0002',100)
INSERT INTO pedido VALUES ('0003',DATE(),'0001',100)
INDEX ON CODIGO TAG CODIGO
CREATE TABLE MovPed(codped c(4),codprod c(4),quant n(4), valvend n(8,2))
INSERT INTO movped values('0001','0001',6,60)
INSERT INTO movped values('0001','0002',2,40)
INSERT INTO movped values('0002','0001',5,50)
INSERT INTO movped values('0002','0002',6,60)
INSERT INTO movped values('0002','0003',2,40)
INSERT INTO movped values('0003','0001',6,60)
INSERT INTO movped values('0003','0002',2,40)
INDEX ON CODPED TAG CODPED
CREATE table produto(codigo c(4),descricao c(30),valor n(8,2))
INSERT INTO produto values('0001','CIMENTO TIPO 1 ',10)
INSERT INTO produto values('0002','AREIA TIPO 2 ',10)
INSERT INTO produto values('0003','PEDRA TIPO 2 ',10)
DEFINE WINDOW pedidos FROM 0,0 TO 18,125 TITLE 'pedidos' FLOAT close
DEFINE WINDOW movimento FROM 20,0 TO 40,125 TITLE 'movimento' FLOAT close
CLOSE DATABASES ALL
SELECT 0
USE movped
SET ORDER TO codped
SELECT 0
USE pedido
SET ORDER TO codigo
SET RELATION TO codigo INTO movped additive
SELECT movped
ACTIVATE WINDOW movimento
BROWSE NOWAIT IN WINDOW movimento
SELECT pedido
ACTIVATE WINDOW pedidos
BROWSE IN WINDOW pedidos
CLOSE ALL
**
*Scather (ler) e Gather (gravar)
CLOSE DATABASES ALL
SET SAFETY OFF
CREATE TABLE CATALOGO (CODIGO N(4),NOMES C(30))
CREATE TABLE CATA9 (CODIGO N(4),NOMES C(30))
FOR I=1 TO 20
INSERT INTO CATA9 (CODIGO,noMES) VALUES (I,"CLIENTE "+STR(I))
ENDFOR
Close DATABASES
USE CATA9 IN 1
use CATALOGO IN 2
Select 1
Go Top
Do While !eof()
Scatter memvar
Select 2
Append Blank
Gather memvar
Select 1
Skip
Enddo
SELECT 2
BROWSE LAST
***
*Gerar um txt
CLOSE DATABASES
CREATE table TABELA ( MeuMemo M )
IF FILE('OTESTO.TXT')
DELETE FILE OTESTO.TXT
ENDIF && Gerando arquivo txt
SET TEXTMERGE OFF
TEXT TO cMemo TEXTMERGE NOSHOW
linha 1 CARTAO VISAO 34,50
linha 2 CHEQUE NR.178 73,40
linha 3 DINHEIRO 22,10
linha 4 DINHEIRO 10,11
linha 5 CARTAO VISA 6,50
linha 6 CH BRADESCO 11,10
linha 7 CH ITAU 9,50
linha 8 CH BOSTON 12,22
linha 9 CH.ITAU 11,10
linha 10 CH BRADESCO 22,10
ENDTEXT
MESSAGEBOX( textmerge(cMemo),48,'texto gerado',2000)
INSERT INTO TABELA (MeuMemo) VALUES (cMemo) && browse
*GERO O UM TESTO DO CAMPO MEMO "MEUMEMO" LINHA A LINHA
**NOME DO ARQUIVO GERADO OTESTO.TXT
CREATE CURSOR JULIO (CONTEM C(90),LINHA N (4))
SET MEMOWIDTH TO 126
n=1
VTOTALLINHAS = MEMLINES(TABELA.MEUmemo)
FOR SEQUENCIADOR = 1 TO VTOTALLINHAS
VLINHA = MLINE(TABELA.MEUmemo,SEQUENCIADOR)
INSERT INTO julio (contem,linha) VALUES (vlinha,n)
StrTOfile(TRANSFORM(VLINHA)+CHR(13)+CHR(10),"OTESTO.TXT",.T.)
n=n+1
ENDFOR
* MODIFY COMMAND OTESTO.TXT
DELETE FILE OTESTO.TXT
****
Select JULIO
WVARIAVEL=""
GO 1
WVARIAVEL=ALLTRIM(JULIO.CONTEM)+' '
GO 4
WVARIAVEL=WVARIAVEL+ALLTRIM(JULIO.CONTEM)+' '
GO 7
WVARIAVEL=WVARIAVEL+ALLTRIM(JULIO.CONTEM)+' '
GO 10
WVARIAVEL=WVARIAVEL+ALLTRIM(JULIO.CONTEM)+' '
Select JULIO
WVARIA=""
GO 2
WVARIA=ALLTRIM(JULIO.CONTEM)+' '
GO 5
WVARIA=WVARIA+ALLTRIM(JULIO.CONTEM)+' '
GO 8
WVARIA=WVARIA+ALLTRIM(JULIO.CONTEM)+' '
WAIT WINDOW ' gerando o relatorio' NOWAIT NOCLEAR
Create TABLE Tabla1 (Txt C(78))
Insert Into Tabla1 Values ("Relatorio do Julio colunar "+DTOC(DATE()))
Insert Into Tabla1 Values ("=============================== ")
Insert Into Tabla1 Values (WVARIAVEL)
Insert Into Tabla1 Values (wVARIA)
Insert Into Tabla1 Values ("=============================== ")
Insert Into Tabla1 Values ("EU JULIO fiz este Report sem abrir o VFP, ")
Insert Into Tabla1 Values ("Sao Paulo, 26/1/2011 ")
Insert Into Tabla1 Values (" ")
Insert Into Tabla1 Values ("====================== ")
SELECT tabla1
WAIT CLEAR
Create Report Reporte1 From Tabla1
USE reporte1.frx IN 0
SELECT reporte1
REPLACE fontface with "Courier New", fontsize WITH 14, STYLE WITH "B", fontstyle WITH 1 FOR objtype = 1
USE IN reporte1
SELECT Tabla1
Report Form Reporte1 Preview Nowait
CLOSE DATABASES all
*Encripitar uma Data *
CLOSE DATABASES all
Local dExemplo1 As Date
CREATE cursor adatas (datas1 d(8) ,segu c(22))
INSERT INTO adatas(datas1) VALUES (DATE())
dExemplo1 = adatas.datas1 &&{^2011-07-06}
Messagebox(dExemplo1 ,48+0+0,"A variavel data é",2000)
Messagebox(criptDate(dExemplo1),48,"criptou",3129 )
mdata=criptDate(dExemplo1)
replace adatas.segu WITH mdata
BROWSE LAST normal
Messagebox(decriptDate(adatas.segu),68,'Descriptou Campo',2000)
Messagebox(decriptDate(criptDate(dExemplo1)),68,'descriptou',2000)
Function criptDate(dData As Date) As String
Local strRetorno As String,dDataBase As Date,iDias As Number,strDias As String
dDataBase = {^1900-01-01} && data inicial basica
iDias = dData - dDataBase && Valor inteiro que corresponde a data
* Aqui fasso uma criptografia simpres como exemplo
Do Case
Case iDias >50000
strRetorno = "A"
Case iDias >40000
strRetorno = "B"
Case iDias >30000
strRetorno = "C"
Case iDias >20000
strRetorno = "D"
Case iDias >10000
strRetorno = "E"
Otherwise
strRetorno = "F"
Endcase
strDias = Padl(iDias ,5,[0])
strRetorno = strRetorno + Chr(Val(Substr(strDias ,2,2))+50)
strRetorno = strRetorno + Chr(Val(Substr(strDias ,4,2))+50)
*** Fim - Aqui fasso uma criptografia simpres como exemplo
Return strRetorno
Endfunc
Function decriptDate(strCript As String) As Date
Local dRetorno As Date,dDataBase As Date,iDias As Number,strDias As String
dDataBase = {^1900-01-01} && data inicial basica
*** Aqui descfasso uma criptografia simpres como exemplo
Do Case
Case Substr(strCript,1,1) == "A"
strDias = "5"
Case Substr(strCript,1,1) == "B"
strDias = "4"
Case Substr(strCript,1,1) == "C"
strDias = "3"
Case Substr(strCript,1,1) == "D"
strDias = "2"
Case Substr(strCript,1,1) == "E"
strDias = "1"
Case Substr(strCript,1,1) == "F"
strDias = "0"
Otherwise
Return Null
Endcase
strDias = strDias + Padl(Asc(Substr(strCript,2,1))-50,2,[0])
strDias = strDias + Padl(Asc(Substr(strCript,3,1))-50,2,[0])
iDias = Val(strDias ) && Valor inteiro que corresponde a data
dRetorno = dDataBase + iDias
*** Fim - Aqui fasso uma criptografia simpres como exemplo
Return dRetorno
Endfunc
*
*** Fim da rotina cript
Exemplo strzero()
wvar=1500
wre=strzero(wvar,8)
MESSAGEBOX(wre)
**00001500
function STRZERO(Var1, Var2, Var3)
Local WVar1
if (PCount() = 3)
WVar1 = Str(Var1, Var2, Var3)
endif
if (PCount() = 2)
WVar1 = Str(Var1, Var2)
endif
if (PCount() = 1)
WVar1 = Str(Var1)
endif
return Replicate("0", Len(WVar1) - Len(LTrim(WVar1))) + LTrim(WVar1)
**
right('000'+this.value,3)
**
Exemplo: impressora matricial
*-- direciona a impressoa
SET PRINTER TO NAME GETPRINTER( )
??? "Imprime onde esta o carro da impressora"
??? chr(13)+chr(10) &&-- pula linha
??? "Imprime na proxima linha"
*-- pula 10 linhas
for i=1 to 10
??? chr(13)+chr(10) &&-- pula linha
next
*-- despeja o buffer
SET PRINTER TO
Chamar form com retorno de variavel
1-No init do form1(chamador) publica as variaveis :
public m.ValorRetorno, m.valorretorno2
2-chame o form2
do form2 with valor1,valor2
3-no destroy do form2 atribua os valores as variaveis
m.ValorRetorno = seu_valor1
m.valorretorno2 = seu_valor2
4- No destroy do form1 libere as variaveis
release m.ValorRetorno, m.valorretorno2
Outra forma de fazer
******
FormA e FormB
Do form formB with thisform.valorvai.value to m.valorvolta
Altere a propriedade WINDOWTYPE do formB chamado para 1-MODAL.
Crie 2 propriedades no FormB - valorreceb e valorretor.
No Init do formB :
Lparam m.valorchegado
Thisform.valorreceb = m.valorchegado
Preencha m.valorretor com algum valor e dê um Thisform.Release ( onde achar melhor ).
No Evento Unload do formB :
Return Thisform.ValorRetor
*** REGISTROS DUPLICADO
CLEAR ALL
CLOSE DATABASES ALL
SET SAFETY OFF
SET DELETED ON
SELECT * FROM MUSICA WHERE !EMPTY(CANTOR) INTO TABLE CANTOR
*BROWSE
USE
LOCAL wo
c = 0
d = 0
CLOSE DATABASES ALL
USE CANTOR IN 0 ALIAS CANTOR
SELECT CANTOR
INDEX on CANTOR TO ssA
GO TOP IN CANTOR
DO WHILE ( Not Eof( "CANTOR" ) )
wo= CANTOR.CANTOR
SKIP IN CANTOR
DO WHILE ( CANTOR.CANTOR = wo And Not Eof( "CANTOR" ) )
DELETE IN CANTOR
c = c + 1
WAIT WINDOW 'Registros Duplicados Apagados '+ str(c) TIMEOUT 0.05
SKIP IN CANTOR
ENDDO
d = d+1
WAIT WINDOW 'Registros Lidos '+ str(d) TIMEOUT 0.1
ENDDO
**Store procedure mysql
Stored Procedure no Mysql 5.1
Obs: Para criar Stored Procedure nesse exemplo, utilizarei o mysql-front.
Primeiro vamos criar a tabela que iremos utilizar:
Código:
CREATE TABLE tbl_cliente (
cli_id int(5) auto_increment primary key unique,
cli_nome varchar(60) not null,
cli_cpf varchar(20) not null unique
);
Inserindo alguns dados na tabela tbl_cliente:
Código:
insert into tbl_cliente(cli_nome,cli_cpf)values('Fernanda','00000');
insert into tbl_cliente(cli_nome,cli_cpf)values('Vanessa','11111');
insert into tbl_cliente(cli_nome,cli_cpf)values('Cristina','22222');
insert into tbl_cliente(cli_nome,cli_cpf)values('Poliana','33333');
insert into tbl_cliente(cli_nome,cli_cpf)values('Sandra','44444');
insert into tbl_cliente(cli_nome,cli_cpf)values('Carla','55555');
Podemos usar 3 tipos de parametros existentes em uma SP no mysql
IN - Para entrada de dados.
OUT - Para saida de dados.
INOUT - Para entrada e saida de dados.
Criaremos nossas procedures com as funcoes de INSERIR,DELETAR,ATULIZAR e MOSTRAR DADOS DA TABELA, com entrada de parametros.
Criando Stored procedure para inserir dados em nossa tabela tbl_cliente
Código:
create procedure add_cliente
(
IN p_nome varchar(50),
IN p_cpf varchar(20)
)
Begin
insert into tbl_cliente ( cli_nome, cli_cpf ) values( p_nome, p_cpf );
end;
Para chamar essa Stored Procedure criada usamos Call().
Vamos inserir alguns dados utilizando essa Stored Procedure add_cliente().
Código:
call add_cliente('suellen','66666');
call add_cliente('claudia','77777');
Se verificar em sua tabela vera que os dados foram inseridos.
------
Criando Stored procedure para apagar dados em nossa tabela tbl_cliente
Código:
create procedure del_cliente
(IN p_cod int(5) )
Begin
delete from tbl_cliente where cli_id = p_cod;
end;
Vamos apagar alguns dados da nossa tabela tbl_cliente
Código:
Call del_cliente(2);
Call del_cliente(4);
Repare em sua tabela que os clientes com os codigos 2 e 4 foram apagados.
----
Criando Stored procedure para atualizar dados em nossa tabela tbl_cliente
Código:
create procedure update_cliente
(
IN p_cod int,
IN p_nome varchar(60),
IN p_cpf int(5)
)
Begin
update tbl_cliente
set
cli_nome = p_nome,
cli_cpf = p_cpf
where
cli_id = p_cod;
end;
vamos atualizar alguns dados da nossa tabela tbl_cliente
Código:
Call update_cliente(1,'MARIA',99999);
Call update_cliente(3,'SOLANGE',88888);
Note que atualizamos os clientes com codigos 1 e 3.
----
Criando Stored procedure para mostra os dados da nossa tabela tbl_cliente
Obs: Nesse caso voce pode utilizar de parametros ou nao.Caso queira
utilizar parametros a ideia e a mesma para os exemplos acima.
Código:
create procedure mostra_cliente()
Begin
select * from tbl_cliente;
end;
Vamos chamar nossa Stored procedure para mostrar os dados da tabela.
Código:
Call mostra_cliente();
---fim store procedure
***Codigo inicio no teu main.prg
ON SHUTDOWN QUIT
On Error Do errores With Error( ),Message( ),Message(1),Program( ),Lineno( )
Procedure Errores
PARAMETER merror, mess, mess1, mprog, mlineno
nOpc= MESSAGEBOX("Ocorreu un error:"+CHR(13)+CHR(13)+;
"Data/Hora.: "+TTOC(DATETIME())+CHR(13)+;
'Número de error: ' + LTRIM(STR(merror))+CHR(13)+ ;
'Menssage do error: ' + mess+ CHR(13)+ ;
'Línha do código com error: ' + mess1+CHR(13)+ ;
'Número da línha do erro : ' +;
LTRIM(STR(mlineno))+CHR(13)+ ;
'Programa com error: ' + mprog, 2+48)
DO CASE
CASE nOpc = 3 && Anular
CANCEL
CASE nOpc = 4 && Reintentar
RETRY
CASE nOpc = 5 && Ignorar
RETURN .T.
ENDCASE
RETURN
Store procedure mysql
Stored Procedure no Mysql 5.1
Obs: Para criar Stored Procedure nesse exemplo, utilizarei o mysql-front.
Primeiro vamos criar a tabela que iremos utilizar:
Código:
CREATE TABLE tbl_cliente (
cli_id int(5) auto_increment primary key unique,
cli_nome varchar(60) not null,
cli_cpf varchar(20) not null unique
);
Inserindo alguns dados na tabela tbl_cliente:
Código:
insert into tbl_cliente(cli_nome,cli_cpf)values('Fernanda','00000');
insert into tbl_cliente(cli_nome,cli_cpf)values('Vanessa','11111');
insert into tbl_cliente(cli_nome,cli_cpf)values('Cristina','22222');
insert into tbl_cliente(cli_nome,cli_cpf)values('Poliana','33333');
insert into tbl_cliente(cli_nome,cli_cpf)values('Sandra','44444');
insert into tbl_cliente(cli_nome,cli_cpf)values('Carla','55555');
Podemos usar 3 tipos de parametros existentes em uma SP no mysql
IN - Para entrada de dados.
OUT - Para saida de dados.
INOUT - Para entrada e saida de dados.
Criaremos nossas procedures com as funcoes de INSERIR,DELETAR,ATULIZAR e MOSTRAR DADOS DA TABELA, com entrada de parametros.
Criando Stored procedure para inserir dados em nossa tabela tbl_cliente
Código:
create procedure add_cliente
(
IN p_nome varchar(50),
IN p_cpf varchar(20)
)
Begin
insert into tbl_cliente ( cli_nome, cli_cpf ) values( p_nome, p_cpf );
end;
Para chamar essa Stored Procedure criada usamos Call().
Vamos inserir alguns dados utilizando essa Stored Procedure add_cliente().
Código:
call add_cliente('suellen','66666');
call add_cliente('claudia','77777');
Se verificar em sua tabela vera que os dados foram inseridos.
------
Criando Stored procedure para apagar dados em nossa tabela tbl_cliente
Código:
create procedure del_cliente
(IN p_cod int(5) )
Begin
delete from tbl_cliente where cli_id = p_cod;
end;
Vamos apagar alguns dados da nossa tabela tbl_cliente
Código:
Call del_cliente(2);
Call del_cliente(4);
Repare em sua tabela que os clientes com os codigos 2 e 4 foram apagados.
----
Criando Stored procedure para atualizar dados em nossa tabela tbl_cliente
Código:
create procedure update_cliente
(
IN p_cod int,
IN p_nome varchar(60),
IN p_cpf int(5)
)
Begin
update tbl_cliente
set
cli_nome = p_nome,
cli_cpf = p_cpf
where
cli_id = p_cod;
end;
vamos atualizar alguns dados da nossa tabela tbl_cliente
Código:
Call update_cliente(1,'MARIA',99999);
Call update_cliente(3,'SOLANGE',88888);
Note que atualizamos os clientes com codigos 1 e 3.
----
Criando Stored procedure para mostra os dados da nossa tabela tbl_cliente
Obs: Nesse caso voce pode utilizar de parametros ou nao.Caso queira
utilizar parametros a ideia e a mesma para os exemplos acima.
Código:
create procedure mostra_cliente()
Begin
select * from tbl_cliente;
end;
Vamos chamar nossa Stored procedure para mostrar os dados da tabela.
Código:
Call mostra_cliente();
---fim store procedure
***Codigo inicio no teu main.prg
ON SHUTDOWN QUIT
On Error Do errores With Error( ),Message( ),Message(1),Program( ),Lineno( )
Procedure Errores
PARAMETER merror, mess, mess1, mprog, mlineno
nOpc= MESSAGEBOX("Ocorreu un error:"+CHR(13)+CHR(13)+;
"Data/Hora.: "+TTOC(DATETIME())+CHR(13)+;
'Número de error: ' + LTRIM(STR(merror))+CHR(13)+ ;
'Menssage do error: ' + mess+ CHR(13)+ ;
'Línha do código com error: ' + mess1+CHR(13)+ ;
'Número da línha do erro : ' +;
LTRIM(STR(mlineno))+CHR(13)+ ;
'Programa com error: ' + mprog, 2+48)
DO CASE
CASE nOpc = 3 && Anular
CANCEL
CASE nOpc = 4 && Reintentar
RETRY
CASE nOpc = 5 && Ignorar
RETURN .T.
ENDCASE
RETURN
**
wa=diaext(DATE())
wait window wa timeout(2)
?diaext(DATE())
FUNCTION diaext(DATA)
dia=DOW(DATA)
DIMENSION semana[7]
semana[1]="DOMINGO"
semana[2]="SEGUNDA"
semana[3]="TERÇA"
semana[4]="QUARTA"
semana[5]="QUINTA"
semana[6]="SÁBADO"
semana[7]="DOMINGO"
? semana[DIA]
RETURN (semana[DIA])
ENDFUNC
***como fazer uma funcao
Funciton nomedela
Parameters nomeretorno
...Seu codigo
Return(nomeRetorno)
Endfunc
* Exemplo
*Data por extenso
SET DATE BRITISH
SET CENTURY on
DATA1=CTOD('14/11/2012') && *DATA1=DATE()
= DATAEXT(DATA1)
***
FUNCTION DATAEXT()
PARAMETERS data1,alou,DIA,WVALOR
IF EMPTY(data1)
WAIT WINDOW 'vc nao informou a data' TIMEOUT 1
RETURN .f.
ENDIF
WVALOR=''
mes=MONTH(data1 )
DIMENSION DIA(31)
DIA(1) = "UM"
DIA(2) = "DOIS"
DIA(3) = "TRES"
DIA(4) = "QUATRO"
DIA(5) = "CINCO"
DIA(6) = "SEIS"
DIA(7) = "SETE"
DIA(8) = "OITO"
DIA(9) = "NOVE"
DIA(10) = "DEZ"
DIA(11) = "ONZE"
DIA(12) = "DOZE"
DIA(13) = "TREZE"
DIA(14) = "QUATROZE"
DIA(15) = "QUINZE"
DIA(16) = "DEZESSEIS"
DIA(17) = "DEZESETE"
DIA(18) = "DEZOITO"
DIA(19) = "DEZENOVE"
DIA(20) = "VINTE"
DIA(21) = "VINTE UM"
DIA(22) = "VINTE DOIS"
DIA(23) = "VINTE E TRES"
DIA(24) = "VINTE E QUATRO"
DIA(25) = "VINTE E CINCO"
DIA(26) = "VINTE SEIS"
DIA(27) = "VINTE SETE"
DIA(28) = "VINTE OITO"
DIA(29) = "VINTE NOVE"
DIA(30) = "TRINTA"
DIA(31) = "TRINTA UM"
DIMENSION alou(12)
alou(1) = "Janeiro"
alou(2) = "Fevereiro"
alou(3) = "Marco"
alou(4) = "ABRIL"
alou(5) = "MAIO"
alou(6) = "JUNHO"
alou(7) = "JULHO"
alou(8) = "AGOSTO"
alou(9) = "SETEMBRO"
alou(10) = "OUTUBRO"
alou(11) = "NOVEMBRO"
alou(12) = "DEZEMBRO"
*? DIA(DAY(DATA1))
wvalor=DIA(DAY(DATA1))+" de " +alou(mes)+ " de " +LTRIM(STR(YEAR(data1 )))
WAIT WINDOW WVALOR TIMEOUT 1
RETURN (wvalor)
**
Dica erro no arquivo scx do form
Dica sobre ERROR LOADING FILE RECORD NUMBER 18
USE seuform.scx
REPLACE ALL objcode WITH ''
CLOSE DATABASES
COMPILE FORM seuform.scx
* 1 Ex.livro caixa (entrada de edados) .crie 1 tabela de nome Caixa ,
* com DATA,HIS.DEB,CRE,SAL e a tabela deve ter o nome de CAIXA.
* Veja um livro caixa ,
Close Databases
Set Safety Off
ON KEY LABEL f2 funcao1()
ON KEY LABEL f3 funcao2()
if not file('caixa.dbf')
Create Table caixa( data d(8) , his c(30), deb N(10,2),cre N(10,2), sal N(10,2) )
Select caixa
use in caixa
endif
clear
use caixa
a=0
browse fields data,his :w=funcao1(),deb,cre,sal :w=funcao2()
function funcao1
append blank
Function Funcao2
a=a+deb-cre
replace sal with a
*Fim Livro Caixa
02-memoria do computador
DECLARE GlobalMemoryStatus IN Win32API STRING @MemStat
cResul2 = ""
cResul3 = ""
cEnter2 = CHR(13)
cBuffer = fLong2str( 32 ) + REPLICATE( CHR( 0 ), 28 )
GlobalMemoryStatus( @cBuffer )
nMemoryLoad = fStr2long( SUBSTR( cBuffer, 5, 4 ))
nTotalPhys = fStr2long( SUBSTR( cBuffer, 9, 4 )) / 1024
nAvailPhys = fStr2long( SUBSTR( cBuffer, 13, 4 )) / 1024
nTotalPageFile = fStr2long( SUBSTR( cBuffer, 17, 4 )) / 1024
nAvailPageFile = fStr2long( SUBSTR( cBuffer, 21, 4 )) / 1024
nTotalVirtual = fStr2long( SUBSTR( cBuffer, 25, 4 )) / 1024
nAvailVirtual = fStr2long( SUBSTR( cBuffer, 29, 4 )) / 1024
CLEAR
cResul2 = cResul2 + "Memoria Lida:" + TRANSFORM( nMemoryLoad, "999,999,999" ) + "%" +cEnter2
cResul2 = cResul2 + "Memoria Fisca:" + TRANSFORM( nTotalPhys, "999,999,999" ) + "k" +cEnter2
cResul2 = cResul2 + "Memória Disponível:" + TRANSFORM( nAvailPhys, "999,999,999" ) + "k" +cEnter2
cResul3 = cResul3 + "Arquivo:" + TRANSFORM( nTotalPageFile, "999,999,999" ) + "k" +cEnter2
cResul3 = cResul3 + "Disponivel para arquivo:" + TRANSFORM( nAvailPageFile, "999,999,999" ) + "k" +cEnter2
cResul3 = cResul3 + "Total de Memoria Virtual:" + TRANSFORM( nTotalVirtual, "999,999,999" ) + "k" +cEnter2
cResul3 = cResul3 + "Memoria Virtual disponível:" + TRANSFORM( nAvailVirtual, "999,999,999" ) + "k" +cEnter2
WAIT WINDOW cResul2 TIMEOUT 14
WAIT window cResul3
*********
FUNCTION fLong2str( iLongVal )
LOCAL iBit, cResult
cResult = ""
FOR iBit = 24 TO 0 STEP -8
cResult = CHR( INT( iLongVal / (2^iBit) )) + cResult
iLongVal = MOD( iLongVal, (2^iBit) )
NEXT
RETURN cResult
ENDFUNC && flong2str( iLongVal ).
*********
FUNCTION fStr2long( cLong )
LOCAL iBit, iResult
iResult = 0
FOR iBit = 0 TO 24 STEP 8
iResult = iResult + (ASC(cLong) * (2^iBit))
cLong = RIGHT( cLong, LEN(cLong) - 1 )
NEXT
RETURN iResult
ENDFUNC && fStr2long( cLong ).
02-c Verficar se ha conexao na internet
DECLARE INTEGER SetForegroundWindow IN user32.dll INTEGER
oIE = CREATEOBJECT("internetexplorer.application")oIE.navigate("http://online.webng.com/atualizacaosistema.rar")oIE.Visible = .T.
=SetForegroundWindow(oIE.HWND)
**outro exemplo
DECLARE LONG InternetGetConnectedState IN "wininet.dll" LONG lpdwFlags, LONG dwReservedIF InternetGetConnectedState(0, 0) = 1
RUN /n explorer.exe http://motosline.webng.com/atualizacaosistema.rar
wait windo "Baixando 1 arquivo em http OK!" timeout(1)
ELSEMESSAGEBOX("Conexão com a Internet não disponível!",48,'Atencao',1000)
ENDIF***De Outra forma
******** Firewall não barra
declare integer InternetGetConnectedState in WinInet.dll integer @lpdwFlags, integer dwReserved
nFlags = 0
nResult = InternetGetConnectedState (@nFlags, 0)
**? iif (nResult = 1, "Connected.", "Not connected.")
IF nResult = 1
MESSAGEBOX('Conectado')
ELSE
MESSAGEBOX('Desconectado')
ENDIF
****** Firewall barra
DECLARE INTEGER InternetCheckConnection;
IN wininet;
STRING lpszUrl,;
INTEGER dwFlags,;
INTEGER dwReserved
IF InternetCheckConnection("http://yahoo.com.br",1,0) = 0
=MESSAGEBOX("O Computador Não está Conectado a Internet, ou Há um Bloqueio do Firewall ou o Servidor de Internet está fora do Ar!",64,"Aviso")
ENDIF
**
03-)Função para verificar a impressora default
SET CONSOLE OFF
SET NOTIFY off
SET SAFETY OFF
APRINTERS(gaprinters, 1)
CREATE CURSOR imprs (caminho c(50), porta c(50), nomeimp c(50), COMMEN c(50))
INSERT INTO imprs FROM ARRAY gaprinters
SELECT imprs
GO TOP
*aqui o browse e so pra voce ver depos exluir alinha browse
BROWSE NORMAL NODELETE TITLE ' Sair'
Declare Integer GetDefaultPrinter In winspool.drv String @pszBuffer, Integer @pcchBuffer
nBufsize = 250
cPrinter = Replicate(Chr(0), nBufsize)
= GetDefaultPrinter(@cPrinter, @nBufsize)
cPrinter = Substr(cPrinter, 1, At(Chr(0),cPrinter)-1)
Select imprs.nomeimp From imprs Where imprs.caminho = Alltrim(cPrinter) Into Cursor impbusca
Select impbusca
Public impdefaut
impdefault = impbusca.nomeimp
MESSAGEBOX('a impressora padrao é:'+CHR(13)+impdefault,48,'aviso')
SET PRINTER TO NAME GETPRINTER()
**ou nomeservidornome da impressora
SET PRINTER TO NAME &impdefault
REPORT FORM nomedoseureport TO PRINTER console
ou
direto
_screen.windowstate = 2
set print to name getprinter()
report form listcli1.frx to printer console
return
****
ou
****
IF APRINTERS(gaprinters) < 1 && Se nao houver drivers de impressora instalada
WAIT windows 'Nenhuma impressora instalada'
ELSE
SET PRINTER TO NAME "novaPDF" && Para colocar impressora padrao no fox
SELECT Pesquisa
REPORT FORM proposta NOCONSOLE TO PRINTER prompt
ENDIF
***
ou
SET PRINTER TO NAME "ZEBRA" && depois confirma a impressora
SET DEVICE TO PRINT
SET PRINTER FONT 'MS Sans Serif', 10 STYLE "B"
**REPORT FORM RELATORIO TO PRINTER && aqui imprimir o Log da empresa
SET PRINTER TO arq.txt
l=1
@ l+1,0 say "Teste da Impressora" FONT 'Courier', 12 STYLE "B"
? CHR(13)+CHR(10)
@ l+1,0 say "na linha de cima pular uma linha ou usar uma ?"
@ L+1,0 SAY '***'
@ l+1,0 say "CAXAMBU EVENTOS"+CHR(18)
@ l+1,0 say "Centro de DIVERSÃO " +CHR(14)
@ l+1,0 say " Rua Azilo,56 VL.JO SAO PAUL0"
?
SET PRINTER to
MODIFY file arq.txt
IF FILE('arq.txt')
RUN /n TYPE arq.TXT > LPT1
ELSE
WAIT WINDOW 'nao encontrei' TIMEOUT 1
endif
ou
**
SYS(2040) onde: 0 = impressao finnalizada
1 = modo preview
2 = imprimindo ou sendo enviado
Report Form cotacao.frx TO PRINTER NODIALOG NOCONSOLE
Do while .t.
if sys(2040) = "0" && verifica se terminou a impressao
exit && sai do loop e continua o resto da rotina
endif
inkey(.5) && espera .5 segundo para nova verificacao
Enddo
**
gerando um arquivo.txt rapido
*****
TEMP=FCREATE("ARQUIVO.TXT") && Cria o Arquivo.txt
FOR I=1 TO 20 && conta de 1 a 20
** GRAVAR AS 20 LINHAS
=Fputs(TEMP,"txt GRAVANDO a LINHA"+STR(I,3)+CHR(13)+CHR(10))
NEXT
FCLOSE(TEMP) && fECHAR O ARQUIVO
CLOSE all
MODIFY FILE arquivo.txt && abrindo o editor
Para gerar o pdf direto, estou usando a versao 90. funcionou
primeiro vc tera ke baixar o FOXyPreviewer para pdf no link
http://foxypreviewer.codeplex.com/releases/view/49471
codigo estou gerando um pdf teste1.pdf, com um report da pasta solution
***
SET PROCEDURE TO LOCFILE("FoxyPreviewer.App") ADDITIVE
SET REPORTBEHAVIOR 90
LOCAL loReport as "PreviewHelper" OF "FoxyPreviewer.App"
loReport = CREATEOBJECT("PreviewHelper")
WITH loReport as ReportHelper
.AddReport(_Samples + "\Solution\Reports\percent.frx", "NODIALOG")
.cDestFile = "c:\Teste1.pdf" && Use para criar uma previsão de saída
.RunReport()
ENDWITH
loReport = NULL
RUN /N Explorer.Exe c:\Teste1.pdf
03a-)Codigo para Abrir uma pagina no internet Explorer pelo VFP
DECLARE INTEGER SetForegroundWindow IN user32.dll INTEGER
oIE = CREATEOBJECT("Internetexplorer.application")
oIE.navigate("http://www.google.com.br")
oIE.Visible = .T.
=SetForegroundWindow(oIE.HWND)
*ou
LOCAL teste
oForm = CREATEOBJECT("teste")
oForm.SHOW(1)
* Definição do Form
DEFINE CLASS teste AS FORM
CAPTION = "Abrindo uma Pagina na Internet pelo Vfp"
BACKCOLOR = RGB(255,255,255)
ICON = ""
DESKTOP = .T.
MINBUTTON = .T.
MAXBUTTON = .T.
top=0
left=0
height=580
width=800
ADD OBJECT oleIE AS OLECONTROL WITH ;
TOP = 0, LEFT = 0, WIDTH = 795, HEIGHT = 575, OLECLASS = "Shell.Explorer.2"
PROCEDURE oleIE.REFRESH
NODEFAULT
ENDPROC
PROCEDURE INIT
THISFORM.oleIE.navigate("http://www.google.com.br")
ENDPROC
03-b) Incluir um campo em uma tabela com comando ALTER TABLE
IF NOT USED('pedidos')
USE pedidos IN 0 EXCLUSIVE ALIAS pedidos
ENDIF
SELECT pedidos
IF TYPE('pedidos.cidade')='U'
ALTER TABLE pedidos ADD cidade c(25)
ALTER TABLE pedidos ADD ufs c(2)
ELSE
WAIT WINDOW 'o campo Cidade ja existe na tabela ' TIMEOUT 1
ENDIF
GO TOP IN pedidos
BROWSE LAST NORMAL FIELDS cidade,uf,nome
04-)*Codigo para Corrigndo indices
WAIT WINDOW "Verifico se o Arq.Danificou Espere" nowait
nReparos = 0
nTotReg = Adir(aDbfs,"*.dbf")
For nFor = 1 To nTotReg
cArq = aDbfs(nFor,1)
WAIT WINDOW "Verifico se Arq "+cArq+" Danificou Aguarde" nowait
If Upper(cArq) <> "FOXUSER.DBF"
nError = 0
lError = .F.
Use (cArq) In 1 Exclusive
**
If lError
=Aerror(aArrErr)
nError = aArrErr(1,1)
Endif
******
If nError = 2091 Or nError = 2065
If Messagebox("Encontrou 1 arq Corrompido"+Chr(13)+;"Deseja tentar recuperar ?",4+32+256,"CUIDADO") = 6
** A linha abaixo usar somente no fox 9
* Set TABLEVALIDATE To 0
nError = 0
lError = .F.
Use In 1
Use (cArq) In 1 Exclusive
If lError
=Aerror(aArrErr)
nError = aArrErr(1,1)
Endif
If nError = 0
lcColumnName = Substr(Sys(2015),1,10)
Alter Table &cArq Add Column (lcColumnName) c(1)
Alter Table &cArq Drop Column (lcColumnName)
USE
nReparos = nReparos + 1
Else
Messagebox("O arquivo "+cArq+" ainda esta corrompido",48,"ATENÇÃO")
Endif
nError = 0
lError = .F.
** A linha abaixo usar somente no fox 9
*Set TABLEVALIDATE TO 3
Use (cArq) In 1 Exclusive
If lError
=Aerror(aArrErr)
nError = aArrErr(1,1)
Endif
Endif
Endif
If nError <> 0
Messagebox("Nao foi possivel reparar o arquivo " + cArq, 48,"ATENÇÃO")
Sele (cArq)
Use
nError = 0
Else
Sele (cArq)
Use
Endif
Endif
NEXT
IF nReparos <> 0
Messagebox("Foram reparados "+TRANSFORM(nReparos)+" arquivos")
Endif
*
05-) Busca de cep
* Para uzar dll ChilkatXml.dll, copie a mesma para * C:\WINDOWS\system32 e *execute o seguinte comando no executar
regsvr32 C:\WINDOWS\system32\ChilkatXml.dll
IF FILE("C:WINDOWSsystem32ChilkatXml.dll") = .F.MessageBox('O arquivo necessário para utilizar esta rotina não foi encontrado!',48+0+0,'Atenção...')
RETURN
ENDIF
* LEITURA DO XML ATRAVES DE UM OBJETO CHILKAT
LOCAL LOXML, LNSUCCESS, LOXMLCEP, mURL, mRESULTADO
wcep1='02728-090' &&ou '02728090'IF EMPTY(wCEP1)MessageBox('PREENCHA O CEP',48+0+0,'Atenção...')
RETURN
ELSEmURL='http://cep.republicavirtual.com.br/web_cep.php?cep=' + ALLTRIM(STRTRAN(wCEP1,'-','')) + '&formato=xml'ENDIFmResultado=" "* OBJETO CHILKAT EXECUTA A LEITURA DO RETORNO DO WEBSERVICE EM XML
LOXML=CREATEOBJECT('Chilkat.Xml')LOXMLCEP=LOXML.HTTPGET(mURL)
IF ISNULL(LOXMLCEP) = .T.MessageBox('Não há conexão com Internet / Serviço não disponível.',48+0+0,'Atenção...')
ELSEmRESULTADO=LOXMLCEP.GETCHILDCONTENT("resultado")STORE " " TO wende,wbairo,wcidade,westaIF mRESULTADO = "1"wENDE =UPPER(LOXMLCEP.GETCHILDCONTENT("tipo_logradouro")+' '+ LOXMLCEP.GETCHILDCONTENT("logradouro"))wBAIRRO=UPPER(LOXMLCEP.GETCHILDCONTENT("bairro"))wCIDADE=UPPER(LOXMLCEP.GETCHILDCONTENT("cidade"))wESTA=UPPER(LOXMLCEP.GETCHILDCONTENT("uf"))WAIT WINDOW AT 10,43 wende+CHR(13)+wbairro+CHR(13)+wcidade+CHR(13)+westa TIMEOUT 3ENDIF
ENDIF
8-) Colacar uma Imagem Centralizada de fundo no Screen do seu Aplicativo
Autor :Julio membro do Blog
m.largura = SYSMETRIC(1)
m.altura = SYSMETRIC(2)
cCaminho = "C:\sistema\background\screen.jpg"
_SCREEN.ADDOBJECT("LOGO","Image")
_SCREEN.LOGO.PICTURE= cCaminho && alterei aqui
_SCREEN.LOGO.LEFT=0
_SCREEN.LOGO.TOP =0
_SCREEN.LOGO.BACKSTYLE = 0
_SCREEN.LOGO.STRETCH = 2
_SCREEN.LOGO.VISIBLE = .T.
_SCREEN.LOGO.WIDTH = m.largura && alterei aqui
_SCREEN.LOGO.HEIGHT =m.altura && alterei aqui
*na Procedure*
m.largura = SYSMETRIC(1)
m.altura = SYSMETRIC(2)
PUBLIC ohandler
ohandler=NEWOBJECT("myhandler")
BINDEVENT(_SCREEN,"Resize",ohandler,"myresize")
DEFINE CLASS myhandler AS SESSION
PROCEDURE myresize
_SCREEN.LOGO.WIDTH = m.largura && alterei aqui
_SCREEN.LOGO.HEIGHT =m.altura && alterei aqui
ENDPROC
ENDDEFINE
CLbusca=UPPER(INPUTBOX("Nome ", "A Pesquisar", "", 0, "", "FOICANCELADO"))
IF CLbusca = "FOICANCELADO"MESSAGEBOX("O botão do InputBox foi pressionado")
ENDIF
09-PISCAR LABEL - EFEITO BLINK
Coloque um objeto do tipo container em seu form com a propriedade BACKSTYLE = 0
Despeje um objeto LABEL e um TIMER no CONTAINER.
Defina a propriedade Interval do objeto TIMER para 300
(este valor você pode alterar conforme sua preferência) e inclua a linha abaixo ao método TIMER :
Código:
This.Parent.label1.Visible = ! This.Parent.label1.Visible
10-VERIFICAR INSCRIÇÃO ESTADUAL
Para verificar a consistência das Inscrições estaduais dos diversos estados, a Secretaria
da Receita disponibilizou uma DLL que faz a verificação com base no ESTADO
e no NUMERO DE I.E. fornecido.
Inicialmente, é preciso se fazer o download da DLL.
Para baixá-la, clique no link abaixo.
Baixar a Dll em http://www.sintegra.gov.br/DLL3.zip
Salve em qualquer pasta, de preferência em ..\WINDOWS\SYSTEM
Usá-la é bastante simples :
Primeiramente, é preciso "declarar" a DLL
Declare Integer ConsisteInscricaoEstadual In DllInscE32.DLL String, String
Crie um programa PROINSC.PRG ou adicione o código abaixo em seu arquivo de procedures:
* FUNCAO....: PROINSC()
* OBJETIVO..: Fazer checagem de INSCRIÇÃO ESTADUAL
* RETORNO...: .T. se for correto ou .F. se for errado
* PARÂMETROS: INSCRIÇÃO ESTADUAL (caracter)
* ESTADO (caracter)
FUNCTION PROINSC
Parameters IE, UF
** "limpar" a inscrição estadual para a verificação
IE = STRTRAN(IE,'.','')
IE = STRTRAN(IE,'-','')
IE = STRTRAN(IE,'/','')
IE = STRTRAN(IE,',','')
IE = STRTRAN(IE,'ME','')
IE = STRTRAN(IE,' ','')
IE = STRTRAN(IE,'P','')
IE = ALLTRIM(IE)
Return ConsisteInscricaoEstadual(IE, UF)=0
Para verificar o valor digitado pode-se colocar o código abaixo no VALID do Textbox.
IF NOT PROINSC(THIS.Value,This.Parent.CmbCli_Estado.Value)
= MESSAGEBOX('INSCRIÇÃO ESTADUAL INVÁLIDA !', 48, 'Atenção')
RETURN .F.
ENDIF
RETURN
***
13-validar cpf 13
13-cpf validar
FUNCTION validates_cpf &&13 segunda forma de validar cfp
LPARAMETERS number_cpf AS STRING
LOCAL validated AS logical
LOCAL nine_twelve_number AS STRING
LOCAL ten_twelve_number AS STRING
LOCAL multiplier AS INTEGER
LOCAL stored_value AS INTEGER
LOCAL rest_division AS INTEGER
m.validated = .F.
m.nine_twelve_number = SUBSTR(ALLTRIM(number_cpf), 1, 9)
m.multiplier = 9
m.stored_value = 0
TRY
IF (LEN(ALLTRIM(m.number_cpf)) == 11) THEN
FOR m.counter = LEN(m.nine_twelve_number) TO 1 STEP -1
m.stored_value = m.stored_value + ;
(VAL(SUBSTR(m.nine_twelve_number, m.counter, 1)) * m.multiplier)
m.multiplier = m.multiplier - 1
IF m.multiplier < 0 THEN
m.multiplier = 9
ENDIF
ENDFOR
m.rest_division = MOD(m.stored_value, 11)
IF (m.rest_division = 10) THEN
m.rest_division = 0
ENDIF
IF (m.rest_division = VAL(SUBSTR(ALLTRIM(number_cpf), 10, 1)))
m.multiplier = 9
m.stored_value = 0
m.ten_twelve_number = SUBSTR(ALLTRIM(number_cpf), 1, 10)
FOR m.counter = LEN(m.ten_twelve_number) TO 1 STEP -1
m.stored_value = m.stored_value + ;
(VAL(SUBSTR(m.ten_twelve_number, m.counter, 1)) * m.multiplier)
m.multiplier = m.multiplier - 1
IF m.multiplier < 0 THEN
m.multiplier = 9
ENDIF
ENDFOR
m.rest_division = MOD(m.stored_value, 11)
IF (m.rest_division = 10) THEN
m.rest_division = 0
ENDIF
IF (m.rest_division = VAL(SUBSTR(ALLTRIM(number_cpf), 11, 1)))
m.validated = .T.
ENDIF
ENDIF
ENDIF
CATCH TO oerr
LOCAL strerro AS STRING
m.strerro = ""
m.strerro = "" + m.strerro + "Date: " + DTOC(DATE()) + CHR(13) + CHR(10)
m.strerro = "" + m.strerro + "Hour: " + TIME() + CHR(13) + CHR(10)
m.strerro = "" + m.strerro + "Error: " + ALLTRIM(STR(m.oerr.ERRORNO)) + CHR(13) + CHR(10)
m.strerro = "" + m.strerro + "LineNo: " + ALLTRIM(STR(m.oerr.LINENO)) + CHR(13) + CHR(10)
m.strerro = "" + m.strerro + "Message: " + m.oerr.MESSAGE + CHR(13) + CHR(10)
m.strerro = "" + m.strerro + "Procedure: " + m.oerr.PROCEDURE + CHR(13) + CHR(10)
m.strerro = "" + m.strerro + "Details: " + m.oerr.DETAILS + CHR(13) + CHR(10)
m.strerro = "" + m.strerro + "StackLevel: " + ALLTRIM(STR(m.oerr.STACKLEVEL)) + CHR(13) + CHR(10)
m.strerro = "" + m.strerro + "LineContents: " + m.oerr.LINECONTENTS + CHR(13) + CHR(10) + CHR(13) + CHR(10)
STRTOFILE(m.strerro, SYS(5) + CURDIR() + "ErrosABT.log", 1)
MESSAGEBOX(m.strerro, 16, "ABTsistem")
ENDTRY
RETURN m.validated
ENDFUNC
*!* Quebra da string por delimitador "\"
#DEFINE _enter CHR(10)+CHR(13)
#DEFINE delimitador "\"
*!* Define o valor de entrada
LOCAL entrada AS STRING
m.entrada = "c:\ Pedidos\backup\tabelas\Resta.dbf"
FOR m.contador=1 TO GETWORDCOUNT(m.entrada,delimitador)
resp = GETWORDNUM(m.entrada,m.contador,delimitador)
ENDFOR
MESSAGEBOX(resp,48,'Nome da tabela',2900)
ou*
m.entrada = "c:\Vfoxpro\aplicacao\tabelas\teste.dbf"
messagebox( JUSTFNAME(m.entrada) ) && teste.dbf
***fim
*Criar um arquivo txt
a=FCREATE('c:\prfifod\Restas.txt')
FPUTS(a,'txtnomedaempresa')
FPUTS(a,'txtcgc')
FCLOSE(a)
*fin
VARIAVEL1 = FILETOSTR("Restas.txt")
*!* encripta dados
FUNCTION SCRIPTA(cDADO)
LOCAL cCRIP
MCOMP = LEN(cDADO)
FOR J = 1 TO MCOMP
IF J = 1
cCRIP = CHR(256-ASC(SUBSTR(cDADO,J,1)))
ELSE
cCRIP=cCRIP+CHR(256-ASC(SUBSTR(cDADO,J,1)))
ENDIF
NEXT
RETURN(cCRIP)
ENDFUNC
*!* Descripta dados
FUNCTION SDRIPTA(cDADO)
LOCAL cCRIP
MCOMP = LEN(cDADO)
FOR J = 1 TO MCOMP
IF J = 1
cCRIP = CHR(256-ASC(SUBSTR(cDADO,J,1)))
ELSE
cCRIP=cCRIP+CHR(256-ASC(SUBSTR(cDADO,J,1)))
ENDIF
NEXT
RETURN(cCRIP)
ENDFUNC
11-VERIFICAR CNPJ
FUNCTION proCNPJ
* Parametro : CNPJ a verificar (C14)
* Retorna : .T. se confirmado
PARAMETERS wcgc
wn1 = VAL(SUBS(wcgc,01,1))
wn2 = VAL(SUBS(wcgc,02,1))
wn3 = VAL(SUBS(wcgc,03,1))
wn4 = VAL(SUBS(wcgc,04,1))
wn5 = VAL(SUBS(wcgc,05,1))
wn6 = VAL(SUBS(wcgc,06,1))
wn7 = VAL(SUBS(wcgc,07,1))
wn8 = VAL(SUBS(wcgc,08,1))
wn9 = VAL(SUBS(wcgc,09,1))
wn10 = VAL(SUBS(wcgc,10,1))
wn11 = VAL(SUBS(wcgc,11,1))
wn12 = VAL(SUBS(wcgc,12,1))
wn13 = VAL(SUBS(wcgc,13,1))
wn14 = VAL(SUBS(wcgc,14,1))
* CALCULO DO 13o ALGARISMO
soma1 = wn1*5+wn2*4+wn3*3+wn4*2+wn5*9+wn6*8+wn7*7+wn8*6+wn9*5+wn10*4+wn11*3+wn12*2
dig1 = 11 - MOD(soma1,11)
IF dig1 = 10 .OR. dig1 = 11
dig1 = 0
ENDIF
IF dig1 <> wn13
RETURN .F.
ENDIF
* CALCULO DO 14o ALGARISMO
soma2 = wn1*6+wn2*5+wn3*4+wn4*3+wn5*2+wn6*9+wn7*8+wn8*7+wn9*6+wn10*5+wn11*4+wn12*3+
wn13*2
dig2 = 11 - MOD(soma2,11)
IF dig2 = 10 .OR. dig2 = 11
dig2 = 0
ENDIF
IF dig2 <> wn14
RETURN .F.
ENDIF
RETURN .T.
12-VERIFICAR CPF
FUNCTION proCPF
* Parametro : CPF a verificar (C11)
* Retorna : .T. se confirmado
PARAMETERS wcpf
wn1 = VAL(SUBS(wcpf,01,1))
wn2 = VAL(SUBS(wcpf,02,1))
wn3 = VAL(SUBS(wcpf,03,1))
wn4 = VAL(SUBS(wcpf,04,1))
wn5 = VAL(SUBS(wcpf,05,1))
wn6 = VAL(SUBS(wcpf,06,1))
wn7 = VAL(SUBS(wcpf,07,1))
wn8 = VAL(SUBS(wcpf,08,1))
wn9 = VAL(SUBS(wcpf,09,1))
wn10 = VAL(SUBS(wcpf,10,1))
wn11 = VAL(SUBS(wcpf,11,1))
* CALCULO DO 1o digito
* --------------------
soma1 = wn1*10+wn2*9+wn3*8+wn4*7+wn5*6+wn6*5+wn7*4+wn8*3+wn9*2
dig1 = 11 - MOD(soma1,11)
IF dig1 = 10 .OR. dig1 = 11
dig1 = 0
ENDIF
IF dig1 <> wn10
RETURN .F.
ENDIF
* CALCULO DO 2o digito
soma2 = wn1*11+wn2*10+wn3*9+wn4*8+wn5*7+wn6*6+wn7*5+wn8*4+wn9*3+wn10*2
dig2 = 11 - MOD(soma2,11)
IF dig2 = 10 .OR. dig2 = 11
dig2 = 0
ENDIF
IF dig2 <> wn11
RETURN .F.
ENDIF
RETURN .T.
ENDFUNC
*
13-SABER SE UMA VARIÁVEL EXISTE
Use a função TYPE() :
IF TYPE("Var")
=MessageBox("Variável Existe",0,"")
ENDIF
15-Importar e Exportar Arquivos
Crie um Botão ou Em qualquer metodo e coloque assim
Importar
append from nome_do_arquivo.xls ou txt type xls ou txt
16-Exportar
copy to nome_do_arquivo.xls ou txt type xls ou txt
18-A Resolucao de Video
_screen.AddObject("LOGO","Image")
_screen.LOGO.Picture="nome_da_imagem.png"
_screen.LOGO.left=(_Screen.width/2) - (_screen.LOGO.width/2)
_screen.LOGO.Top =(_Screen.Height/2) - (_screen.LOGO.Height/2)
_screen.LOGO.BackStyle = 0 && Transparente
_screen.LOGO.Visible = .T.
*Registrando Uma MOLEZIP.DLL
Close Databases
SET DEFAULT TO SYS(5)+CURDIR()
Set Safety Off
SET EXACT OFF
Create Table teste1( codigo c(10) , descricao c(40), preco N(10,2))
Select teste1
INDEX on codigo TAG codigo
For i = 1 To 15
Insert Into teste1 (codigo,descricao,preco) Values ( Alltrim(Str(i,6)), 'Produto '+Str(i), i)
NEXT
WAIT WINDOW 'Incio backup.zip Aguarde..... ' NOWAIT noclear
**Registra DLL MOLEZIP.DLL
DECLARE LONG DllRegisterServer IN molezip.dll
IF DllRegisterServer() = 0
WAIT WINDOW 'molezip. dll REGISTRADO !!!' TIMEOUT 0.3
ELSE
messagebox('NÃO REGISTRADO !!!')
RETURN .f.
ENDIF
gcDirBackup = SYS(5)+CURDIR()
SET defa TO SYS(5)+CURDIR()
Close Table All
Close Database All
Local cArquivo, x
Versao1='V10171012'
cArquivo = 'Backup'
cArquivo = AllTrim(gcDirBackup)+cArquivo
cArquivo = AllTrim(cArquivo) + '.Zip'
oZip = CreateObject("molezip.zipfile")
oZip.Create(cArquivo)
?? chr(7)
*Aqui adiciono todos os dbf ao arquivo criado pelo molezip chamado oZip
nArquivos = Adir(aArquivos,"*.DBF" ) && *.dbf
For x = 1 To nArquivos
Inkey(0.01,'H')
oZip.PackInplace(aArquivos(x,1),aArquivos(x,1),1)
EndFor
nArquivos = Adir(aArquivos,'*.CDX') && *.CDX
For x = 1 To nArquivos
Inkey(0.01,'H')
oZip.PackInplace(aArquivos(x,1),aArquivos(x,1),1)
EndFor
nArquivos = Adir(aArquivos,'TESTE.BAK')
For x = 1 To nArquivos
Inkey(0.01,'H')
oZip.PackInplace(aArquivos(x,1),aArquivos(x,1),1)
ENDFOR
OZip.Close
WAIT WINDOW 'fim do backup' TIMEOUT 0.7
WAIT clear
Link da dll molezip.zip
19-Como saber SE 1 OBJETO TEM OU NÃO UMA PROPRIEDADE / MÉTODO
* se existe o método Release, executa
IF pemstatus(Thisform, 'RELEASE',5)
Thisform.Release
ENDIF
20-NÃO Deuxe ke Seu EXECUTÁVEL RODE SIMULTANEAMENTE Na MESMA ESTAÇÃO
Normalmente, não queremos que um executável seja executado ao mesmo tempo mais de uma vez. Existem vária técnicas para isso, aí vai uma delas.
Modo de uso :
Coloque no programa inicial do seu sistema nas primeiras linhas:
Código:
IF NOT validar_sistema()
QUIT
ENDIF
Salve como validar_sistema.PRG ou inclua em seu arquivo de procedures
Código:
FUNCTION validar_sistema
LOCAL lcOldCaption
lcOldCaption = _screen.Caption
_screen.Caption = SYS(3)
LOCAL lnhwnd
DECLARE INTEGER FindWindow IN Win32API STRING lpClassName, STRING lpWindowName
DECLARE INTEGER BringWindowToTop IN Win32API INTEGER HWND
DECLARE INTEGER SendMessage IN Win32API INTEGER HWND, INTEGER Msg, INTEGER WParam, INTEGER LPARAM
lnhwnd = findwindow( 0, lcOldCaption)
_screen.Caption = lcOldCaption
IF lnhwnd > 0
bringwindowtotop(lnhwnd) && Mandar la ventana de la aplicación al frente
sendmessage(lnhwnd, 274, 61488, 0) && Maximizar la ventana de la aplicación
RETURN .F.
ENDIF
RETURN .T.
***
Ou
Local lnWinHandle
Declare Integer FindWindow In Win32API Integer, String
lnWinHandle = FindWindow( 0, 'Nome da Tela do seu programa' )
If lnWinHandle # 0
=Messagebox( "O aplicativo já está sendo executado!",16,'Nome da Tela do seu programa' )
clear events
QUIT
Endif
21-REMOVER UMA ABA DE UM PAGEFRAME
*-- Esconder a 2a pagina do PageFrame
thisform.PageFrame1.RemoveObject("Page2")
22-SABER SE UMA PASTA EXISTE
1 exemplo cria uma pasta no sistema caso não exista uma com o nome desejado.
IF NOT DIRECTORY('c:\TEMP\')
MKDIR ('c:\TEMP\')
ELSE
WAIT WINDOW 'PASTA JA EXISTE' TIMEOUT 1
ENDIF
23-COMO FECHAR TODOS OS FORMS
FOR i = 1 TO _Screen.formCount
_Screen.forms(i).release
ENDFOR
ou então
Código:
LOCAL loForm
FOR EACH loForm IN _SCREEN.FORM
loForm.RELEASE()
NEXT
***
DEFINIR PROPRIEDADES DE VÁRIOS OBJETOS DE uma SÓ VEZ
FOR EACH Objeto in Thisform.ObjectsIf Objeto.BaseClass=="Label" Then
Objeto.Left=Objeto.Left+10EndifNEXT
******
24-OBTER O IP LOCAL DA MÁQUINA
oSocket = CreateObject("MSWinsock.Winsock")
? oSocket.LocalIP
******ou
Veja tambem o comando SYS(0)
ELE traz o nome da maquina e o usuario logado
*ou
Public usuario
declare integer GetUserName in advapi32 String@, Integer@ && identifica usuario logado no computador
lcnomeusuario = replicate(chr(0),255)
lres = getusername(@lcnomeusuario,255)
if lres # 0 then
usuario = left(lcnomeusuario,at(chr(0),lcnomeusuario)-1)
***aqui o seu textbox de usuario
* thisform.text1.value = left(lcnomeusuario,at(chr(0),lcnomeusuario)-1)
endif
wait windo usuario timeout 3
24-A abri
oShell = Createobject("Shell.Application")
oShell.Open('C:\arquiv~1\TeamViewer\Version7\teamViewer.exe ')
WAIT WINDOW 'aguarde ' TIMEOUT 3
26A-Label na screen
ON SHUTDOWN QUIT
ON KEY LABEL F2 QUIT
_SCREEN.WindowState = 2
_SCREEN.BackColor = RGB(255,255,255)
_SCREEN.Caption='TESTE DE SISTEMA F2 SAIR '
_screen.AddObject("lblTeste","label")
_screen.lblTeste.top = 280
_screen.lblTeste.left = 80
_screen.lblTeste.AutoSize = .t.
_screen.lblTeste.caption = "Site http://teste.com/ TEL.nome-11-99999986"
_screen.lblTeste.Visible = .T.
_screen.lblTeste.BackStyle = 0
_screen.lblTeste.fontbold = .t.
_screen.lbLTESTE.FontSize = 8
_screen.lbLTESTE.forecolor =rgb(0,0,255)
26-CRIAR UM EXECUTÁVEL RAPIDAMENTE A PARTIR DE UM PRG
BUILD PROJECT TempProj FROM myprg
BUILD EXE myexe FROM TempProj
ERASE TempProj.pj?
27-FINALIZAR TODAS AS TRANSAÇÕES ABERTAS
Eventualmente, em situações de erro no programa, precisamos finalizar todas as transações abertas.
Código:
DO WHILE TXNLEVEL() > 0
ROLLBACK
ENDDO
28-MOVER O CURSOR PARA O INICIO DO TEXTBOX
Eventualmente alguém pede para que o cursor vá automaticamente para o início do texto qdo um TEXTBOX é clicado.
No evento CLICK do Textbox, basta colocar :
Código:
This.SelStart = 0
****
29-Data invalida metodo lostfocus
Validação de campo pelo metodo lostfocus.
IF EMPTY(CTOD(THIS.VALUE)) THEN
MESSAGEBOX("Data Inválida!")
NODEFAULT
ENDIF
ou pelo Metodo valid
Para validar 1 data no método VALID de um TEXTBOX:
IF EMPTY(CTOD(THIS.VALUE)) THEN
= MESSAGEBOX("Data Inválida!")
RETURN 0
ENDIF
29A-DESABILITAR A CAIXA DE TEXTO DE UM SPINNER
no Evento KEYPRESS, coloque :
Código:
NODEFAULT
30-SABER SE PROGRAMA ESTA SENDO EXECUTADO A PARTIR DO EXE OU NO PROJETO
IF VERSION(2) = 0 && RunTime
MESSAGEBOX("EXECUTÁVEL")
ELSE
MESSAGEBOX("DESENVOLVIMENTO")
ENDIF
31-SINCRONIZAR HORARIO COM O SERVIDOR
Há várias maneiras de se fazer isso, aí vai uma delas:
SET MEMOWIDTH TO 126
tcserver = "\\ServidorNt"
_cTextBat = GETENV("TEMP")+"\"+SUBSTR(SYS(2015), 3, 8)+".bat"
_cTextShell = "NET TIME "+tcserver+" /SET /Y"
STRTOFILE(_cTextShell, _cTextBat)
DECLARE LONG WinExec;
IN KERNEL32;
STRING lpCmdLine, LONG nCmdShow
winexec(_cTextBat, 0)
=INKEY(.2, "H")
32-CONTROLAR SAÍDA DO BROWSE
Algumas pessoas ainda não estão totalmente acostumadas ao uso de Grids, então vai uma dica antiga, para se fechar a tela do BROWSE com a tecla ENTER:
ON KEY LABEL ENTER KEYBOARD '{CTRL+W}'
USE suaTabela
BROWSE
ON KEY LABEL ENTER
Outro modo interessante, agora usando a função SYS(18), que retorna o campo em que se estava:
Código:
ON KEY LABEL ENTER do teste
USE clientes
BROWSE
ON KEY LABEL ENTER
RETURN
PROCEDURE teste
MESSAGEBOX("Campo selecionado :" + SYS(18))
KEYBOARD '{CTRL+W}'
ENDPROC
32-CONTROLAR SAÍDA DO BROWSE
Algumas pessoas ainda não estão totalmente acostumadas ao uso de Grids, então vai uma dica antiga, para se fechar a tela do BROWSE com a tecla ENTER:
ON KEY LABEL ENTER KEYBOARD '{CTRL+W}'
USE suaTabela
BROWSE
ON KEY LABEL ENTER
Outro modo interessante, agora usando a função SYS(18), que retorna o campo em que se estava:
Código:
ON KEY LABEL ENTER do teste
USE clientes
BROWSE
ON KEY LABEL ENTER
RETURN
PROCEDURE teste
MESSAGEBOX("Campo selecionado :" + SYS(18))
KEYBOARD '{CTRL+W}'
ENDPROC
33-CONFIRMAÇÃO ANTES DE FECHAR O FORM
O evento QueryUnload é disparado ao se clicar no "X" para fechar um form. Para se evitar que
ele seja fechado, basta se colocar NODEFAULT, que o Form volta à execução normal.
Para testar, coloque no evento QueryUnload do seu form :
Código:
IF MESSAGEBOX("Deseja encerrar ?",32+4,"Unload") <> 6 && Sim
NODEFAULT
ENDIF
35-IMPRIMIR ARQUIVO DIRETAMETE NA IMPRESSORA
DECLARE INTEGER ShellExecute IN SHELL32.DLL;
INTEGER nWinHandle,;
STRING cOperation,;
STRING cFileName,;
STRING cParameters,;
STRING cDirectory,;
INTEGER nShowWindow
ShellExecute(0, 'print', [MeuArquivo.xxx], '', '', 1)
Gerando txt
Close Databases
Set Safety Off
Create Table tabela( codigo c(10) , descricao c(40), preco N(10,2))
Select tabela && ** Gerando 1 TABELA com 15 registros.....
For i = 1 To 15
Insert Into tabela (codigo,descricao,preco) Values ( Alltrim(Str(i,6)), "Produto "+Str(i), i)
NEXT
BROWSE LAST NORMAL nodelete &&**MOSTRANDO OS DADOS
nomearq="Dados.txt"
arquivo = Fcreate(nomearq)
Select Tabela
Scan
conteudo = alltrim(tabela.codigo)+alltrim(tabela.descricao)
Fwrite(arquivo,conteudo+chr(13)+Chr(10))
Endscan
Fclose(arquivo)
RELEASE arquivo
CLOSE DATABASES
CLOSE all
MODIFY COMMAND dados.txt
ou
Close Tables AllIf Not Used('eventos')
Use eventos In 0 Alias eventos SharedEndifSelect eventos
Set Console Off
Set Notify Off
Set Safety Off
Set Alternate To testi.txt
Set Alternate On
gn=Fcount()
? 'Número de campos: ' + Alltrim(Str(gn -1))gnFieldcount = Afields(My) && Cria matrizFor N = 1 To gnFieldcount? My(N,1)+' - '+My(N,2)+ ' '+Str(My(N,3))+ ', '+Alltrim(Str(My(N,4)))Select eventosEndfor
?Scan? Alltrim(Str(codigo))+'|'+Alltrim(transport)+'|'+Alltrim(endereco)+Alltrim(endereco)Endscan?Set Alternate To
Set Alternate Off
Set Console On
Modify Command testi.txt
38-b) APAGAR REGISTROS DUPLICADOS
CLEAR ALL
LOCAL wo
c = 0
d = 0
CLOSE DATABASES ALL
**TABELA IBGE CIDADE E UF
USE IBGE IN 0 ALIAS R1
SELECT R1
INDEX ON CIDADE to TEMP
GO TOP IN R1
DO WHILE ( Not Eof( "R1" ) )
wo= R1.CIDADE+R1.UF
SKIP IN R1
DO WHILE ( R1.CIDADE+R1.UF = wo And Not Eof( "R1" ) )
DELETE IN R1
c = c + 1
@05,10 say 'Registros Duplicados Apagados '+ str(c)
SKIP IN R1
ENDDO
d = d+1
@10,10 say 'Registros Lidos '+ str(d)
ENDDO
BROWSE NORMAL LAST
39-) Tira ascento
FUNCTION TiraAcento(tcStringInput)
*1) Indexe tirando o acento do campo. Ex.: TiraAcento(nm_empresa)
*2) Procure tirando, também, o acento da chave de pesquisa. Ex.: SEEK
*TiraAcento(lcNomedaEmpresa)
LOCAL lcStringFilterIn, lcStringFilterOut, lcStringOutput
lcStringFilterIn = "ÁÉÍÓÚáéíóúÀÈÌÒÙàèìòùÂÊÎÔÛâêîôûÄËÏÖÜäëïöüÃÕãõÇçÑñº"
lcStringFilterOut = "AEIOUaeiouAEIOUaeiouAEIOUaeiouAEIOUaeiouAOaoCcNno"
lcStringOutput = CHRTRAN(tcStringInput, lcStringFilterIn, lcStringFilterOut)
RETURN (lcStringOutput)
ENDFUNC
**
ou
LOCAL WFilterIn, WFilterOut, lcStringOut
CLOSE DATABASES
USE cepbrasil IN 0
SELECT cepbrasil
GO top
wende=ALLTRIM(cepbrasil.cidade)
DO WHILE !EOF()
WFilterIn = "ÁÉÍÓÚáéíóúÀÈÌÒÙàèìòùÂÊÎÔÛâêîôûÄËÏÖÜäëïöüÃÕãõÇçÑñº"
WFilterOut = "AEIOUaeiouAEIOUaeiouAEIOUaeiouAEIOUaeiouAOaoCcNno"
lcStringOut = CHRTRAN(WENDE, WFilterIn, WFilterOut)
replace cidade with UPPER(ALLTRIM(lcStringOut) )
lcStringOut =''
SKIP IN cepbrasil
wende=ALLTRIM(cepbrasil.cidade)
IF EOF()
EXIT
ENDIF
ENDDO
GO TOP
BROWSE LAST normal
**
ou
Close Databases
Select 0
Use cep_bras
Go Top
wcidade=cep_bras.cidade
Do While Not Eof()
cProcurarPor = "ÁÉÍÓÚáéíóúÀÈÌÒÙàèìòùÂÊÎÔÛâêîôûÄËÏÖÜäëïöüÃÕãõÇçÑñº"
cSubstituirPor = "AEIOUaeiouAEIOUaeiouAEIOUaeiouAEIOUaeiouAOaoCcNno"
wcidade = Chrtran(wcidade,cProcurarPor,cSubstituirPor)
Replace cidade With wcidade
Skip
wcidade=''
wcidade=cep_bras.cidade
If Eof()
Wait Window 'fim' Timeout 0.5
Exit
Endif
Enddo
Go Top
Browse last normal
39=) Converter numero em caracter sem perder o valor
wr=43170557096
y=Ferrari(wr)
WAIT WINDOW AT 25,35 y +1 TIMEOUT 2
FUNCTION Ferrari
parameters onumero
alltrim(str(onumero,100))
return(onumero)
***Funciton nomedela
Parameters nomeretorno
...Seu codigo
Return(nomeRetorno)
Endfunc
***Um exemplo
CLEAR
store 0 to A,B,C
DO PROCEDURE1 WITH A,B,C
? A+B+C
PROCEDURE PROCEDURE1
PARAMETERS A,B,C
A=90
B=90
C=90
41-a) Tabela corrompida
SET TABLEVALIDATE TO 0
USE tabela_corrompida EXCLUSIVE
COPY STRUCTURE TO manu_bk
USE manu_bk
APPEND FROM tabela_corrompida
USE IN manu_bk
USE tabela_corrompida EXCLUSIVE
ZAP
REINDEX COMPACT
APPEND FROM manu_bk
USE IN tabela_corrompida
***
Public oForm1
oForm1=newobject('Form1')
oForm1.show
return
define class Form1 as form
top = 0
left = 0
height = 177
width = 469
docreate = .T.
borderstyle = 2
caption = 'Teste '
windowtype = 1
name = 'FrmTeste'
add object Label0 as label with caption = 'codigo', height = 23, ;
left = 94, top = 56, width = 100, name = 'Label0'
add object TextBox1 as textbox with alignment = 1 , value = 0 , ;
height = 23, left = 233, top = 48, width = 100, name = 'TextBox1'
add object sair10 as commandbutton with top = 57, left = 339, ;
height = 23, width = 75, caption = 'Sair', name= 'Sair10'
PROCEDURE sair10.click()
IF 6=MESSAGEBOX("SAIR",+4+32,"QUER" )
close databases
THISFORM.RELEASE
ENDIF
endproc
Enddefine
42-) Impressora On line na rede
SET CONSOLE OFF
SET NOTIFY off
SET SAFETY OFF
APRINTERS(gaprinters, 1)CREATE CURSOR imprs (caminho c(50), porta c(50), nomeimp c(50), COMMEN c(50))INSERT INTO imprs FROM ARRAY gaprinters
SELECT imprs
GO TOP*aqui o browse e so pra voce ver depos exluir alinha browse
BROWSE NORMAL NODELETE TITLE ' Sair'Declare Integer GetDefaultPrinter In winspool.drv String @pszBuffer, Integer @pcchBuffer
nBufsize = 250
cPrinter = Replicate(Chr(0), nBufsize)
= GetDefaultPrinter(@cPrinter, @nBufsize)cPrinter = Substr(cPrinter, 1, At(Chr(0),cPrinter)-1)Select imprs.nomeimp From imprs Where imprs.caminho = Alltrim(cPrinter) Into Cursor impbusca
Select impbuscaPublic impdefaut
impdefault = impbusca.nomeimp
MESSAGEBOX('a impressora padrao é:'+CHR(13)+impdefault,48,'aviso')
** primeira opcao
SET PRINTER TO NAME GETPRINTER()
**ou nomeservidornome da impressora
SET PRINTER TO NAME &impdefault
REPORT FORM nomedoseureport TO PRINTER console
**
**eject
l=0
SET CONSOLE OFF
SET ALTERNATE TO C:\temp\temp.txt
SET ALTERNATE ON
SET PRINTER TO &impressora
SET DEVICE TO PRINTER
SET PRINTER FONT 'DRAFT 10cpi',10
???CHR(27)+"C"+CHR(32)
@ l,1 say campo
l=l+2
@ l,1 say " "
EJECT
SET ALTERNATE OFF
SET ALTERNATE TO
SET PRINTER TO
SET DEVICE TO SCREEN
SET CONSOLE ON
***
sobre array
Para você criar um array:
Código:
DIMENSION LNEmpr[1]
Agora o array pode ser redimensionada ou criada após o seu SELECT
Código:
SELECT.....o seu código
DIMENSION LNEmpr[RECCOUNT()]
Use o comando FOR para o preenchimento da mesma.
Código:
FOR lnX = 1 to RECCOUNT()
LNEmpr[lnX]
NEXT
Código:
DIMENSION laTeste[1]
laTeste[1] = "Ops."
MESSAGEBOX(laTeste[1])
DIMENSION laTeste[4]
MESSAGEBOX(laTeste[1])
***
39-) exportar dbf para xls
CLOSE DATABASES all
SET SAFETY OFF
CREATE TABLE produto ( codigo n(6), grupo n(3), subgrupo n(3), descr c(30), preco n(10,2))
n=1
wdes='Produto '
FOR I = 1 TO 10
INSERT INTO produto values(n,n,n,wdes+STR(n),n)
n=n+1
NEXT
SELECT produto
copy to nomearq type xls
***ou
copy to nomearq2 type xl5
DECLARE INTEGER ShellExecute IN SHELL32.DLL INTEGER, STRING CDIR, STRING CFILE, ;
STRING , STRING, INTEGER
cArqDoc=getfile('xls','Selecione o arquivo','SelecionE')
If File(cArqDoc)
*p/ imprimr arq. "print" no lugar do Open,p/imprimir direto
*O Open serve para abrir o doc
ShellExecute(0, "Open", cArqDoc,"", Fullpath(""),0)
Else
Wait Window ' O arquivo nao esta na pasta!! ' Timeout 2
Endif
****
*ou simplesmente
use suatabela
copy to nomearq type xls
ou
copy to nomearq type xl5
**O processo inverso importar xls para um tabela ou cursor
CLOSE DATABASES all
*Então você cria 1 cursor temporario correspondente a tabela, por exemplo,
CREATE TABLE cursorprod ( codigo n(6), grupo n(3), subgrupo n(3), descr c(30), preco n(10,2))
*Agora para puxar os dados do arquivo XLS para dentro desta tabela temporária que criamos:
sele cursorProd
append from nomearq.xls TYPE XLS && xl5 para o nomearq2
BROWSE**
Baixe o arquivo com os fontes
***
Agora codigo para pegar memo no arquivo e transforma em Excel
******
Create Cursor test (mField m)
m.mField = '1234567' + Chr(13) + 'Erik Gomez' + Chr(13)+;
'Memo to Excel'
Insert Into test From Memvar
lnLine = Alines(laMemo,test.mField,.T.)
loExcel = Createobject('Excel.Application')
loWrkBk = loExcel.Workbooks.Add
loWrkSheet = loWrkBk.Worksheets(1)
For lnX = 1 To lnLine
lcCell = 'A' + Alltrim(Str(lnX))
loWrkSheet.Range(lcCell) = laMemo[lnX]
Next
loWrkBk.SaveAs('c:\PEDRO\MOTO\test.xls')
loWrkBk.Close
loExcel.Quit
loWrkSheet = .Null.
loWrkBk = .Null.
loExcel = .Null.fonte
http://www.foxite.com/archives/can-i-export-memo-fields-content-to-excel-0000021258.htm
ou
CLOSE DATABASES all
SET SAFETY OFF && Gero o Cursor TEst e insero 10 registros
Create Cursor test (registro c(4), desenho c(4), nomes c(15),mField m)
m.mField = '1234567' + Chr(13) + 'Erik Gomez' + Chr(13)+'Memo to Excel'
FOR i = 1 TO 10
Insert Into test values(STR(i,4),STR(i,4),'Firma '+STR(i,4), m.mField)
NEXT
SELECT registro, desenho,Nomes, Left(ALLTRIM(mfield),120) as OBS FROM test INTO CURSOR auxcli
*Path \pedro\moto mude para o seu path
copy to c:\pedro\moto\infocli.xls type xl5
***aqui vou abrir o excel para pegar sua planilha, infocli.xls
DECLARE INTEGER ShellExecute IN SHELL32.DLL INTEGER, STRING CDIR, STRING CFILE, ;
STRING , STRING, INTEGER
cArqDoc=getfile('xls','Escolha Xls','Selecione')
If File(cArqDoc)
*p/ imprimr arq. "print" no lugar do open,p/imprimir direto
ShellExecute(0, "Open", cArqDoc,"", Fullpath(""),0)
Else
Wait Window ' O arquivo nao esta na pasta!! ' Timeout 2
Endif
**
ou
CLOSE DATABASES all
SET SAFETY OFF && Gero o Cursor TEst e insero 10 registros
Create Cursor test (registro c(4), desenho c(4), nomes c(15),mField m)
m.mField = '1234567' + Chr(13) + 'Erik Gomez' + Chr(13)+'Memo to Excel'
FOR i = 1 TO 10
Insert Into test values(STR(i,4),STR(i,4),'Firma '+STR(i,4), m.mField)
NEXT
SELECT registro,desenho,Nomes, Left(RTRIM(mfield),120) as OBS FROM test INTO CURSOR auxcli
*** BROWSE normal && Gerei o cursor auxcli ,,,,,,para pegar obs.
m.contador=1
WAIT WINDOW 'Gerando Planilha e Abrindo o Exce l' NOWAIT
tmpsheet = GETOBJECT('','excel.sheet')
xlapp = tmpsheet.APPLICATION
xlapp.VISIBLE = .T.
xlapp.workbooks.ADD()
xlsheet = xlapp.activesheet
***nome das celulas
xlsheet.cells(1,1).VALUE = "Registro"
xlsheet.cells(1,2).VALUE = "Desenho"
xlsheet.cells(1,3).VALUE = "Clientes"
xlsheet.cells(1,4).VALUE = "OBS"
SCAN
xlsheet.cells(M.contador+1,1).VALUE=auxcli.registro
xlsheet.cells(M.contador+1,2).VALUE=auxcli.desenho
xlsheet.cells(M.contador+1,3).VALUE=auxcli.nomes
xlsheet.cells(M.contador+1,4).VALUE=auxcli.obs
m.contador=M.contador+1
ENDSCAN
WAIT WINDOW 'Veja a Barra de Tarefas Windows Excel aberto ' TIMEOUT 2
WAIT CLEAR
codigo COM INSTRUCAO Select
Esse exemplo seleciona os campos "Sobrenome" e "Nome" de todos os registros da tabela "Funcionários".
SELECT Sobrenome, Nome FROM Funcionários
Esse exemplo seleciona todos os campos da tabela "Funcionários".
SELECT Funcionários.* FROM Funcionários;
Esse exemplo conta o número de registros que têm uma entrada no campo "CódigoPostal" e nomeia o campo retornado como "Tcp".
SELECT Count(CódigoPostal) AS Tcp FROM Clientes;
Esse exemplo mostra qual seria o salário se cada funcionário recebesse um aumento de 10 porcento. Não altera o valor original dos salários.
SELECT Sobrenome, Salário AS Atual, Salário * 1.1 AS Proposto FROM Funcionários;
Esse exemplo coloca o título Nome no topo da coluna "Sobrenome". O título Salário é exibido no topo da coluna "Salário".
SELECT Sobrenome AS Nome, Salário FROM Funcionários;
Esse exemplo mostra o número de funcionários e os salários médio e máximo.
SELECT Count(*) AS [Total de Funcionários], Avg(Salário) AS [Salário Médio], Max(Salário) AS [Salário Máximo] FROM Funcionários;
Para cada registro, mostra Sobrenome e Salário no primeiro e último campos. A seqüência de caracteres "tem um salário de" é retornada como o campo do meio de cada registro.
SELECT Sobrenome, 'tem um salário de', Salário FROM Funcionários;
Exemplo de cláusula GROUP BY
SELECT cliente, SUM(pe_valor) as soma FROM receber GROUP BY receber.cliente ORDER BY cliente INTO CURSOR teste
e com soma com data e cliente ficaria
SELECT pe_data, cliente, SUM(pe_valor) as soma FROM receber GROUP BY receber.cliente,pe_data ORDER BY cliente,pe_data INTO CURSOR teste
Esse exemplo cria uma lista de nomes de departamentos únicos e o número de funcionários em cada um destes departamentos.
SELECT Departamento, Count([Departamento]) AS Tbc FROM Funcionários
GROUP BY Departamento;
SELECT Country, AVG(Inv_Total)
FROM Invoices GROUP BY Country
Para cada título de função único, calcula o número de funcionários do departamento de Vendas que têm este título.
SELECT Título, Count(Título) AS Tbc FROM Funcionários
WHERE Departamento = 'Vendas' GROUP BY Título;
Esse exemplo calcula o número de itens em estoque para cada combinação de número e cor do item.
SELECT Item, Sum(Unidades) AS Tbc FROM ItensEmEstoque
GROUP BY Item, Cor;
Exemplo de cláusula HAVING
Esse exemplo seleciona os títulos de cargos do departamento de Produção atribuídos a mais de 50 funcionários.
SELECT Título, Count(Título) FROM Funcionários WHERE Departamento = 'Produção'
GROUP BY Título HAVING Count(Título) > 50;
Esse exemplo seleciona os departamentos que tenham mais de 100 funcionários.
SELECT Departamento, Count([Departamento]) FROM Funcionários
GROUP BY Departamento HAVING Count(Departamento) > 100;
Exemplo de cláusula ORDER BY
As instruções SQL mostradas abaixo usam a cláusula ORDER BY para classificar os registros em ordem alfabética e depois por categoria.
Esse exemplo ordena os registros pelo sobrenome, em ordem descendente (Z-A).
SELECT Sobrenome, Nome FROM Funcionários ORDER BY Sobrenome DESC;
Esse exemplo ordena, primeiro, por categoria ID e depois por nome do produto.
SELECT CategoriaID, ProdutoNome, PreçoUnit FROM Produtos
ORDER BY CategoriaID, NomeProduto;
INSERT INTO destino [IN bancodedadosexterno] [(campo1[, campo2[, ...]])]
SELECT [origem.]campo1[, campo2[, ...]
FROM expressãodetabela
Consulta anexação de um único registro:
INSERT INTO destino [(campo1[, campo2[, ...]])]
VALUES (valor1[, valor2[, ...])
A instrução INSERT INTO tem as partes abaixo:
Parte Descrição
destino O nome da tabela ou consulta em que os registros devem ser anexados.
bancodedadosexterno O caminho para um banco de dados externo. Para uma descrição do
caminho, consulte a cláusula IN.
origem O nome da tabela ou consulta de onde os dados devem ser copiados.
campo1, campo2 Os nomes dos campos aos quais os dados devem ser anexados, se
estiverem após um argumento destino ou os nomes dos campos dos quais
se deve obter os dados, se estiverem após um argumento origem.
expressãodetabela O nome da tabela ou tabelas das quais registros são inseridos. Este
argumento pode ser um único nome de tabela ou uma combinação
resultante de uma operação INNER JOIN, LEFT JOIN ou RIGHT JOIN
Select cod,hr_inicio, hr_final,ctg_cod,ctg_data From Horas, Cadctpg WHERE cod=ctg_cod INTO CURSOR testar
ou de uma consulta gravada.
valor1, valor2 Os valores para inserir em campos específicos do novo registro. Cada valor
é inserido no campo que corresponde à posição do valor na lista: Valor1 é
inserido no campo1 do novo registro, valor2 no campo2 e assim por
diante. Você deve separar os valores com uma vírgula e colocar os
campos de textos entre aspas (" ").
Declaração UPDATE
Cria uma consulta atualização que altera os valores dos campos em uma tabela especificada com base em critérios específicos.
Sintaxe
UPDATE tabela
SET valornovo
WHERE critério;
A instrução UPDATE tem as partes abaixo:
Parte Descrição
tabela O nome da tabela cujos os dados você quer modificar.
valornovo Uma expressão que determina o valor a ser inserido em um campo específico nos
registros atualizados.
critério Uma expressão que determina quais registros devem ser atualizados. Só os registros
que satisfazem a expressão são atualizados.
Comentários
UPDATE é especialmente útil quando você quer alterar registros ou quando os registros que você quer alterar estão em várias tabelas. Você pode alterar vários campos ao mesmo tempo. O exemplo abaixo aumenta o Valor do Pedido em 10 por cento e o valor do Frete em 3 por cento para embarques do Reino Unido:
UPDATE Pedidos SET ValorPedido = ValorPedido * 1.1, Frete = Frete * 1.03
WHERE PaísEmbarque = 'RU';
UPDATE não gera um conjunto de resultados. Se você quiser saber quais resultados serão alterados, examine primeiro os resultados da consulta seleção que use os mesmos critérios e então execute a consulta atualização.
Exemplo de instrução UPDATE
Esse exemplo muda os valores no campo "RelatórioPara" para 5 para todos os registros de funcionários que atualmente têm valores de RelatórioPara de 2.
UPDATE Funcionários SET RelatórioPara = 5 WHERE RelatórioPara = 2;
Esse exemplo aumenta o "PreçoUnit" de todos os produtos não suspensos do fornecedor 8 em 10 porcento.
UPDATE Produtos SET PreçoUnit = PreçoUnit * 1.1
WHERE FornecedorID = 8 AND Suspenso = No;
Amarzenando todos os dados de uma tabela num cursor, para leitura:
Código:SELECT * FROM nomeTabela INTO CURSOR nomeCursor
- Amarzenando todos os dados de uma tabela num cursor, para escrita:
Código:SELECT * FROM nomeTabela INTO CURSOR nomeCursor READWRITE
- Amarzenando alguns os dados de uma tabela num cursor, para leitura:
Código:SELECT campo1, campo2, campo3 FROM nomeTabela INTO CURSOR nomeCursor
- Amarzenando alguns os dados de uma tabela num cursor, para escrita:
Código:SELECT campo1, campo2, campo3 FROM nomeTabela INTO CURSOR nomeCursor READWRITE- No caso de tabelas grandes, podemos utilizar TOP para definir a quantidade de registro que queremos trabalhar. Exemplo com 100 registros:
Código:SELECT TOP 100 campo1, campo2 FROM nomeTabela
Busca entre as duas tabelas, o campo RE que tem uma tabela, e que não tem na outra
sele a.re,a.nome from cadfunc a where a.re not in (select b.re from cadvt b)
Select RE from TABELA1 where RE not in (select RE from TABELA2) ****CodigoClose Databases
Set Safety Off
Create Table teste1( codigo c(10) , descricao c(40), preco N(10,2))
wcod =1
wdesc ='Produto '
valor =1
Select teste1
*** Gerando 1 arquivo com 15000 registros.....
For i = 1 To 15000
Insert Into teste1 (codigo,descricao,preco) Values ( Alltrim(Str(wcod,6)), wdesc+Str(wcod), valor)
wcod=wcod+1
valor=valor+1
Next
Use In teste1 && fechei o arquivo
*******
Create Table propdv( codpro c(10) , despro c(40), prepro N(10,2))
** Inserindo 15 mil registro de uma vez, so no arq. Propdv
Insert into propdv (codpro, despro, prepro) select codigo, descricao, preco FROM teste1
BROWSE normal
USE IN teste1
**Fazendo agora de outra forma com o comando scan se o registro for maior ke 14500
Create Table propdv( codpro c(10) , despro c(40), prepro N(10,2))
Sele 1
Use teste1
Go Top
If Not Eof()
Scan
Store codigo To cod
Store descricao To des
Store preco To pre
IF RECNO() >=14500
Insert Into propdv (codpro,despro,prepro) Values (cod,des,pre)
endif
ENDSCAN
Else
Wait Window 'nao tem registros para esta operacao' Timeout 1
Endif
Select propdv
BROWSE normal
USE IN propdv**Configuracao do seu video 800x 600 no vfp
veja como configurar no pRG .PRG PRINCIPAL NO seu projeto na aba code
no seu programa start na aba code do seu prrojeto
apos esta linha
codigo
***
IF SYSMETRIC(1) = 800 AND SYSMETRIC(2) = 600
_screen.WindowState = 2
WAIT WINDOW 'sua Resolucao de video é 800 x 600' time 1
ENDIF
IF SYSMETRIC(1) = 1024 AND SYSMETRIC(2) = 768
_screen.WindowState = 2
WAIT WINDOW AT 20,45 'Sua Resolucao de video é 1024 x 768'
ENDIF
IF SYSMETRIC(1) = 1280 AND SYSMETRIC(2) = 800
_screen.WindowState = 2
WAIT WINDOW AT 25,25 'A Resolucao de video é 1280 x 800'
ENDIFou
codigo
DO case
CASE SYSMETRIC(1)=800 AND SYSMETRIC(2)=600
_screen.WindowState = 2
WAIT WINDOW 'sua Resolucao de video é 800 x 600' time 1
CASE SYSMETRIC(1)=1024 AND SYSMETRIC(2)=768
_screen.WindowState = 2
WAIT WINDOW AT 20,45 'Sua Resolucao de video é 1024 x 768'
CASE SYSMETRIC(1)=1280 AND SYSMETRIC(2)=800
_screen.WindowState = 2
WAIT WINDOW AT 25,25 'A Resolucao de video é 1280 x 800'
ENDDO
*
on shutdow quit
Gera Relatorio em html link do arq
SELECT hist
SELECT * FROM HIST ORDER BY DESCRICAO INTO CURSOR teste
SELECT TESTE
IF RECCOUNT() > 0
=GERA_HTM()
IF USED('TESTE')
USE IN TESTE
ENDIF
ELSE
WAIT WINDOW 'Vc nao cadastrou os Precos' TIMEOUT 1
ENDIF
SELECT hist
thisform.Refresh
thisform.grid1.SetFocus
99**dbf em html
CLOSE ALL
IF NOT FILE('FMOVEN.DBF')
CREATE TABLE FMOVEN(NNOTA C(6),OBS C(20), FORNEC C(45), VALOR N(12,2),EMISSAO D(8),VALOR1 C(14))
INSERT INTO FMOVEN VALUES('000001','SEM MOVIMENTO','EMPRESA TESTE 1',520,DATE(),'520,00' )
INSERT INTO FMOVEN VALUES('000001','SEM MOVIMENTO','EMPRESA TESTE 2',520.12,DATE(),'510,12' )
INSERT INTO FMOVEN VALUES('000001','SEM MOVIMENTO','EMPRESA TESTE 2',2510.12,DATE(),'2.510,12' )
use
ENDIF
SELECT 0
USE fmoven Shared
***Crio a tabela com o valor e caracter
CREATE TABLE teste(NNOTA C(6),OBS C(20), FORNEC C(45), VALOR c(14),EMISSAO D(8))
SELECT teste && na linha abaixo pego fmoven insiro na tabela, teste com o valor em caracter
INSERT INTO teste (nnota,obs,fornec,valor,emissao) SELECT nnota,obs,fornec,TRansform(valor,'99,999,999.99'),emissao from fmoven
SELECT teste
go top
SET POINT TO ","
SET DATE FRENCH
SET CENTURY ON
SET DECIMALS TO 2
SET SYSFORMATS ON
LOCAL obj AS OBJECT
LOCAL arquivo AS STRING
m.obj = NEWOBJECT("datatohtml")
m.arquivo = m.obj.tabletohtml("teste")
m.obj.shell_exec(m.arquivo)
m.obj = NULL
USE IN SELECT("teste")
***********
DEFINE CLASS datatohtml AS CUSTOM
*!* Converte um SELECT para HTML
FUNCTION selecttohtml AS STRING
LPARAMETERS cselect AS STRING, caminhoarquivo AS STRING
*!*
LOCAL cabecalho AS STRING
LOCAL rodapeh AS STRING
LOCAL conteudo AS STRING
LOCAL nometabela AS STRING
LOCAL totalcampos AS INTEGER
LOCAL contador AS INTEGER
LOCAL nomecursor AS STRING
LOCAL nomecoluna AS STRING
LOCAL cor AS STRING
*!*
IF (VARTYPE(m.cselect)!="C") THEN
RETURN ""
ENDIF
*!* Caminho onde o arquivo será armazenado (Informar a extensão do arquivo!)
IF (VARTYPE(m.caminhoarquivo)!="C") THEN
m.caminhoarquivo = SYS(5)+CURDIR() + SYS(2015)+".html"
ENDIF
*!*
m.nometabela = ALLTRIM(GETWORDNUM(STREXTRACT(UPPER(cselect),"FROM"),1))
m.nomecursor = SYS(2015)
*!*
IF !USED(m.nometabela) THEN
RETURN ""
ENDIF
*!*
m.cabecalho = ""
m.rodapeh = "
"
m.totalcampos = FCOUNT(m.nometabela)
m.conteudo = ""
*!*
m.conteudo = m.conteudo + ""
FOR m.contador=1 TO m.totalcampos
m.conteudo = m.conteudo + []+FIELD(m.contador)+""
ENDFOR
m.conteudo = m.conteudo + ""
*!*
EXECscript(m.cselect+" INTO CURSOR "+m.nomecursor)
*!*
IF (RECCOUNT(m.nomecursor)>0) THEN
SELECT(m.nomecursor)
SCAN
IF (RECNO()%2!=0) THEN
m.cor = "#EAF1FF"
ELSE
m.cor = "#DFEAFF"
ENDIF
m.conteudo = m.conteudo + ""
FOR m.contador=1 TO m.totalcampos
m.nomecoluna = FIELD(m.contador)
m.conteudo = m.conteudo + []+TRANSFORM(&nomecoluna)+""
ENDFOR
m.conteudo = m.conteudo + ""
WAIT WINDOW M.CONTEUDO TIMEOUT 1
ENDSCAN
ENDIF
WAIT WINDOW M.CONTEUDO TIMEOUT 1
WAIT WINDOW M.nometabela
*!*
USE IN SELECT(m.nomecursor)
*!*
STRTOFILE(m.cabecalho + m.conteudo + m.rodapeh,m.caminhoarquivo)
RETURN m.caminhoarquivo
ENDFUNC
*!* Converte dados de um cursor para HTML
FUNCTION tabletohtml AS STRING
LPARAMETERS nomeTabela AS STRING, caminhoarquivo AS STRING
*!*
LOCAL cabecalho AS STRING
LOCAL rodapeh AS STRING
LOCAL conteudo AS STRING
LOCAL totalcampos AS INTEGER
LOCAL contador AS INTEGER
LOCAL nomecoluna AS STRING
LOCAL cor AS STRING
*!*
IF (VARTYPE(m.nomeTabela)!="C") THEN
RETURN ""
ENDIF
*!* Caminho onde o arquivo será armazenado (Informar a extensão do arquivo!)
IF (VARTYPE(m.caminhoarquivo)!="C") THEN
m.caminhoarquivo = SYS(5)+CURDIR() + SYS(2015)+".html"
ENDIF
*!*
IF !USED(m.nometabela) THEN
RETURN ""
ENDIF
*!*
m.cabecalho = ""
m.rodapeh = "
"
m.totalcampos = FCOUNT(m.nometabela)
m.conteudo = ""
*!*
m.conteudo = m.conteudo + ""
FOR m.contador=1 TO m.totalcampos
m.conteudo = m.conteudo + []+FIELD(m.contador)+""
ENDFOR
m.conteudo = m.conteudo + ""
*!*
IF (RECCOUNT(m.nomeTabela)>0) THEN
SELECT(m.nomeTabela)
SCAN
IF (RECNO()%2!=0) THEN
m.cor = "#EAF1FF"
ELSE
m.cor = "#DFEAFF"
ENDIF
m.conteudo = m.conteudo + ""
FOR m.contador=1 TO m.totalcampos
m.nomecoluna = FIELD(m.contador)
m.conteudo = m.conteudo + []+TRANSFORM(&nomecoluna)+""
ENDFOR
m.conteudo = m.conteudo + ""
ENDSCAN
ENDIF
*!*
STRTOFILE(m.cabecalho + m.conteudo + m.rodapeh,m.caminhoarquivo)
RETURN m.caminhoarquivo
ENDFUNC
*!* Abre o arquivo
FUNCTION shell_exec
LPARAMETERS lclink, lcaction, lcparms, lcdir, nshowwindow
IF (VARTYPE(m.lclink)!="C") THEN
RETURN -1
ENDIF
DECLARE INTEGER FindWindow IN WIN32API AS WGFindWindow STRING, STRING
DECLARE INTEGER ShellExecute IN SHELL32.DLL AS WGShellExecute ;
INTEGER, STRING, STRING, STRING, STRING, INTEGER
m.lcaction = IIF(EMPTY(lcaction), "Open", lcaction)
m.lcparms = IIF(EMPTY(lcparms), "", lcparms)
m.lcdir = IIF(EMPTY(lcdir), "", lcdir)
m.nshowwindow = IIF(VARTYPE(m.nshowwindow) == "N", m.nshowwindow, 1)
RETURN wgshellexecute(wgfindwindow(0, _SCREEN.CAPTION), ;
@lcaction, @lclink, ;
@lcparms, @lcdir, ;
m.nshowwindow)
ENDFUNC
ENDDEFINE && fim do html
40_a) Valor por Extenso
Set Safety Off
=valor_extenso(2452.34)
wre=valor_extenso(2452.34)
Create Cursor Tabla1 (Txt C(78))
Insert Into Tabla1 Values ("RECIBO ")
Insert Into Tabla1 Values ("======== ")
Insert Into Tabla1 Values ("Valor R$ 2,452.34")
Insert Into Tabla1 Values (wre)
Insert Into Tabla1 Values ("Recebemos de Joao Grana, a importancia acima cidtada,ref.serv.prestados ")
Insert Into Tabla1 Values ("Sao Paulo, 31/2/2010 ")
Insert Into Tabla1 Values (" ")
Insert Into Tabla1 Values ("======== ")
Create Report Reporte1 From Tabla1
Report Form Reporte1 Preview Nowait
FUNCTION valor_extenso
lPARAMETERS pvalor
local vextenso, flagbilhao, flagmilhao,flagcentavos
DIMENSION unidade[10], dez[10], dezena[10], centena[11]
STORE .F. TO flagbilhao,flagmilhao,flagcentavos
unidade[1] = ""
unidade[2] = "Um "
unidade[3] = "Dois "
unidade[4] = "Três "
unidade[5] = "Quatro "
unidade[6] = "Cinco "
unidade[7] = "Seis "
unidade[8] = "Sete "
unidade[9] = "Oito "
unidade[10] = "Nove "
dez[1] = "Dez "
dez[2] = "Onze "
dez[3] = "Doze "
dez[4] = "Treze "
dez[5] = "Quatorze "
dez[6] = "Quinze "
dez[7] = "Dezesseis "
dez[8] = "Dezessete "
dez[9] = "Dezoito "
dez[10] = "Dezenove "
dezena[1] = ""
dezena[2] = "Dez "
dezena[3] = "Vinte "
dezena[4] = "Trinta "
dezena[5] = "Quarenta "
dezena[6] = "Cinqüenta "
dezena[7] = "Sessenta "
dezena[8] = "Setenta "
dezena[9] = "Oitenta "
dezena[10] = "Noventa "
centena[1] = ""
centena[2] = "Cento "
centena[3] = "Duzentos "
centena[4] = "Trezentos "
centena[5] = "Quatrocentos "
centena[6] = "Quinhentos "
centena[7] = "Seiscentos "
centena[8] = "Setecentos "
centena[9] = "Oitocentos "
centena[10] = "Novecentos "
centena[11] = "Cem "
valorstr = STR(INT(pvalor * 100),14,0)
vextenso = " "
FOR i=1 TO 14
IF SUBSTR(valorstr,i,1) != " "
num = VAL(SUBSTR(valorstr,i,1))
DO CASE
* --- Bilhao
CASE i = 1
IF num = 1 .AND. VAL(SUBSTR(valorstr,i+1,2)) = 0
vextenso = centena[11]
ELSE
vextenso = centena[Num+1] + IIF(SUBSTR(valorstr,i+1,2) = "00" OR num=0, "", "e ")
ENDIF
flagbilhao = .T.
CASE i = 2
IF num != 1
vextenso = vextenso + dezena[Num+1] + IIF(SUBSTR(valorstr,i+1,1) = "0" .OR. num=0, "", "e ")
flagbilhao = .T.
ELSE
i=i+1
num = VAL(SUBSTR(valorstr,i,1))
vextenso = vextenso + dez[Num+1] + "Bilhões" + IIF(VAL(SUBSTR(valorstr,4))>0,", "," ")
ENDIF
CASE i = 3
IF !(flagbilhao)
flagbilhao = IIF(num>1,.T.,.F.)
ENDIF
vextenso = vextenso + unidade[Num+1] + IIF(flagbilhao,"Bilhões","Bilhão") + IIF(VAL(SUBSTR(valorstr,4))>0,", "," ")
*---- Milhao
CASE i = 4
IF num = 1 .AND. VAL(SUBSTR(valorstr,i+1,2)) = 0
vextenso = vextenso + centena[11]
ELSE
vextenso = vextenso + centena[Num+1] + IIF(SUBSTR(valorstr,i+1,2) = "00" OR num=0, "", "e ")
ENDIF
flagmilhao = .T.
CASE i = 5
IF num != 1
vextenso = vextenso + dezena[Num+1] + IIF(SUBSTR(valorstr,i+1,1) = "0" .OR. num=0, "", "e ")
flagmilhao = .T.
ELSE
i=i+1
num = VAL(SUBSTR(valorstr,i,1))
vextenso = vextenso + dez[Num+1] + "Milhões" + IIF(VAL(SUBSTR(valorstr,7))>0,", "," ")
ENDIF
CASE i = 6
IF !(flagmilhao)
flagmilhao = IIF(num>1,.T.,.F.)
ENDIF
vextenso = vextenso + unidade[Num+1] + IIF(flagmilhao,"Milhões","Milhão") + IIF(VAL(SUBSTR(valorstr,7))>0,", "," ")
*--- MILHAR
CASE i = 7
IF num = 1 .AND. VAL(SUBSTR(valorstr,i+1,2)) = 0
vextenso = vextenso + centena[11]
ELSE
vextenso = vextenso + centena[Num+1] + IIF(SUBSTR(valorstr,i+1,2) = "00" OR num=0, "", "e ")
ENDIF
CASE i = 8
IF num != 1
vextenso = vextenso + dezena[Num+1] + IIF(SUBSTR(valorstr,i+1,1) = "0" .OR. num=0, "", "e ")
ELSE
i=i+1
num = VAL(SUBSTR(valorstr,i,1))
vextenso = vextenso + dez[Num+1] + "Mil" + IIF(VAL(SUBSTR(valorstr,10))>0,", "," ")
ENDIF
CASE i = 9
vextenso = vextenso + unidade[Num+1] + "Mil" + IIF(VAL(SUBSTR(valorstr,10))>0,", "," ")
*--- Reais
CASE i = 10
IF num = 1 .AND. VAL(SUBSTR(valorstr,i+1,2)) = 0
vextenso = vextenso + centena[11]
ELSE
vextenso = vextenso + centena[Num+1] + IIF(SUBSTR(valorstr,i+1,2) = "00" OR num=0, "", "e ")
ENDIF
CASE i = 11
IF num != 1
vextenso = vextenso + dezena[Num+1] + IIF(SUBSTR(valorstr,i+1,1) = "0" .OR. num=0, "", "e ")
ELSE
i=i+1
num = VAL(SUBSTR(valorstr,i,1))
vextenso = vextenso + dez[Num+1] + "Reais" + IIF(VAL(SUBSTR(valorstr,13))>0," e "," ")
ENDIF
CASE i = 12
vextenso=vextenso+unidade[Num+1]+ IIF(EMPTY(vextenso) AND num=1,"Real","Reais") +IIF(VAL(SUBSTR(valorstr,13))>0," e "," ")
*---- CENTAVOS
CASE i = 13
IF num != 1
vextenso = vextenso + dezena[Num+1]
flagcentavos = IIF(num>1,.T.,.F.)
ELSE
i=i+1
num = VAL(SUBSTR(valorstr,i,1))
vextenso = vextenso + dez[Num+1] + "Centavos"
flagcentavos = .T.
ENDIF
CASE i = 14
IF !(flagcentavos)
flagcentavos = IIF(num>1,.T.,.F.)
ENDIF
IF flagcentavos
vextenso = vextenso + unidade[Num+1] + IIF(flagcentavos,"Centavos","")
ELSE
IF num>0
vextenso = vextenso + unidade[Num+1] + "Centavo"
ENDIF
ENDIF
ENDCASE
ENDIF
ENDFOR
WAIT WINDOW 'vc digitou 2452.34 '+ALLTRIM(vextenso) TIMEOUT 0.2
RETURN ALLTRIM(vextenso)
**
39=) Converter numero em caracter sem perder o valor
wr=43170557096
y=Ferrari(wr)
WAIT WINDOW AT 25,35 y +1 TIMEOUT 2
FUNCTION Ferrari
parameters onumero
alltrim(str(onumero,100))
return(onumero)
***Funciton nomedela
Parameters nomeretorno
...Seu codigo
Return(nomeRetorno)
Endfunc
***Um exemplo
CLEAR
store 0 to A,B,C
DO PROCEDURE1 WITH A,B,C
? A+B+C
PROCEDURE PROCEDURE1
PARAMETERS A,B,C
A=90
B=90
C=90
* Impressão da nota de venda
* Mini cupom
*---------------------------------
SET DEVICE TO PRINT
DATA = DTOC(DATE())
TEMPO = TIME()
LETRA = "TIMES NEW ROMAM"
TAM = 8
*
@ PROW()+1, 01 SAY REPLICATE("-",70) FONT LETRA,TAM STYLE "T"
@ PROW()+1, 13 SAY "S E M V A L O R F I S C A L" FONT LETRA,TAM STYLE "T"
@ PROW()+1, 01 SAY REPLICATE("-",70) FONT LETRA,TAM STYLE "T"
@ PROW()+1, 01 SAY VFIRMA FONT LETRA,TAM STYLE "T"
@ PROW()+1, 01 SAY ALLTRIM(VENDE_FIRMA) FONT LETRA,TAM STYLE "T"
@ PROW()+1, 01 SAY ALLTRIM(VCID_FIRMA) + " Cep:" + VCEP_FIRMA + " - " + "Brasil" FONT LETRA,TAM STYLE "T"
@ PROW()+1, 01 SAY "Atendente:" + NOME_VEND FONT LETRA,TAM STYLE "T"
@ PROW()+1, 01 SAY "Mesa:" + STR(COD_MESA) FONT LETRA,TAM STYLE "T"
@ PROW() , 26 SAY "Nº Comanda: " + NR_VENDA FONT LETRA,TAM STYLE "T"
@ PROW()+1, 01 SAY REPLICATE("-",70) FONT LETRA,TAM STYLE "T"
@ PROW()+1, 13 SAY "C U P O M C O N S U M O" FONT LETRA,TAM STYLE "T"
@ PROW()+1, 01 SAY REPLICATE("-",70) FONT LETRA,TAM STYLE "T"
@ PROW()+1, 01 SAY "Descrição do Produto Qtd´s R$ Unit Total Item" FONT LETRA,7 STYLE "T"
@ PROW()+1, 01 SAY REPLICATE("-",70) FONT LETRA,TAM STYLE "T"
*
DO WHILE .NOT. EOF()
*
@ PROW()+1,01 SAY DES_PRODU PICTURE "xxxxxxxxxxxxxxxxxxxxxxxxxxxxx" FONT LETRA,6 STYLE "T"
@ PROW() ,27 SAY QTD PICTURE "99.99" FONT LETRA,6 STYLE "T"
@ PROW() ,34 SAY PRECO_VEND PICTURE "999.99" FONT LETRA,6 STYLE "T"
@ PROW() ,43 SAY TOTAL_ITEM PICTURE "999.99" FONT LETRA,6 STYLE "T"
*
SKIP
*
IF EOF()
*
@ PROW()+1,01 SAY REPLICATE("-",70) FONT LETRA,TAM STYLE "T"
*
IF VCOD_PGTO_1 <> 0.00
*
@ PROW()+1,01 SAY VDES_PGTO_1 FONT LETRA,TAM STYLE "T"
@ PROW() ,15 SAY VVLR_PGTO_1 PICTURE "999.99" FONT LETRA,TAM STYLE "T"
*
ENDIF
*
@ PROW() ,28 SAY "Consumo:" FONT LETRA,TAM STYLE "T"
@ PROW() ,43 SAY VTOT_VENDA PICTURE "999.99" FONT LETRA,TAM STYLE "T"
*
IF VCOD_PGTO_2 <> 0.00
*
@ PROW()+1,01 SAY VDES_PGTO_2 FONT LETRA,TAM STYLE "T"
@ PROW() ,15 SAY VVLR_PGTO_2 PICTURE "999.99" FONT LETRA,TAM STYLE "T"
@ PROW() ,28 SAY "Total Serviços" FONT LETRA,TAM STYLE "T"
@ PROW() ,43 SAY VTOT_SERVI PICTURE "999.99" FONT LETRA,TAM STYLE "T"
ELSE
@ PROW()+1,28 SAY "Total Serviços" FONT LETRA,TAM STYLE "T"
@ PROW() ,43 SAY VTOT_SERVI PICTURE "999.99" FONT LETRA,TAM STYLE "T"
ENDIF
IF VCOD_PGTO_3 <> 0.00
@ PROW()+1,01 SAY VDES_PGTO_3 FONT LETRA,TAM STYLE "T"
@ PROW() ,15 SAY VVLR_PGTO_3 PICTURE "999.99" FONT LETRA,TAM STYLE "T"
@ PROW() ,28 SAY "Total Geral:" FONT LETRA,TAM STYLE "T"
@ PROW() ,43 SAY VTOT_GERAL PICTURE "999.99" FONT LETRA,TAM STYLE "T"
ELSE
@ PROW()+1,28 SAY "Total Geral:" FONT LETRA,TAM STYLE "T"
@ PROW() ,43 SAY VTOT_GERAL PICTURE "999.99" FONT LETRA,TAM STYLE "T"
ENDIF
@ PROW()+2,01 SAY REPLICATE("-",70) FONT LETRA,TAM STYLE "T"
@ PROW()+1,12 SAY "OBRIGADO E VOLTE SEMPRE" FONT LETRA,TAM STYLE "T"
EXIT
ENDIF
ENDDO
SET PRINTER OFF
SET PRINTER TO
SET DEVICE TO SCREEN
Boa noite, sou programador "clipeiro das antigas" e to migando para VFP e me deparei com um problema que tá me corroendo os miolos.
ResponderExcluirPreciso gerar boletos (Ex: 60 boletos, com o mesmo dia na data de vencimento, que é de mês em mês - 20/02/2018 - 20/03/2018 - 20/04/2018.... até que complete os 60)
Já consegui gerar usando o FOR.
DO case
CASE atencao = 6 && sim
qtddias=thisform.txt_quanparc.Value * 30 && Quant de Parcelas
thisform.txt_mdata.Value=(thisform.txt_datainic.value-30) && txt_mdata (variavel local)
FOR i = 1 TO (qtddias/30) && gera a quantidade de meses
SELECT boletos
APPEND BLANK
replace codisaca WITH sacado.codigo
&& gera a data de vencimento para o mesmo dia
xmdia=SUBSTR(DTOC(thisform.txt_datainic.Value),1,2)
xdata=xmdia+"/"+SUBSTR(DTOC(thisform.txt_mdata.Value),4,2)+;
"/"+SUBSTR(DTOC(thisform.txt_mdata.Value),7,4)
gravadata=CTOD(xdata)
replace datavenc WITH gravadata
replace nomesaca WITH sacado.sacad1
replace grupsaca WITH sacado.tipogrup
replace situacao WITH "Em Aberto"
replace codicede WITH cedente.codicede
&&
NEXT
Em algum momento está gerando uma data de vencimento repetida. Concluo que seja
pelo fato de Julho e Agosto terem o mesmo total de dias ou, talvez seja pelo fato
do "Ano Bissexto".
Alguem aí seria capaz de me ajudar. Saiba, sou iniciante ainda no VFP 9.0
Seria muito agradecido. Meu mail: jereclima@gmail.com - Anápolis/GO
Aguardo...