[Tópico Único] - Funções Interessantes

por **Marcos Guedes** em 2/4/2009, 01:17

Relembrando a primeira mensagem :

Conferindo CEP
Clique aqui para acessar o site oficial e/ou consultar o exemplo em outras linguagens...

Código:: * ######################################################################################## * ####### Desenvolvido por Leandro Sbrissa ####### * ####### MSN: [Você precisa estar registrado e conectado para ver este link.] ####### * ######################################################################################## * EXEMPLO FEITO PELO COLEGA ACIMA E CONVERTIDO PARA O VFP POR PABLO SOLLAR ****************************************************************************************** * Cria objeto e realiza consulta no "[Você precisa estar registrado e conectado para ver este link.] (XML) lc_cep_a_ser_procurado="50920180" lc_url_procura ="http://[Você precisa estar registrado e conectado para ver este link.] srvXMLHttp = CreateObject("MSXML2.ServerXMLHTTP.4.0") srvXMLHttp.open("GET",lc_url_procura,.f.) srvXMLHttp.Send() *!*MESSAGEBOX(srvXMLHttp.responseText) STORE "" TO cep, uf, cidade, bairro, t_logradouro, logradouro, resultado, resultado_txt *Cria objeto e Adquiri resultado da busca em formato XML xmlResult = CreateObject("MSXML2.DomDocument") xmlResult.loadXML(srvXMLHttp.ResponseText) * Recupera valores do resultado da busca * ********************** Observação * O servidor [Você precisa estar registrado e conectado para ver este link.] retorna apenas 1 resultado para cada CEP * por esta razão o método ".item(0)" foi usado, ou seja, se existisse, mais de 1 resultado * seria necessario realizar um LOOP de "0" à "xmlResult.length" para recuperar * todos os items de cada resultado retornado com o nome de cada nó do XML resultado = xmlResult.SelectNodes("//resultado" ).item(0).Text resultado_txt= xmlResult.SelectNodes("//resultado_txt" ).item(0).Text cep = xmlResult.SelectNodes("//cep" ).item(0).Text * Caso ocorra alguma irregularidade os nós abaixo não vão existir * portanto para evitar erros pegaremos os valore apenas se o resultado for positivo IF INT(VAL(resultado)) > 0 uf = xmlResult.SelectNodes("//uf" ).item(0).Text cidade = xmlResult.SelectNodes("//cidade" ).item(0).Text bairro = xmlResult.SelectNodes("//bairro" ).item(0).Text t_logradouro = xmlResult.SelectNodes("//tipo_logradouro").item(0).Text logradouro = xmlResult.SelectNodes("//logradouro" ).item(0).Text ENDIF CLEAR ?cep ?uf ?cidade ?bairro ?t_logradouro ?logradouro

por **Marcos Guedes** em 2/7/2009, 18:08

Listando as principais pastas do Windows:

Código:: m.pastasWindows() FUNCTION pastasWindows AS void LOCAL objscriptshell AS wscript.SHELL LOCAL counter as Integer m.objscriptshell = NEWOBJECT("wscript.shell") FOR m.counter = 0 TO 16 ?m.objscriptshell.SpecialFolders(m.counter) ENDFOR ENDFUNC

por **Marcos Guedes** em 2/7/2009, 18:09

Listando pastas especiais do Windows:

Código:: m.pastasEspeciaisWindows() FUNCTION pastasEspeciaisWindows AS void LOCAL objscriptfile AS scripting.filesystemobject LOCAL counter AS INTEGER m.objscriptfile= NEWOBJECT("Scripting.FileSystemObject") FOR m.counter = 0 TO 2 ?m.objscriptfile.getspecialfolder(m.counter).PATH ENDFOR ENDFUNC

por **Marcos Guedes** em 6/7/2009, 16:54

Abrindo Executáveis com a DLL ShellExecute:

Como chamar:

Código:: shell_exec("calc.exe") shell_exec("mspaint.exe") shell_exec("explorer.exe") shell_exec("wmplayer.exe", "open", "C:\seuArquivo.ext")

A função:

Código:: FUNCTION shell_exec LPARAMETERS lclink, lcaction, lcparms, lcdir, nshowwindow 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

por **Marcos Guedes** em 6/7/2009, 23:36

Enviando email's com o componente Jmail.

