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

[Marcos Guedes]

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

[Marcos Guedes]

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]

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]

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

[Marcos Guedes]

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]

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

[Marcos Guedes]

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

[Marcos Guedes]

Decimal para Hexadecimal

Código:

FUNCTION decimalToHexa
    LPARAMETERS numeroDecimal
    RETURN Transform(m. numeroDecimal, '@0x')
ENDFUNC

[Marcos Guedes]

Hexadecimal para Decimal

Código:

FUNCTION hexaToDecimal
    LPARAMETERS numeroHexa AS STRING
    RETURN EVALUATE(m. numeroHexa)
ENDFUNC

[Marcos Guedes]

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]

Abrindo links com o navegador padrão:

Código:

open_page("http://[Você precisa estar registrado e conectado para ver este link.]

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]

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]

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]

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]

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