Clique abaixo para nos ajudar
Conectar-se

Esqueci minha senha

Estamos no Facebook
Buscar
 
 

Resultados por:
 


Rechercher Busca avançada

Quem está conectado
15 usuários online :: Nenhum usuário registrado, Nenhum Invisível e 15 Visitantes :: 2 Motores de busca

Nenhum

[ Ver toda a lista ]


O recorde de usuários online foi de 468 em 1/3/2012, 10:43
ListBox

23/5/2017, 10:37 por Rosangela Pires

Ola Amigos.

Para se movimentar na grid com as setas colocamos no Metodo AfterChange da grid …

Comentários: 0

TRY BEGIN E FLOCK()

17/4/2017, 10:32 por AJC

Pessoal estou tendo alguns problemas de gravação em rede, estou usando
try begin, mas vi algo na …

Comentários: 0

Exportar Dados Campo Memo Tabela DBF

10/4/2017, 10:28 por fcampos

Olá bom dia.

Estou tentando exportar os dados de algumas tabelas em formato dbf pelo foxpro.
O …

Comentários: 2

Função EVL()

8/4/2017, 12:18 por Clebervfp

Bom dia a todos.
Vim compartilhar de uma Função do próprio VFP que me benefício muito.
Função …

Comentários: 0

COMO BLOQUEAR REGISTRO OU TABELA NO VISUAL FOXPRO PARA GRAVAÇÃO EM REDE

3/4/2017, 10:29 por AJC

Pessoal estou tendo um problema que acontece sempre busco na minha tabela de clientes o ultimo …

Comentários: 2

Estatísticas
Temos 7080 usuários registrados
O último usuário registrado atende pelo nome de Edi_0306

Os nossos membros postaram um total de 49 mensagens em 26 assuntos

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

Página 1 de 4 1, 2, 3, 4  Seguinte

Ver o tópico anterior Ver o tópico seguinte Ir em baixo

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

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

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://www.buscarcep.com.br/?cep="+lc_cep_a_ser_procurado+"&formato=xml"

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


Última edição por Marcos Guedes em 3/5/2010, 11:09, editado 6 vez(es)

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 15/4/2009, 14:35

Listando arquivos e pastas num diretório:

Como chamar a função:
Código:
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

A função:
Código:
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

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 20/5/2009, 09:46

Segue o link para download de uma classe em fox, para abrir aplicações externas e esperar o encerramento da mesma para prosseguir:
[Você precisa estar registrado e conectado para ver este link.]

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 20/5/2009, 09:56

Feche aplicações abertas com esta classe em fox:
[Você precisa estar registrado e conectado para ver este link.]

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 20/5/2009, 10:08

Atalhos na área de trabalho.

Exemplos com o bloco de notas:
Código:
wshshell = CREATEOBJECT("WScript.shell")
strdesktop = wshshell.specialfolders("Desktop") && Endereço da área de trabalho
omyshortcut =wshshell.createshortcut(strdesktop+"\\mi ejemplo.lnk") && Cria um atalho na área de trabalho
omyshortcut.windowstyle = 3
&&oMyShortCut.IconLocation = \"c:\\fox.ico\"
omyshortcut.targetpath = "%windir%\\notepad.exe\"
omyshortcut.HOTKEY = "F11"
omyshortcut.SAVE

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 20/5/2009, 10:16

Exemplo utilizando FoxTray:
[Você precisa estar registrado e conectado para ver este link.]

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 20/5/2009, 10:33

Uma ótima rotina para manipulação de arquivos zipados:
[Você precisa estar registrado e conectado para ver este link.]

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 21/5/2009, 00:12

Decimal para Hexadecimal
Código:
FUNCTION decimalToHexa
    LPARAMETERS numeroDecimal
    RETURN Transform(m. numeroDecimal, '@0x')
ENDFUNC

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 21/5/2009, 00:23

Hexadecimal para Decimal
Código:
FUNCTION hexaToDecimal
    LPARAMETERS numeroHexa AS STRING
    RETURN EVALUATE(m. numeroHexa)
ENDFUNC

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 22/5/2009, 11:51

Wait Window no centro da SCREEN:
Código:
PROCEDURE waitCenter as VOID
*********************************