Código:: FUNCTION enviaremailjmail AS logical LPARAMETERS ; remetente AS STRING,; destinatario AS STRING,; assunto AS STRING,; conteudo AS STRING,; formatohtml AS logical LOCAL objmail AS OBJECT LOCAL usuarioautenticar AS STRING LOCAL senhaautenticar AS STRING LOCAL servidorsmtp AS STRING m.usuarioautenticar = "usuario@dominio.com.br" m.senhaautenticar = "senhaUsuario" m.servidorsmtp = "mail.dominio.com.br" m.objmail = NEWOBJECT("jmail.message") m.objmail.silent = .T. && Caso ocorra um erro, ficará em silêncio. m.objmail.FROM = m.remetente m.objmail.addrecipient(destinatario) m.objmail.subject = m.assunto IF !EMPTY(m.formatohtml) THEN *!* Formato HTML m.objmail.appendhtml(m.conteudo) ELSE *!* Formato texto m.objmail.appendtext = m.conteudo ENDIF m.objmail.mailserverusername = m.usuarioautenticar m.objmail.mailserverpassword = m.senhaautenticar RETURN m.objmail.SEND(m.servidorsmtp) ENDFUNC

Nota: Para que esta função funcione corretamente, é necessário ter o componente w3Jmail instalado em sua máquina.
Para download do componente, acesse o link abaixo:
[Você precisa estar registrado e conectado para ver este link.]

por **Marcos Guedes** em 9/7/2009, 00:23

Executando um arquivo wav:
Mensagem movida para um tópico específico:
[Você precisa estar registrado e conectado para ver este link.]

por **Marcos Guedes** em 9/7/2009, 23:34

Criptografia MD5:

Segue uma ótima classe para criptografia em MD5:

