Clique abaixo para nos ajudar
Login

Esqueci minha senha

Estamos no Facebook
Buscar
 
 

Resultados por:
 


Rechercher Busca avançada

Quem está conectado
30 usuários online :: Nenhum usuário registrado, Nenhum Invisível e 30 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
Como preencher campos vazios

9/2/2017, 11:55 por Linghston

Pessoal boa tarde,

É o seguinte, eu preciso preencher os campos de uma coluna da tabela DBF que …

Comentários: 2

Enviar msg para WhatsAPP via VFP

7/2/2017, 10:31 por Eliana

Olá Pessoal!

Alguém sabe se é possível enviar mensagem para o WhatsAPP via VFP?


Grata


Comentários: 0

Tudo dá errado

3/2/2017, 16:50 por Douglas Pascini

Troquei de maquina, achei que seria uma boa, [Você precisa estar registrado e conectado para ver esta imagem.]  pois passei para uma maquina melhor.

Instalei o …

Comentários: 1

URGENTE - Instalação do aplicativo

24/1/2017, 08:51 por Douglas Pascini

Bom dia. Estou com um problema, ao fazer a instalação (colocar os arquivo) do aplicativo na …

Comentários: 0

USAR REPORT FORM

30/12/2016, 09:06 por AJC

Pessoal bom dia,
Estou com um grande problema, já pesquisei muita coisa sobre report form, mas o …

Comentários: 3

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

Os nossos membros postaram um total de 21 mensagens em 12 assuntos

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

Página 2 de 4 Anterior  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

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://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 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

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: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

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: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

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

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

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 23/7/2009, 15:04

Verifica se uma aplicação está em execução:
Código:
*!* Verifica se o Antivirus está ativo!
?verificarAPP("Symantec Antivirus")

FUNCTION verificarAPP
  LPARAMETERS captionAPP
  LOCAL emUso as Logical

  DECLARE INTEGER FindWindow IN Win32api STRING, STRING
  m.emUso = findwindow(NULL, m.captionAPP)

  IF (m.emUso != 0) THEN
      RETURN .T.
  ELSE
      RETURN .F.
  ENDIF
ENDFUNC

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 23/7/2009, 16:28

Rotina para manipular barra de tarefas do windows:

Exemplo de uso
Código:
m.obj = NEWOBJECT("taskbar")
m.obj.enabledtaskbar(.F.) && Desabilita a barra de tarefas
m.obj.enabledtaskbar(.T.) && Habilita a barra de tarefas
m.obj.hidetaskbar() && Esconde a barra de ferramentas
m.obj.showtaskbar() && Exibe a barra de ferramentas
m.obj = null

Código Fonte:
Código:
#DEFINE toggle_hidewindow 128
#DEFINE toggle_unhidewindow 64

DEFINE CLASS taskbar AS CUSTOM

   PROCEDURE enabledtaskbar AS void
      LPARAMETERS ll_enab AS logical
      *!* ll_enab = .T. -> Habilitado
      *!* ll_enab = .F. -> Desabilitado
      
      =enablewindow(findwindowex(0, 0, "Shell_TrayWnd", .NULL.), m.ll_enab)
      =enablewindow(findwindowex(0, 0, "Button", .NULL.), m.ll_enab)
   ENDPROC

   PROCEDURE hidetaskbar as VOID
      LOCAL lnhwnd as Integer
      m.lnhwnd = findwindowa('Shell_traywnd', '')

      *!* Ocultar a barra de tarefas
      IF (m.lnhwnd <> 0) THEN
         setwindowpos(m.lnhwnd, 0, 0, 0, 0, 0, toggle_hidewindow)
      ENDIF
   ENDPROC

   PROCEDURE showtaskbar as VOID
      LOCAL lnhwnd as Integer
      m.lnhwnd = findwindowa('Shell_traywnd', '')

      *!* Mostrar a barra de tarefas
      IF (m.lnhwnd != 0) THEN
         setwindowpos(m.lnhwnd, 0, 0, 0, 0, 0, toggle_unhidewindow)
      ENDIF
   ENDPROC

   HIDDEN PROCEDURE INIT AS void
      THIS.declarar()
   ENDPROC

   HIDDEN PROCEDURE declarar AS void
      DECLARE INTEGER FindWindowA IN Win32API STRING lpClassName, STRING lpWindowName
      DECLARE INTEGER SetWindowPos IN Win32API INTEGER HWND, INTEGER hwndInsertAfter, INTEGER x, INTEGER Y, INTEGER cx, INTEGER cy, INTEGER wFlags
      DECLARE INTEGER FindWindowEx IN user32.DLL LONG, LONG, STRING, STRING
      DECLARE INTEGER EnableWindow IN user32.DLL LONG, LONG
   ENDPROC