LPARAMETERS pctext as String, pntimeout as Integer
LOCAL lnyy as Integer, lnxx as Integer

* Calcula o número total de linhas
m.lnxx = 1
FOR m.lnyy = 1 TO MEMLINES( m.pctext )
   m.lnxx = MAX( m.lnxx, LEN( ALLTRIM( MLINE(m.pctext, m.lnxx) ) ) )
NEXT

* Calcula a posição central da tela
m.lnyy = ( SROWS()/ 2 ) - ( (m.lnyy-1) / 2 )
m.lnxx = ( SCOLS() / 2 ) - ( m.lnxx / 2 )

* Limpa buffer de teclado e janela wait window
CLEAR TYPEAHEAD
WAIT CLEAR

* Se for especificado o timeout
IF VARTYPE( m.pntimeout ) = "N"
   *!* ---> Para ambiente de teste
   WAIT WINDOW m.pctext TIMEOUT m.pntimeout AT m.lnyy, m.lnxx-5
   *!* ---> Para ambiente de produção
   *!*WAIT WINDOW m.pctext TIMEOUT m.pntimeout AT m.lnyy+INT((SYSMETRIC(2)*3)/600), m.lnxx+INT((SYSMETRIC(1)*40)/800)
ELSE
   *!* ---> Para ambiente de teste
   WAIT WINDOW m.pctext NOWAIT NOCLEAR AT m.lnyy, m.lnxx-5
   *!* ---> Para ambiente de produção
   *!*WAIT WINDOW m.pctext NOWAIT NOCLEAR AT m.lnyy+INT((SYSMETRIC(2)*3)/600), m.lnxx+INT((SYSMETRIC(1)*40)/800)
ENDIF
ENDPROC

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 26/5/2009, 11:26

Abrindo links com o navegador padrão:
Código:
open_page("http://www.google.com")

PROCEDURE open_page as VOID
   LPARAMETERS pcurl AS STRING
      LOCAL _open AS HYPERLINK
      m._open = NEWOBJECT("hyperlink")
      m._open.NAVIGATETO(m.pcurl)
      m._open = null
ENDPROC

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 23/6/2009, 16:13

Ler arquivo INI:
Código:
OBJ = NEWOBJECT("INIFILE", "INIFILE.PRG")
?OBJ.READINivalue("ARQUIVOS","FOTOS", SYS(5)+CURDIR()+"CAMINHOS.INI")

DEFINE CLASS inifile AS CUSTOM

   cinifile = ""
   nlasterror = 0
   NAME = "inifile"

   FUNCTION readinivalue
      LPARAMETERS tcsection, tckeyname, tcinifile

      LOCAL lcinifile, lnerror, lnretval, lcbuffer, lcretval

      IF EMPTY(tcinifile) THEN
         lcinifile = THIS.cinifile
      ELSE
         lcinifile = tcinifile
      ENDIF

      lcbuffer = SPACE(250) + CHR(0)

      IF (getprivateprofilestring(tcsection, tckeyname, "", @lcbuffer, LEN(lcbuffer), lcinifile) > 0) THEN
         lcretval = ALLTRIM(CHRTRAN(lcbuffer, CHR(0), ""))
         THIS.nlasterror = 0
      ELSE
         THIS.nlasterror = getlasterror()
         lcretval = ""
      ENDIF
      RETURN lcretval
   ENDFUNC

   PROCEDURE INIT
      LPARAMETERS tcinifile

      IF  (!EMPTY(tcinifile) AND TYPE("tcIniFile") =  "C") THEN
         THIS.cinifile = tcinifile
      ELSE
         THIS.cinifile = ""
      ENDIF

      DECLARE LONG GetPrivateProfileString    IN WIN32API STRING, STRING, STRING, STRING @, LONG, STRING
      DECLARE LONG WritePrivateProfileString    IN WIN32API STRING, STRING, STRING, STRING
      DECLARE LONG WritePrivateProfileSection IN WIN32API STRING, STRING, STRING
      DECLARE LONG GetLastError             IN WIN32API
   ENDPROC
ENDDEFINE

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 23/6/2009, 17:49

Esta função verifica se sua aplicação está em uso pelo sistema.