Código:: DEFINE CLASS md5 AS CUSTOM OLEPUBLIC ********************************************************************************************************************** * Written in VFP by GILLES Patrick (C) IKOONET SARL [Você precisa estar registrado e conectado para ver este link.] * Une implémention en Visual Foxpro de l'algorithme MD5 message digest tel que definis dans le RFC 1321 par R. RIVEST * de la sociét?RSA DATA SECURTY & MIT Laboratory for Computer Science * A VFP implementation of the RSA Data Security, Inc. MD5 Message Digest Algorithm, as defined in RFC 1321. ********************************************************************************************************************** * Usage (sample) * SET PROCEDURE TO mdigest5 * MD5=CREATEOBJECT("MD5") * MD5.tohash="abc" * ? MD5.compute() ******************************* tohash="" DIMENSION sinusarray(64) #DEFINE max_uint 4294967296 #DEFINE numberofbit 8 && UNICODE 16 (unicode not tested) PROCEDURE INIT LOCAL i FOR i = 1 TO 64 THIS.sinusarray(i)=TRANSFORM(max_uint*ABS(SIN(i)),"@0") THIS.sinusarray(i)=BITAND(EVALUATE(THIS.sinusarray(i)),0xffffffff) &&CAST ENDFOR RETURN .T. PROCEDURE bourre LOCAL nbr_bit_bourre, bourrage bourrage = CHR(128)+REPLICATE(CHR(0),63) nbr_bit_bourre=(448-(LEN(THIS.tohash)*numberofbit)%512)/numberofbit IF (LEN(THIS.tohash)*numberofbit)%512>=448 nbr_bit_bourre=(448+((512-LEN(THIS.tohash)*numberofbit)%512))/numberofbit ENDIF RETURN LEFT(bourrage,nbr_bit_bourre) PROCEDURE acompleter LOCAL retour,decalage decalage=TRANSFORM(LEN(THIS.tohash)* numberofbit,"@0") retour="" retour=retour+CHR(EVALUATE("0x"+SUBSTR(decalage,9,2))) retour=retour+CHR(EVALUATE("0x"+SUBSTR(decalage,7,2))) retour=retour+CHR(EVALUATE("0x"+SUBSTR(decalage,5,2))) retour=retour+CHR(EVALUATE("0x"+SUBSTR(decalage,3,2))) retour=retour+REPLICATE(CHR(0),4) RETURN retour PROCEDURE md5_f LPARAMETERS x,Y,z RETURN BITOR(BITAND(x,Y),BITAND(BITNOT(x),z)) PROCEDURE md5_g LPARAMETERS x,Y,z RETURN BITOR(BITAND(x,z),BITAND(Y,BITNOT(z))) PROCEDURE md5_h LPARAMETERS x,Y,z RETURN BITXOR(x,Y,z) PROCEDURE md5_i LPARAMETERS x,Y,z RETURN BITXOR(Y,BITOR(x,BITNOT(z))) PROCEDURE rotate_left LPARAMETERS PIVOT, npivot RETURN BITOR(BITLSHIFT(PIVOT,npivot),BITRSHIFT(PIVOT,32-npivot)) PROCEDURE ronde1 LPARAMETERS pa,pb,pc,pd,pe,pf,pg RETURN pb+THIS.rotate_left(pa+THIS.md5_f(pb,pc,pd)+pe+pg,pf) PROCEDURE ronde2 LPARAMETERS pa,pb,pc,pd,pe,pf,pg RETURN pb+THIS.rotate_left(pa+THIS.md5_g(pb,pc,pd)+pe+pg,pf) PROCEDURE ronde3 LPARAMETERS pa,pb,pc,pd,pe,pf,pg RETURN pb+THIS.rotate_left(pa+THIS.md5_h(pb,pc,pd)+pe+pg,pf) PROCEDURE ronde4 LPARAMETERS pa,pb,pc,pd,pe,pf,pg RETURN pb+THIS.rotate_left(pa+THIS.md5_i(pb,pc,pd)+pe+pg,pf) PROCEDURE COMPUTE LOCAL tocompute,cpt_i,cpt_j,cpt_l,tmp_string,aa,bb,cc,dd,a,b,c,d,aa,bb,cc,dd a=BITAND(0x67452301,0xffffffff) b=BITAND(0xefcdab89,0xffffffff) c=BITAND(0x98badcfe,0xffffffff) d=BITAND(0x10325476,0xffffffff) DIMENSION t_x(16) tocompute=THIS.tohash+THIS.bourre()+THIS.acompleter() lentocompute=LEN(tocompute)/64 olda=a oldb=b oldc=c oldd=d FOR cpt_i=0 TO lentocompute-1 FOR cpt_j=0 TO 15 t_x(cpt_j+1)="" t_x(cpt_j+1)=t_x(cpt_j+1)+RIGHT(TRANSFORM(ASC(SUBSTR(tocompute,(cpt_i*64)+(cpt_j*4)+4,1)),"@0"),2) t_x(cpt_j+1)=t_x(cpt_j+1)+RIGHT(TRANSFORM(ASC(SUBSTR(tocompute,(cpt_i*64)+(cpt_j*4)+3,1)),"@0"),2) t_x(cpt_j+1)=t_x(cpt_j+1)+RIGHT(TRANSFORM(ASC(SUBSTR(tocompute,(cpt_i*64)+(cpt_j*4)+2,1)),"@0"),2) t_x(cpt_j+1)=t_x(cpt_j+1)+RIGHT(TRANSFORM(ASC(SUBSTR(tocompute,(cpt_i*64)+(cpt_j*4)+1,1)),"@0"),2) t_x(cpt_j+1)=BITAND(EVALUATE("0x"+t_x(cpt_j+1)),0xffffffff) && CAST *? TRANSFORM(T_X(CPT_J+1),"@0") *? ENDFOR olda=a oldb=b oldc=c oldd=d && Ronde1 a=THIS.ronde1(a,b,c,d,t_x( 1), 7,THIS.sinusarray( 1)) d=THIS.ronde1(d,a,b,c,t_x( 2),12,THIS.sinusarray( 2)) c=THIS.ronde1(c,d,a,b,t_x( 3),17,THIS.sinusarray( 3)) b=THIS.ronde1(b,c,d,a,t_x( 4),22,THIS.sinusarray( 4)) a=THIS.ronde1(a,b,c,d,t_x( 5), 7,THIS.sinusarray( 5)) d=THIS.ronde1(d,a,b,c,t_x( 6),12,THIS.sinusarray( 6)) c=THIS.ronde1(c,d,a,b,t_x( 7),17,THIS.sinusarray( 7)) b=THIS.ronde1(b,c,d,a,t_x( 8),22,THIS.sinusarray( 8)) a=THIS.ronde1(a,b,c,d,t_x( 9), 7,THIS.sinusarray( 9)) d=THIS.ronde1(d,a,b,c,t_x(10),12,THIS.sinusarray(10)) c=THIS.ronde1(c,d,a,b,t_x(11),17,THIS.sinusarray(11)) b=THIS.ronde1(b,c,d,a,t_x(12),22,THIS.sinusarray(12)) a=THIS.ronde1(a,b,c,d,t_x(13), 7,THIS.sinusarray(13)) d=THIS.ronde1(d,a,b,c,t_x(14),12,THIS.sinusarray(14)) c=THIS.ronde1(c,d,a,b,t_x(15),17,THIS.sinusarray(15)) b=THIS.ronde1(b,c,d,a,t_x(16),22,THIS.sinusarray(16)) && ronde 2 a=THIS.ronde2(a,b,c,d,t_x( 2), 5,THIS.sinusarray(17)) d=THIS.ronde2(d,a,b,c,t_x( 7), 9,THIS.sinusarray(18)) c=THIS.ronde2(c,d,a,b,t_x(12),14,THIS.sinusarray(19)) b=THIS.ronde2(b,c,d,a,t_x( 1),20,THIS.sinusarray(20)) a=THIS.ronde2(a,b,c,d,t_x( 6), 5,THIS.sinusarray(21)) d=THIS.ronde2(d,a,b,c,t_x(11), 9,THIS.sinusarray(22)) c=THIS.ronde2(c,d,a,b,t_x(16),14,THIS.sinusarray(23)) b=THIS.ronde2(b,c,d,a,t_x( 5),20,THIS.sinusarray(24)) a=THIS.ronde2(a,b,c,d,t_x(10), 5,THIS.sinusarray(25)) d=THIS.ronde2(d,a,b,c,t_x(15), 9,THIS.sinusarray(26)) c=THIS.ronde2(c,d,a,b,t_x( 4),14,THIS.sinusarray(27)) b=THIS.ronde2(b,c,d,a,t_x( 9),20,THIS.sinusarray(28)) a=THIS.ronde2(a,b,c,d,t_x(14), 5,THIS.sinusarray(29)) d=THIS.ronde2(d,a,b,c,t_x( 3), 9,THIS.sinusarray(30)) c=THIS.ronde2(c,d,a,b,t_x( 8),14,THIS.sinusarray(31)) b=THIS.ronde2(b,c,d,a,t_x(13),20,THIS.sinusarray(32)) && ronde 3 a=THIS.ronde3(a,b,c,d,t_x( 6), 4,THIS.sinusarray(33)) d=THIS.ronde3(d,a,b,c,t_x( 9),11,THIS.sinusarray(34)) c=THIS.ronde3(c,d,a,b,t_x(12),16,THIS.sinusarray(35)) b=THIS.ronde3(b,c,d,a,t_x(15),23,THIS.sinusarray(36)) a=THIS.ronde3(a,b,c,d,t_x( 2), 4,THIS.sinusarray(37)) d=THIS.ronde3(d,a,b,c,t_x( 5),11,THIS.sinusarray(38)) c=THIS.ronde3(c,d,a,b,t_x( 8),16,THIS.sinusarray(39)) b=THIS.ronde3(b,c,d,a,t_x(11),23,THIS.sinusarray(40)) a=THIS.ronde3(a,b,c,d,t_x(14), 4,THIS.sinusarray(41)) d=THIS.ronde3(d,a,b,c,t_x( 1),11,THIS.sinusarray(42)) c=THIS.ronde3(c,d,a,b,t_x( 4),16,THIS.sinusarray(43)) b=THIS.ronde3(b,c,d,a,t_x( 7),23,THIS.sinusarray(44)) a=THIS.ronde3(a,b,c,d,t_x(10), 4,THIS.sinusarray(45)) d=THIS.ronde3(d,a,b,c,t_x(13),11,THIS.sinusarray(46)) c=THIS.ronde3(c,d,a,b,t_x(16),16,THIS.sinusarray(47)) b=THIS.ronde3(b,c,d,a,t_x( 3),23,THIS.sinusarray(48)) && ronde 4 a=THIS.ronde4(a,b,c,d,t_x( 1), 6,THIS.sinusarray(49)) d=THIS.ronde4(d,a,b,c,t_x( 8),10,THIS.sinusarray(50)) c=THIS.ronde4(c,d,a,b,t_x(15),15,THIS.sinusarray(51)) b=THIS.ronde4(b,c,d,a,t_x( 6),21,THIS.sinusarray(52)) a=THIS.ronde4(a,b,c,d,t_x(13), 6,THIS.sinusarray(53)) d=THIS.ronde4(d,a,b,c,t_x( 4),10,THIS.sinusarray(54)) c=THIS.ronde4(c,d,a,b,t_x(11),15,THIS.sinusarray(55)) b=THIS.ronde4(b,c,d,a,t_x( 2),21,THIS.sinusarray(56)) a=THIS.ronde4(a,b,c,d,t_x( 9), 6,THIS.sinusarray(57)) d=THIS.ronde4(d,a,b,c,t_x(16),10,THIS.sinusarray(58)) c=THIS.ronde4(c,d,a,b,t_x( 7),15,THIS.sinusarray(59)) b=THIS.ronde4(b,c,d,a,t_x(14),21,THIS.sinusarray(60)) a=THIS.ronde4(a,b,c,d,t_x( 5), 6,THIS.sinusarray(61)) d=THIS.ronde4(d,a,b,c,t_x(12),10,THIS.sinusarray(62)) c=THIS.ronde4(c,d,a,b,t_x( 3),15,THIS.sinusarray(63)) b=THIS.ronde4(b,c,d,a,t_x(10),21,THIS.sinusarray(64)) &&-- this was wrong, as lead to numeric overfolow when &&-- string tocompute is larger than 2KB *!* a=a+olda *!* b=b+oldb *!* c=c+oldC *!* d=d+oldd &&-- now it's OK a=BITAND(a+olda,0xffffffff) &&-- cut to 32bit unsigned integer b=BITAND(b+oldb,0xffffffff) c=BITAND(c+oldc,0xffffffff) d=BITAND(d+oldd,0xffffffff) ENDFOR a=TRANSFORM(BITAND(a,0xffffffff),"@0") && cast b=TRANSFORM(BITAND(b,0xffffffff),"@0") && cast c=TRANSFORM(BITAND(c,0xffffffff),"@0") && cast d=TRANSFORM(BITAND(d,0xffffffff),"@0") && cast a=SUBSTR(a,9,2)+SUBSTR(a,7,2)+SUBSTR(a,5,2)+SUBSTR(a,3,2) b=SUBSTR(b,9,2)+SUBSTR(b,7,2)+SUBSTR(b,5,2)+SUBSTR(b,3,2) c=SUBSTR(c,9,2)+SUBSTR(c,7,2)+SUBSTR(c,5,2)+SUBSTR(c,3,2) d=SUBSTR(d,9,2)+SUBSTR(d,7,2)+SUBSTR(d,5,2)+SUBSTR(d,3,2) RETURN a+b+c+d PROCEDURE testsuite && return true if all the reference value are true LOCAL test test=.T. THIS.tohash="" IF LOWER(THIS.COMPUTE())#"d41d8cd98f00b204e9800998ecf8427e" RETURN THIS.tohash ENDIF THIS.tohash="a" IF LOWER(THIS.COMPUTE())#"0cc175b9c0f1b6a831c399e269772661" RETURN THIS.tohash ENDIF THIS.tohash="abc" IF LOWER(THIS.COMPUTE())#"900150983cd24fb0d6963f7d28e17f72" RETURN THIS.tohash ENDIF THIS.tohash="message digest" IF LOWER(THIS.COMPUTE())#"f96b697d7cb7938d525a2f31aaf161d0" RETURN THIS.tohash ENDIF THIS.tohash="abcdefghijklmnopqrstuvwxyz" IF LOWER(THIS.COMPUTE())#"c3fcd3d76192e4007dfb496cca67e13b" RETURN THIS.tohash ENDIF THIS.tohash="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" IF LOWER(THIS.COMPUTE())#"d174ab98d277d9f5a5611c2c9f419d9f" RETURN THIS.tohash ENDIF THIS.tohash="12345678901234567890123456789012345678901234567890123456789012345678901234567890" IF LOWER(THIS.COMPUTE())#"57edf4a22be3c955ac49da2e2107b67a" RETURN THIS.tohash ENDIF RETURN test ENDDEFINE