ENDDEFINE

Fontes originais:
[Você precisa estar registrado e conectado para ver este link.]
[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 23/7/2009, 17:07

Modificando a resolução da tela:
Código:
*!* Autor: Alexandre Hédréville
*!* Modifica a resolução
*!* Syntax: ChangeRes(tnWidth, tnHeight)
*!* retorna: llRetVal
*!* Parametros: tnWidth, tnHeight
*!* tnWidth largura em pixels
*!* tnHeight altura em pixels

changeres(1280, 1024)

FUNCTION changeres
   LPARAMETERS tnwidth, tnheight
   LOCAL lnwidth, lnheight, lnmodenum, lcdevmode

   lnmodenum = 0
   lcdevmode = REPLICATE(CHR(0), 156)
   lnwidth = IIF(EMPTY(tnwidth), 800, tnwidth)
   lnheight = IIF(EMPTY(tnheight), 600, tnheight)

   *!* Instrucciones DECLARE DLL para cambiar resolución
   DECLARE INTEGER EnumDisplaySettings IN Win32API ;
      STRING lpszDeviceName,;
      INTEGER iModeNum, ;
      STRING @lpDevMode

   DECLARE INTEGER ChangeDisplaySettings IN Win32API STRING @lpDevMode, INTEGER dwFlags

   *!* Bucle para obtener todos los modos disponibles
   DO WHILE enumdisplaysettings(NULL, lnmodenum, @lcdevmode) <> 0
      lnmodenum = lnmodenum +1
   ENDDO

   *!* Configurar la structura DevMode
   lcdevmode = STUFF(lcdevmode, 41, 4, longtostr(1572864))
   lcdevmode = STUFF(lcdevmode, 109, 4, longtostr(tnwidth)) && Ancho
   lcdevmode = STUFF(lcdevmode, 113, 4, longtostr(tnheight)) && Alto

   *!* Cambiar resolucion
   changedisplaysettings(@lcdevmode, 1)
ENDFUNC

FUNCTION longtostr
   LPARAMETERS lnlongval
   LOCAL lncnt, lcretstr
   lcretstr = ''
   FOR lncnt = 24 TO 0 STEP -8
      lcretstr = CHR(INT(lnlongval/(2^lncnt))) + lcretstr
      lnlongval = MOD(lnlongval, (2^lncnt))
   NEXT
   RETURN lcretstr
ENDFUNC

Fonte original:
[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 23/7/2009, 17:58

Função para "desligar" o windows:
Código:
PROCEDURE desligar AS void
   LPARAMETERS acao AS INTEGER
   DECLARE INTEGER ExitWindowsEx IN "user32.dll" INTEGER uFlags, INTEGER dwReserved
   = exitwindowsex(0,0)
ENDPROC

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 24/7/2009, 14:18

Listando serviços do windows:
Código:
CREATE CURSOR servicos (cname c(50), cstartname c(50), cstate c(20))
   
objwmi = GETOBJECT("winmgmts:\\")
ccadwmi = "Select * From Win32_Service"
oserv = objwmi.execquery(ccadwmi)
   
FOR EACH objservi IN oserv
   INSERT INTO servicos (cname, cstartname, cstate) VALUES (objservi.NAME, objservi.startname, objservi.State)
NEXT

SELECT("servicos")
BROWSE
USE IN SELECT("servicos")

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 28/7/2009, 12:39

Retorna data e hora do servidor:

Encontrei esta função no link [Você precisa estar registrado e conectado para ver este link.]
Fiz uma pequena modificação para se ajustar ao fuso horário GTM(-03:00)-Brasília.
Havendo qualquer problema em utilizá-la, favor criar um novo tópico para discussão.

Como usar:
Código:
LOCAL obj as Object
m.obj = NEWOBJECT("dataserver")
?m.obj.serverdate("192.168.254.28")
m.obj = null

Código Fonte:
Código:
DEFINE CLASS dataserver AS CUSTOM
   *===========================================================================
   * Procedure..: ServerDate
   * Author.....: Mark Austen
   * Date.......: September 21, 2006
   * Parameters.: pcServerName - Name of server to get datetime from
   * Returns....: Datetime, current datetime on specified server.
   * Abstract...: Retrieve the datetime from a specified server. If the server
   * ...........: cannot be contacted, this routine returns the current
   * ...........: datetime from the local PC
   *===========================================================================
   *
   FUNCTION serverdate AS DATE
      *
      LPARAMETERS ;
         pcservername AS STRING
      *
      LOCAL                            ;
         lcoutputbuffer  AS STRING  , ;
         lcservername    AS STRING  , ;
         lndaylightsaving AS INTEGER  , ;
         lnelapsed        AS INTEGER  , ;
         lninputbuffer    AS INTEGER  , ;
         lnresult        AS INTEGER  , ;
         ltserver        AS DATETIME
      *
      DECLARE INTEGER NetRemoteTOD IN netapi32 ;
         STRING @, ;
         INTEGER @
      *
      DECLARE INTEGER RtlMoveMemory IN win32api ;
         STRING @, ;
         INTEGER , ;
         INTEGER
      *
      lcoutputbuffer = REPLICATE( CHR(0), 48 )
      lninputbuffer  = 0
      *
      lcservername = STRCONV( pcservername, 5 ) + CHR(0)
      lnresult    = netremotetod( @lcservername, @lninputbuffer )
      *
      IF lnresult = 0
         rtlmovememory( @lcoutputbuffer, lninputbuffer, 48 )
         *
      ELSE && lnResult = 0
         lcservername = STRCONV( [\\] + pcservername, 5 )
         lnresult    = netremotetod( @lcservername, @lninputbuffer )
         *
         IF lnresult = 0
            rtlmovememory( @lcoutputbuffer, lninputbuffer, 48 )
            *
         ENDIF && lnResult = 0
         *
      ENDIF && lnResult = 0
      *
      IF lnresult = 0
         lnelapsed        = this.strtolong( SUBSTR( lcoutputbuffer,  1, 4 ) )
         lndaylightsaving = this.getdaylightsaving()
         *
         *ltserver = {^1970-01-01 00:00:00} + lnelapsed - ( lndaylightsaving * 60 ) <<< Original
         ltserver = {^1970-01-01 00:00:00} + lnelapsed - ( 60*60*3 )

         *
      ELSE && lnResult = 0
         ltserver = DATETIME()
         *
      ENDIF && lnResult = 0
      *
      CLEAR DLLS [NetRemoteTOD]
      CLEAR DLLS [RtlMoveMemory]
      *
      RETURN ltserver
   ENDFUNC
   *
   *===========================================================================
   * End: ServerDate
   *===========================================================================
   *===========================================================================
   * Procedure..: GetDaylightSaving
   * Author.....: Mark Austen
   * Date.......: September 21, 2006
   * Parameters.: None
   * Returns....: Numeric, Difference in minutes between the local time and UTC
   * Abstract...: Get the daylight saving time in minutes.
   *===========================================================================
   *
   FUNCTION getdaylightsaving AS INTEGER
      *
      DECLARE INTEGER GetTimeZoneInformation IN kernel32 ;
         STRING @lpTimeZoneInformation
      *
      lctimezone = REPLICATE( CHR(0), 172 )
      lnid      = gettimezoneinformation( @lctimezone )
      lnbias    = this.strtodword( SUBSTR( lctimezone, 169, 4 ) )
      *
      CLEAR DLLS [GetTimeZoneInformation]
      *
      RETURN lnbias
   ENDFUNC
   *
   *===========================================================================
   * End: GetDaylightSaving
   *===========================================================================
   *===========================================================================
   * Procedure..: StrToLong
   * Author.....: Mark Austen
   * Date.......: September 21, 2006
   * Parameters.: pcLongString - String containing long data
   * Returns....: Numeric, Long number
   * Abstract...: Convert a string to a long integer.
   *===========================================================================
   *
   FUNCTION strtolong AS LONG
      *
      LPARAMETERS ;
         pclongstring
      *
      LOCAL ;
         lcstring AS STRING, ;
         lnretval AS INTEGER, ;
         lni AS INTEGER
      *
      lcstring = pclongstring
      lnretval = 0
      *
      FOR lni = 0 TO 24 STEP 8
         lnretval = lnretval + ( ASC( lcstring ) * ( 2^lni ) )
         lcstring = SUBSTR( lcstring, 2 )
         *
      NEXT && lnI
      *
      RETURN lnretval
   ENDFUNC
   *
   *===========================================================================
   * End: StrToLong
   *===========================================================================
   *===========================================================================
   * Procedure..: StrToWord
   * Author.....: Mark Austen
   * Date.......: September 21, 2006
   * Parameters.: pcDWordString - String containing DWord data
   * Returns....: Numeric, word data
   * Abstract...: Convert a string to a DWord.
   *===========================================================================
   *
   FUNCTION strtodword AS INTEGER
      *
      LPARAMETERS ;
         pcdwordstring AS STRING
      *
      lnretval ;
         =            ASC( SUBSTR( pcdwordstring, 1, 1 ) )      ;
         + BITLSHIFT( ASC( SUBSTR( pcdwordstring, 2, 1 ) ),  8 ) ;
         + BITLSHIFT( ASC( SUBSTR( pcdwordstring, 3, 1 ) ), 16 ) ;
         + BITLSHIFT( ASC( SUBSTR( pcdwordstring, 4, 1 ) ), 24 )
      RETURN lnretval
   ENDFUNC
ENDDEFINE

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 5/8/2009, 14:40

Lendo o formato de data do windows: (Acessando o registro)
Código:
?getdateformat()

FUNCTION getdateformat AS STRING
   LOCAL objshell AS OBJECT
   LOCAL cformat AS STRING
   m.objshell = NEWOBJECT("WScript.Shell")
   m.cformat = m.objshell.regread("HKEY_CURRENT_USER\Control Panel\International\sShortDate")
   objshell = NULL
   RETURN m.cformat
ENDFUNC

_________________
Marcos Guedes - Programador e desenvolvedor Web.


Visite o nosso portal:
[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 6/8/2009, 11:27

Alterando o Papel de Parede do Windows:
Código:
DECLARE INTEGER SystemParametersInfo IN "user32";
   LONG uAction, LONG uParam, STRING lpvParam, LONG fuWinIni

lffile = GETPICT()

IF !EMPTY(lffile)
   = systemparametersinfo(20, 0,lffile, 1)
ENDIF

Fonte: (Postado por Sergio)
[Você precisa estar registrado e conectado para ver este link.]

_________________
Marcos Guedes - Programador e desenvolvedor Web.


Visite o nosso portal:
[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 6/8/2009, 17:47

Abrindo e/ou fechando a unidade de CD:
Código:
abrir_cd(.F.)

PROCEDURE abrir_cd AS void
   LPARAMETERS l_abrir AS logical

   DECLARE INTEGER mciSendString IN  ;
      WINMM.DLL STRING, STRING, INTEGER, INTEGER

   IF (m.l_abrir = .T.) THEN
      mcisendstring('set cdaudio door open wait', "", 0, 0)
   ELSE
      mcisendstring("set cdaudio door closed", "", 0, 0)
   ENDIF
ENDPROC

_________________
Marcos Guedes - Programador e desenvolvedor Web.


Visite o nosso portal:
[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 6/8/2009, 22:48

Valida CNPJ:
Código:
?procnpj("42021905000198")
FUNCTION validarCNPJ AS void
   * 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.
ENDFUNC

_________________
Marcos Guedes - Programador e desenvolvedor Web.


Visite o nosso portal:
[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 6/8/2009, 22:52

Valida CPF:
Código:
?validaCPF("54232191755")
FUNCTION validaCPF
   * 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

_________________
Marcos Guedes - Programador e desenvolvedor Web.


Visite o nosso portal:
[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/8/2009, 22:00

Retorna a posição do mouse na tela:
Código:
CLEAR
LOCAL nx as Integer
LOCAL ny as Integer
posicaomouse(@nx, @ny)
?nx
?ny
PROCEDURE posicaomouse AS void
   LPARAMETERS nx AS INTEGER, nY AS INTEGER
   DECLARE INTEGER GetCursorPos IN user32 STRING @ lpPoint
   LOCAL lcbuffer
   lcbuffer = REPLI(CHR(0), 8)
   = getcursorpos (@lcbuffer)
   nx = CTOBIN(SUBSTR(lcbuffer, 1,4),"4rs")
   nY = CTOBIN(SUBSTR(lcbuffer, 5,4),"4rs")
ENDPROC

_________________
Marcos Guedes - Programador e desenvolvedor Web.


Visite o nosso portal:
[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/8/2009, 22:07

Habilitar/Desabilitar a tecla PrintScreen:
Código:
teclaprintscreen(.F.)
teclaprintscreen(.T.)
PROCEDURE teclaprintscreen AS void
   LPARAMETERS habilitar AS logical
   #DEFINE vk_printscreen 0x2c
   
   IF (m.habilitar) THEN
      DECLARE INTEGER UnregisterHotKey IN user32;
         INTEGER HWND,INTEGER ID
      unregisterhotkey(_SCREEN.HWND, 0)
   ELSE
      DECLARE INTEGER RegisterHotKey IN user32;
         INTEGER HWND,INTEGER ID,;
         INTEGER fsModifiers, INTEGER vk

      registerhotkey(_SCREEN.HWND, 0, 0,vk_printscreen)
   ENDIF
ENDPROC
Obs: Não fui eu quem fiz!

_________________
Marcos Guedes - Programador e desenvolvedor Web.


Visite o nosso portal:
[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 12/8/2009, 17:30

Retorna a aplicação default para um determinado tipo de arquivo:
Código:
* FindExec.prg
*
* This example demonstrates Visual FoxPro and FPW2.6 code to find the
* location of Word for Windows based on a file association.
*
* A file with the specific association must already exist for
* FindExecutable to work correctly. Therefore, the sample creates
* a fictitious file with a .DOC extension.
*
* If an association is not present, FindExecutable will
* return an empty string.

* Modify this string to SAMPLE.XLS to find the path to Excel.
CLEAR
lcsampledoc = "SAMPLE.DOC"
lihandle = FCREATE(lcsampledoc)
=FCLOSE(lihandle)

lpfile = lcsampledoc
lpdirectory = ''
lpresults = SPACE(128)

* Any VFP version.
IF ("VISUAL FOXPRO" $ UPPER(VERSION()))
   DECLARE INTEGER FindExecutable IN SHELL32 ;
      STRING@lpFile, STRING@lpDirectory, ;
      STRING @lpResults

   lireturnvalue = findexecutable(@lpfile, @lpdirectory,@lpresults)

ELSE
   * FPW 2.x version.
   SET LIBRARY TO HOME() + "foxtools.fll"
   lffindexe = regfn("FindExecutable", "@C@C@C", "I", ;
      "SHELL.DLL")

   lireturnvalue = callfn(lffindexe, @lpfile, @lpdirectory, @lpresults)
ENDIF

* Interpret the return code.
DO CASE
   CASE lireturnvalue = 0
      ? "FindExecutable failed: Out of memory or resources"
   CASE lireturnvalue = 31
      ? "FindExecutable failed: No association for file type"
   CASE lireturnvalue = 2
      ? "FindExecutable failed: Specified file not found"
   CASE lireturnvalue = 3
      ? "FindExecutable failed: Specified path not found"
   CASE lireturnvalue = 11
      ? "FindExecutable failed: Invalid EXE format"
   OTHERWISE
      * Read out to the null terminator.
      lpresults = LEFT(lpresults, AT(CHR(0), lpresults) - 1)
      ? "Full path of application: " + lpresults
ENDCASE

* Delete the dummy file you created.
DELETE FILE (lcsampledoc)
Fonte:
[Você precisa estar registrado e conectado para ver este link.]

_________________
Marcos Guedes - Programador e desenvolvedor Web.


Visite o nosso portal:
[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 12/8/2009, 17:48

abrindo programas com winexec:
Código:
?winexec_app("calc.exe")
?winexec_app("mspaint.exe")
?winexec_app("explorer.exe")

FUNCTION winexec_app AS INTEGER
   LPARAMETERS fileexe AS STRING
   DECLARE INTEGER WinExec IN kernel32;
      STRING cCmdLine,;
      INTEGER nCmdShow

   RETURN winexec(m.fileexe, 1)
ENDFUNC

_________________
Marcos Guedes - Programador e desenvolvedor Web.


Visite o nosso portal:
[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 13/8/2009, 15:03

Verifica qual botão do mouse foi pressionado:
Código:
CLEAR
DECLARE INTEGER GetAsyncKeyState IN user32 INTEGER vKey
DECLARE INTEGER GetKeyState IN user32 INTEGER vKey
DECLARE INTEGER SetKeyboardState IN user32 STRING @lpKeyState

#DEFINE vk_lbutton 1
#DEFINE vk_rbutton 2

LOCAL cbuffer, nindex, lstop
lstop = .F.
cbuffer = REPLICATE(CHR(0), 256)

= setkeyboardstate(@cbuffer)

DO WHILE NOT lstop
   DOEVENTS
   IF getkeystate(vk_lbutton) <> 0
      ? "Botón izquierda presionado"
      EXIT
   ENDIF

   IF getkeystate(vk_rbutton) <> 0
      ? "Botón derecho presionado"
      EXIT
   ENDIF
ENDDO

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

_________________
Marcos Guedes - Programador e desenvolvedor Web.


Visite o nosso portal:
[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 14/9/2009, 11:48

Pegando a Hora atual a partir de um site:
Código:
FUNCTION retornahora AS STRING
   LOCAL loxmlhttp AS "MSXML2.IXMLHTTPREQUEST"
   loxmlhttp = NEWOBJECT("MSXML2.XMLHTTP.4.0")
   loxmlhttp.OPEN("GET","http://pcdsh01.on.br/HoraLegalBrasileira.asp",.F.)
   loxmlhttp.SEND()

   LOCAL filtro AS STRING
   m.filtro = STREXTRACT(loxmlhttp.responsetext,[<TD ALIGN="CENTER" BGCOLOR=#ffcc66><B>],"</B></TD>")

   RETURN GETWORDNUM(m.filtro,2)
ENDFUNC
Obs: Adaptei de uma função postada pelo colega Sergio Figueiredo no Grupo Fox Brasil

_________________
Marcos Guedes - Programador e desenvolvedor Web.


Visite o nosso portal:
[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 15/9/2009, 13:06

Obtendo informações da Barra de Tarefa (TaskBar) do Windows:
Código:
*!* Fonte Original: http://www.vfpbrasil.com.br/modules/newbb/viewtopic.php?post_id=6570
*!* Adaptado por Marcos Guedes

CLEAR

obj = NEWOBJECT("taskbarwindows")
?"Width:"
??obj.getwidth()
?"Height:"
??obj.getheight()
?"Left:"
??obj.getleft()
?"Right:"
??obj.getright ()
?"Top:"
??obj.gettop()
?"Bottom:"
??obj.getbottom()
?"Location (Int):"
??obj.getintlocation()
?"Location (Str):"
??obj.getstrlocation()

DEFINE CLASS taskbarwindows AS CUSTOM

   HIDDEN ntaskbarright AS INTEGER
   HIDDEN ntaskbarlocation AS INTEGER
   HIDDEN ntaskbarleft AS INTEGER
   HIDDEN ntaskbartop AS INTEGER
   HIDDEN ntaskbarbottom AS INTEGER

   FUNCTION getwidth AS INTEGER
      *!* Retorna a largura da barra de tarefa
      RETURN INT(THIS.ntaskbarright - THIS.ntaskbarleft)
   ENDFUNC

   FUNCTION getheight AS INTEGER
      RETURN INT(THIS.ntaskbarbottom - THIS.ntaskbartop)
   ENDFUNC

   FUNCTION getleft AS INTEGER
      RETURN INT(THIS.ntaskbarleft)
   ENDFUNC

   FUNCTION getright AS INTEGER
      RETURN INT(THIS.ntaskbarright)
   ENDFUNC

   FUNCTION gettop AS INTEGER
      RETURN INT(THIS.ntaskbartop)
   ENDFUNC

   FUNCTION getbottom AS INTEGER
      RETURN INT(THIS.ntaskbarbottom)
   ENDFUNC

   FUNCTION getintlocation AS INTEGER
      RETURN THIS.ntaskbarlocation
   ENDFUNC

   FUNCTION getstrlocation AS STRING
      DO CASE
         CASE (THIS.ntaskbarlocation=0)
            RETURN "BOTTOM"
         CASE (THIS.ntaskbarlocation=1)
            RETURN "LEFT"
         CASE (THIS.ntaskbarlocation=2)
            RETURN "TOP"
         CASE (THIS.ntaskbarlocation=3)
            RETURN "RIGHT"
         OTHERWISE
            RETURN ""

      ENDCASE
   ENDFUNC

   HIDDEN PROCEDURE INIT AS void
      LOCAL ntaskbarleft AS INTEGER
      LOCAL ntaskbartop AS INTEGER
      LOCAL ntaskbarright AS INTEGER
      LOCAL ntaskbarbottom AS INTEGER

      m.ntaskbarleft = 0
      m.ntaskbartop = 0
      m.ntaskbarright = 0
      m.ntaskbarbottom = 0

      THIS.ntaskbarlocation = THIS.taskbar(@ntaskbarleft, @ntaskbartop, @ntaskbarright, @ntaskbarbottom)

      THIS.ntaskbarright = m.ntaskbarright
      *   this.ntaskbarlocation AS INTEGER
      THIS.ntaskbarleft = m.ntaskbarleft
      THIS.ntaskbartop = m.ntaskbartop
      THIS.ntaskbarbottom = m.ntaskbarbottom
   ENDPROC

   HIDDEN PROCEDURE taskbar
      LPARAMETERS nleft, ntop, nright, nbottom
      LOCAL cappbardata, nreturn

      #DEFINE abm_gettaskbarpos 5

      DECLARE INTEGER SHAppBarMessage ;
         IN "shell32.dll" ;
         AS WinAPI_SHAppBarMessage ;
         INTEGER dwMessage, ;
         STRING @ PAPPBARDATA

      cappbardata = THIS.inttostr(0)
      cappbardata = cappbardata + THIS.inttostr(0)
      cappbardata = cappbardata + THIS.inttostr(0)
      cappbardata = cappbardata + REPL(CHR(0), 4*4)
      cappbardata = cappbardata + THIS.inttostr(0)
      cappbardata = THIS.inttostr(LEN(cappbardata) + 4) + cappbardata

      nreturn = winapi_shappbarmessage(abm_gettaskbarpos, @cappbardata)
      nleft = THIS.strtoint(SUBS(cappbardata, 17, 4))
      IF nleft > 16777215
         nleft = 0 - (4294967295 - nleft)
      ENDIF

      ntop = THIS.strtoint(SUBS(cappbardata, 21, 4))
      IF ntop > 16777215
         ntop = 0 - (4294967295 - ntop)
      ENDIF

      nright = THIS.strtoint(SUBS(cappbardata, 25, 4))
      IF nright > 16777215
         nright = 0 - (4294967295 - nright)
      ENDIF

      nbottom = THIS.strtoint(SUBS(cappbardata, 29, 4))
      IF nbottom > 16777215
         nbottom = 0 - (4294967295 - nbottom)
      ENDIF

      DO CASE
         CASE nleft < 2 AND ntop < 2 AND nright < 479
            RETURN( 1 )
         CASE nleft < 2 AND ntop > 0
            RETURN( 0 )
         CASE nleft < 2 AND ntop < 2
            RETURN( 2 )
         OTHERWISE
            RETURN( 3 )
      ENDCASE
   ENDPROC

   HIDDEN PROCEDURE inttostr
      LPARAMETERS xint
      RETURN(CHR(BITAND(xint, 255)) + CHR(BITAND(BITRSHIFT(xint, 8), 255)) + ;
         CHR(BITAND(BITRSHIFT(xint, 16), 255)) + CHR(BITAND(BITRSHIFT(xint, 24), 255)))
   ENDPROC

   HIDDEN PROCEDURE strtoint
      LPARAMETERS cword, nbytes
      IF PCOUNT() < 2
         nbytes = 4
      ENDIF
      LOCAL nreturn, ncurbyte
      nreturn = 0
      FOR ncurbyte = 1 TO nbytes
         nreturn = nreturn + ASC(SUBS(cword, ncurbyte, 1))*(256^(ncurbyte-1))
      ENDFOR
      RETURN( nreturn )
   ENDPROC

ENDDEFINE

_________________
Marcos Guedes - Programador e desenvolvedor Web.


Visite o nosso portal:
[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 19/9/2009, 09:58

Pegando a Data atual a partir de um site:
Código:
FUNCTION retornaData AS STRING
  LOCAL loxmlhttp AS "MSXML2.IXMLHTTPREQUEST"
  loxmlhttp = NEWOBJECT("MSXML2.XMLHTTP.4.0")
  loxmlhttp.OPEN("GET","http://pcdsh01.on.br/HoraLegalBrasileira.asp",.F.)
  loxmlhttp.SEND()

  LOCAL filtro AS STRING
  m.filtro = STREXTRACT(loxmlhttp.responsetext,[<TD ALIGN="CENTER" BGCOLOR=#ffcc66><B>],"</B></TD>")

  RETURN GETWORDNUM(m.filtro,1)
ENDFUNC
Obs: Adaptei de uma função postada pelo colega Sergio Figueiredo no Grupo Fox Brasil

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

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

Mensagem por Marcos Guedes em 19/9/2009, 10:06

Verificando conexão com a internet:
Código:
FUNCTION conectado as logical
   DECLARE LONG InternetGetConnectedState IN "wininet.dll"  LONG, LONG

   IF internetgetconnectedstate(0, 0) = 1
      RETURN .T.
   ELSE
      RETURN .F.
   ENDIF
ENDFUNC

Marcos Guedes
Webmaster
Webmaster


Voltar ao Topo Ir em baixo

Página 2 de 4 Anterior  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