Código:
FUNCTION sistemaEmUso
   LOCAL lcoldcaption
   LOCAL lnhwnd

   lcoldcaption = _SCREEN.CAPTION
   _SCREEN.CAPTION = SYS(3)

   DECLARE INTEGER FindWindow IN Win32API STRING, STRING

   DECLARE INTEGER BringWindowToTop IN Win32API INTEGER

   DECLARE INTEGER SendMessage IN Win32API INTEGER, INTEGER, INTEGER, INTEGER

   lnhwnd = findwindow(0, lcoldcaption)
   _SCREEN.CAPTION = lcoldcaption

   IF (lnhwnd > 0) THEN
      bringwindowtotop(lnhwnd)
      sendmessage(lnhwnd, 274, 61488, 0)
      RETURN .F.
   ENDIF

   RETURN .T.
ENDFUNC

Como utilizar?

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

SET PROCEDURE TO "caminhoDoArquivo\sistemaEmUso.PRG" ADDITIVE

IF  !sistemaEmUso() THEN
   QUIT   
ELSE
   *!* Prossiga com o seu código que torna o sistema funcional.
ENDIF

Nota:
Se sua aplicação estiver rodando, mas não minimizada, então ela virá para frente dos outros programas.
Não consegui melhorá-la para trazer uma aplicação minimizada.

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 24/6/2009, 18:04

Retorna o nome da impressora padrão:
Código:
?getprinterdefault()

FUNCTION getprinterdefault AS STRING
   LOCAL cursorimpressoras AS STRING
   m.cursorimpressoras = SYS(2015)

   APRINTERS(gaprinters, 1)
   CREATE CURSOR (m.cursorimpressoras) (caminho c(50), porta c(50), nomeimp c(50), COMMEN c(50))
   INSERT INTO (m.cursorimpressoras) FROM ARRAY gaprinters
   SELECT (m.cursorimpressoras)
   GO TOP

   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 nomeimp FROM (m.cursorimpressoras) ;
      WHERE caminho = ALLTRIM(cprinter) INTO ARRAY impbusca
   USE IN SELECT(m.cursorimpressoras)

   RETURN impbusca
ENDFUNC
Adaptada do link abaixo:
[Você precisa estar registrado e conectado para ver este link.]

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 26/6/2009, 11:48

Valida Inscrição Estadual
Código:
FUNCTION inscricaoestadual
      PARAMETER ie, uf
      LOCAL inscvalida AS logical
      m.ie = IIF(EMPTY(m.ie), "", m.ie)
      m.uf = IIF(EMPTY(m.uf), "", m.uf)

      DECLARE INTEGER consisteinscricaoestadual  ;
         IN SYS(5) + CURDIR() + "DllInscE32.DLL"  ;
         STRING, STRING

      m.ie = STRTRAN(m.ie, '.', '')
      m.ie = STRTRAN(m.ie, '-', '')
      m.ie = STRTRAN(m.ie, '/', '')
      m.ie = STRTRAN(m.ie, ',', '')
      m.ie = STRTRAN(m.ie, 'ME','')
      m.ie = STRTRAN(m.ie, ' ', '')
      m.ie = STRTRAN(m.ie, 'P', '')
      m.ie = ALLTRIM(m.ie)

      m.inscvalida = (consisteinscricaoestadual(m.ie, m.uf) = 0)
      CLEAR DLLS  'CONSISTEINSCRICAOESTADUAL'

      RETURN m.inscvalida
ENDFUNC

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

Link para download da DllInscE32.DLL:
[Você precisa estar registrado e conectado para ver este link.]

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem 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

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem 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

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem 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


Última edição por Marcos Guedes em 18/9/2009, 13:28, editado 2 vez(es)

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem 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.]

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem 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.]


Última edição por Marcos Guedes em 19/8/2009, 11:33, editado 2 vez(es)

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem 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.]

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

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

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

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem 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.]

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem 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

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem 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.

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

Página 1 de 4 1, 2, 3, 4  Seguinte

Ver o tópico anterior Ver o tópico seguinte Voltar ao Topo


 
Permissão deste fórum:
Você não pode responder aos tópicos neste fórum