Obs: Link onde a classe foi encontrada:
[Você precisa estar registrado e conectado para ver este link.]

por **Marcos Guedes** em 10/7/2009, 00:09

Criptografia Blowfish:
[Você precisa estar registrado e conectado para ver este link.]

por **Marcos Guedes** em 18/7/2009, 13:04

Verifica se sua aplicação está em uso pelo sistema - OUTRA ALTERNATIVA.

Código:: FUNCTION isapprunning LPARAMETERS icappscreentitle DECLARE INTEGER FindWindow IN Win32api STRING, STRING DECLARE ShowWindow IN Win32api INTEGER, INTEGER DECLARE SetForegroundWindow IN Win32api INTEGER nwinhandle = findwindow(NULL, icappscreentitle) IF nwinhandle <> 0 setforegroundwindow(nwinhandle) *!* WAIT WINDOW 'Carregando ' + icappscreentitle + '...' TIMEOUT 1 ShowWindow(nwinhandle, 9) RETURN .T. ELSE RETURN .F. ENDIF ENDFUNC

Como utilizar?

- Salve a função acima num arquivo com o nome "isapprunning.prg"
- No início de seu PRG principal escreva o seguinte código:

Código:: SET PROCEDURE TO "caminhoArquivo\isapprunning.PRG" ADDITIVE m.titprog = "CAPTION de sua aplicação" IF isapprunning(M.titprog) THEN QUIT ENDIF

Nota:
Se sua aplicação estiver sendo executada, então ela virá para frente dos outros programas.

Fonte:
Postada por Edgar - Softeasy em:
[Você precisa estar registrado e conectado para ver este link.]

por **Marcos Guedes** em 20/7/2009, 10:14

Usando recurso de voz do windows:

Código:: obj = NEWOBJECT("SAPI.SPVoice") obj.Speak("Hello!") obj.Speak("This example it is in Programation Brazil.")

Volume:

Código:: obj.Volume = 50

Saída de áudio:

Código:: *!* Padrão: obj.AudioOutputStream.Format.Type=18

por **Marcos Guedes** em 21/7/2009, 11:15

Valida email:

Código:: FUNCTION verifica_email LPARAMETERS m.emailaddr PRIVATE m.emailisok, m.allowed, m.emaddr, m.domain, m.mailbox m.emaddr = UPPER(ALLTRIM(m.emailaddr)) m.domain = SUBSTR(m.emaddr, AT("@", m.emaddr) + 1) m.mailbox = LEFT(m.emaddr, AT("@", m.emaddr) - 1) m.allowed = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ-_.@1234567890' m.emailisok = .T. DO CASE CASE LEN(CHRTRAN(UPPER(ALLTRIM(m.emaddr)), m.allowed, "")) > 0 m.emailisok = .F. CASE OCCURS("@", m.emaddr) != 1 m.emailisok = .F. CASE OCCURS(".", m.emaddr) < 1 m.emailisok = .F. CASE OCCURS("..", m.emaddr) > 0 m.emailisok = .F. CASE OCCURS(".", m.domain) < 1 m.emailisok = .F. CASE INLIST(LEFT(m.domain, 1), "-", ".") m.emailisok = .F. CASE INLIST(RIGHT(m.domain, 1), "-", ".") m.emailisok = .F. CASE INLIST(LEFT(m.mailbox, 1), "-", ".") m.emailisok = .F. CASE INLIST(RIGHT(m.mailbox, 1), "-", ".") m.emailisok = .F. CASE !BETWEEN(LEN(SUBSTR(m.domain, RAT(".", m.domain) + 1)), 2, 4) m.emailisok = .F. ENDCASE RETURN m.emailisok ENDFUNC

Obs: Não foi feita por mim.

por **Marcos Guedes** em 21/7/2009, 11:17

Valida o Estado/UF baseado no CPF do mesmo:

Código:: FUNCTION validate_UF LPARAMETERS number_cpf AS STRING, wich_state AS STRING LOCAL validated AS logical LOCAL ninth_number AS INTEGER LOCAL state AS STRING LOCAL coverage_one AS COLLECTION LOCAL coverage_two AS COLLECTION LOCAL coverage_three AS COLLECTION LOCAL coverage_four AS COLLECTION LOCAL coverage_five AS COLLECTION LOCAL coverage_six AS COLLECTION LOCAL coverage_seven AS COLLECTION LOCAL coverage_eight AS COLLECTION LOCAL coverage_nine AS COLLECTION LOCAL coverage_zero AS COLLECTION LOCAL fiscal_region AS COLLECTION m.validated = .F. m.state = UPPER(ALLTRIM(m.wich_state)) m.coverage_one = NEWOBJECT("Collection") m.coverage_two = NEWOBJECT("Collection") m.coverage_three = NEWOBJECT("Collection") m.coverage_four = NEWOBJECT("Collection") m.coverage_five = NEWOBJECT("Collection") m.coverage_six = NEWOBJECT("Collection") m.coverage_seven = NEWOBJECT("Collection") m.coverage_eight = NEWOBJECT("Collection") m.coverage_nine = NEWOBJECT("Collection") m.coverage_zero = NEWOBJECT("Collection") m.fiscal_region = NEWOBJECT("Collection") m.coverage_one.ADD("DISTRITO FEDERAL") m.coverage_one.ADD("GOIÁS") m.coverage_one.ADD("MATO GROSSO DO SUL") m.coverage_one.ADD("MATO GROSSO") m.coverage_one.ADD("TOCANTINS") m.coverage_two.ADD("ACRE") m.coverage_two.ADD("AMAZONAS") m.coverage_two.ADD("AMAPÁ") m.coverage_two.ADD("PARÁ") m.coverage_two.ADD("RONDÔNIA") m.coverage_two.ADD("RORAIMA") m.coverage_three.ADD("CEARÁ") m.coverage_three.ADD("MARANHÃO") m.coverage_three.ADD("PIAUÍ") m.coverage_four.ADD("ALAGOAS") m.coverage_four.ADD("PARAÍBA") m.coverage_four.ADD("PERNAMBUCO") m.coverage_four.ADD("RIO GRANDE DO NORTE") m.coverage_five.ADD("BAHIA") m.coverage_five.ADD("SERGIPE") m.coverage_six.ADD("MINAS GERAIS") m.coverage_seven.ADD("ESPÍRITO SANTO") m.coverage_seven.ADD("RIO DE JANEIRO") m.coverage_eight.ADD("SÃO PAULO") m.coverage_nine.ADD("PARANÁ") m.coverage_nine.ADD("SANTA CATARINA") m.coverage_zero.ADD("RIO GRANDE DO SUL") m.fiscal_region.ADD(m.coverage_one) m.fiscal_region.ADD(m.coverage_two) m.fiscal_region.ADD(m.coverage_three) m.fiscal_region.ADD(m.coverage_four) m.fiscal_region.ADD(m.coverage_five) m.fiscal_region.ADD(m.coverage_six) m.fiscal_region.ADD(m.coverage_seven) m.fiscal_region.ADD(m.coverage_eight) m.fiscal_region.ADD(m.coverage_nine) m.fiscal_region.ADD(m.coverage_zero) IF THIS.validates_cpf(ALLTRIM(number_cpf)) = .T. THEN m.ninth_number = VAL(SUBSTR(ALLTRIM(number_cpf), 9, 1)) IF m.ninth_number = 0 THEN m.ninth_number = 10 ENDIF FOR i = 1 TO m.fiscal_region.ITEM(m.ninth_number).COUNT IF (m.state == m.fiscal_region.ITEM(m.ninth_number).ITEM(i)) m.validated = .T. EXIT ENDIF ENDFOR ENDIF RETURN m.validated ENDFUNC

por **Marcos Guedes** em 21/7/2009, 11:20

Valida CPF:

Código:: FUNCTION validates_cpf 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

por **Marcos Guedes** em 21/7/2009, 11:21

Valida CNPJ:

Código:: FUNCTION validates_cnpj LPARAMETERS number_cnpj AS STRING LOCAL validated AS logical LOCAL first_twelve_number AS STRING LOCAL thirteen_twelve_number AS STRING LOCAL multiplier AS INTEGER LOCAL counter AS INTEGER LOCAL stored_value AS INTEGER LOCAL rest_division AS INTEGER m.validated = .F. m.first_twelve_number = SUBSTR(ALLTRIM(number_cnpj), 1, 12) m.multiplier = 9 m.stored_value = 0 TRY IF (LEN(ALLTRIM(number_cnpj)) == 14) FOR m.counter = LEN(m.first_twelve_number) TO 1 STEP -1 m.stored_value = m.stored_value + (VAL(SUBSTR(m.first_twelve_number, m.counter, 1)) * m.multiplier) m.multiplier = m.multiplier - 1 IF m.multiplier < 2 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_cnpj), 13, 1))) THEN m.multiplier = 9 m.stored_value = 0 m.thirteen_twelve_number = SUBSTR(ALLTRIM(number_cnpj), 1, 13) FOR m.counter = LEN(m.thirteen_twelve_number) TO 1 STEP -1 m.stored_value = m.stored_value + ; (VAL(SUBSTR(m.thirteen_twelve_number, m.counter, 1)) * m.multiplier) m.multiplier = m.multiplier - 1 IF m.multiplier < 2 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_cnpj), 14, 1))) THEN 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

por **Marcos Guedes** em 21/7/2009, 13:35

Obter Mac Address a partir de um IP:

Como chamar a função:

Código:: LOCAL obj AS OBJECT m.obj = NEWOBJECT("mac_address") ? m.obj.iptomacaddress("192.168.1.0") m.obj = NULL

Código Fonte:

Código:: DEFINE CLASS mac_address AS CUSTOM FUNCTION iptomacaddress(lcip) DECLARE INTEGER inet_addr IN ws2_32.DLL STRING cIP DECLARE INTEGER SendARP IN iphlpapi.DLL; INTEGER destIP, INTEGER sourceIP,; STRING @ pMacAddr, INTEGER @ PhyAddrLen LOCAL lnhr, lnipaddr, lcmacaddr, lnlen lnipaddr = inet_addr(lcip) lcmacaddr = REPLICATE(CHR(0),6) lnlen = 6 lnhr = sendarp(lnipaddr,0,@lcmacaddr,@lnlen) RETURN THIS.binarytomac(lcmacaddr,lnlen) ENDFUNC FUNCTION binarytomac(lcmacaddr, lnlen) LOCAL lcmac, xj lcmac = "" FOR xj = 1 TO lnlen - 1 lcmac = lcmac + RIGHT(TRANSFORM(ASC(; SUBSTR(lcmacaddr,xj,1)),"@0"),2) + ":" ENDFOR lcmac = lcmac + RIGHT(TRANSFORM(ASC(; SUBSTR(lcmacaddr,lnlen,1)),"@0"),2) RETURN lcmac ENDFUNC ENDDEFINE

Fonte da função original:
[Você precisa estar registrado e conectado para ver este link.]

por **Marcos Guedes** em 21/7/2009, 13:56

Obtendo IP a partir do Nome da máquina:

Como chamar a função:

Código:: CLEAR LOCAL obj as Object LOCAL localHost as String LOCAL ip as String m.obj = NEWOBJECT("GetIP") m.localHost = m.obj.getlocalhostname() m.ip = m.obj.gethostip( m.localHost ) ? "Local Host : ", m.localHost ? "Local IP : ", m.ip

Código Fonte:

Código:: DEFINE CLASS getip AS CUSTOM NAME = "GetIP" HIDDEN PROCEDURE INIT DECLARE INTEGER WSAStartup IN ws2_32 INTEGER wVerRq, STRING @lpWSAData DECLARE INTEGER WSACleanup IN ws2_32 DECLARE INTEGER gethostbyname IN ws2_32 STRING HOSTNAME DECLARE INTEGER gethostname IN ws2_32; STRING @NAME, INTEGER namelen DECLARE RtlMoveMemory IN kernel32 AS Heap2Str; STRING @DEST, INTEGER Src, INTEGER nLength ENDPROC PROCEDURE getlocalhostname *|-- returns the standard host name for the local machine #DEFINE socket_error -1 LOCAL lcbuffer, lnresult lcbuffer = SPACE(250) lnresult = gethostname (@lcbuffer, LEN(lcbuffer)) RETURN IIF(lnresult=0, SUBSTR(lcbuffer, 1,AT(CHR(0),lcbuffer)-1), "") ENDPROC FUNCTION gethostip (lchostname) #DEFINE hostent_size 16 LOCAL lchostentptr, lchostent, lnaddrlistptr *|-- address for the HOSTENT structure lchostentptr = gethostbyname(lchostname) IF lchostentptr <> 0 lchostent = THIS.getmembuf( lchostentptr, hostent_size ) *|-- a pointer to a null-terminated list of addresses lnaddrlistptr = THIS.buf2dword(SUBSTR(lchostent, 13,4)) RETURN THIS.getipfromhostent(lnaddrlistptr) ENDIF RETURN "" ENDPROC HIDDEN PROCEDURE getipfromhostent (lnaddrlistptr) *|-- retrieving IP address from the HOSTENT structure LOCAL lndataaddress, lcresult lndataaddress = THIS.buf2dword( THIS.getmembuf( lnaddrlistptr, 4 ) ) RETURN IIF( lndataaddress <> 0, THIS.getipaddress( THIS.getmembuf( lndataaddress, 4 ) ), "" ) ENDPROC HIDDEN FUNCTION getipaddress (lcaddrbuf) *|-- converts 4-characters string buffer *|-- to the IP address string representation LOCAL lcresult, ii lcresult = "" FOR ii=1 TO 4 lcresult = lcresult +; LTRIM(STR(ASC(SUBSTR(lcaddrbuf, ii,1)))) +; IIF(ii=4, "",".") ENDFOR RETURN lcresult ENDPROC HIDDEN PROCEDURE buf2dword (lcbuffer) RETURN ASC(SUBSTR(lcbuffer, 1,1)) + ; ASC(SUBSTR(lcbuffer, 2,1)) * 256 +; ASC(SUBSTR(lcbuffer, 3,1)) * 65536 +; ASC(SUBSTR(lcbuffer, 4,1)) * 16777216 ENDPROC HIDDEN PROCEDURE getmembuf (lnaddr, lnbufsize) LOCAL lcbuffer lcbuffer = REPLICATE(CHR(0), lnbufsize) heap2str( @lcbuffer, lnaddr, lnbufsize) RETURN lcbuffer ENDPROC ENDDEFINE

Fonte original:
[Você precisa estar registrado e conectado para ver este link.]

[Tópico Único] - Funções Interessantes

[Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes

Re: [Tópico Único] - Funções Interessantes