ATOUTFOX
COMMUNAUTÉ FRANCOPHONE DES PROFESSIONNELS FOXPRO
Visual FoxPro : le développement durable

transfert ftp web vers local et local vers web avec un thermomètre   


L'auteur

eric leissler
France France
Membre Simple
# 0000002784
enregistré le 06/03/2010
http://www.aumeric.fr
67 ans
LEISSLER Eric
85290 MORTAGNE SUR SEVRE
de la société AUMERIC LOGICIELS
Fiche personnelle

Note des membres
20/20
2 votes

Contributions > 01 - PRG : Programmation

transfert ftp web vers local et local vers web avec un thermomètre
# 0000000292
ajouté le 21/02/2006 12:03:00 et modifié le 01/06/2012
consulté 13176 fois
Niveau initié

Version(s) Foxpro :
VFP 9.0
VFP 8.0
VFP 7.0
VFP 6.0

Le téléchargement des pièces jointes est limité aux membres
Veuillez vous identifier ou vous inscrire si vous n'avez pas encore de compte ...
Description

Bonjour à toutes et à tous

Merci à anatole je me suis basé sur sa classe


Bien voila c'est fait et cela fonctionne. Un grand merci à Grégory
Pour envoyer un fichier vers le web :
local_vers_web (fichiersurleweb,fichieraenvoyer)

pour recevoir un fichier du web
web_vers_local(fichierarecevoirenlocal,fichiersurleweb)

Tout est dans le zip joint

Bonne journée à toutes et à tous

Code source :
FUNCTION LOCAL_VERS_WEB(ficsurleweb,ficaenvoyer)
retour=.f.
*--------------------------------------------------------------------------*
* FTP
* Classe pour le transfert FTP
*--------------------------------------------------------------------------*

#DEFINE INTERNET_INVALID_PORT_NUMBER   0
#DEFINE INTERNET_OPEN_TYPE_DIRECT      1
#DEFINE INTERNET_SERVICE_FTP           1
#DEFINE FTP_TRANSFER_TYPE_ASCII        1
#DEFINE FTP_TRANSFER_TYPE_BINARY       2
#DEFINE INTERNET_FLAG_NEED_FILE       16
#DEFINE FILE_ATTRIBUTE_DIRECTORY      16
#DEFINE GENERIC_READ    2147483648   && &H80000000
#DEFINE GENERIC_WRITE   1073741824   && &H40000000

objet=createobject("ftp")
toto=objet.CONNEXION(maconnexion,mon_loing,mon_motdepasse)
if toto
     objet.changerepertoire("www/transfert")
*!*       objet.EnvoyerFichier("c:\aumeric\temp\totototo.txt","creat.txt")
     fd_ftp=objet.OuvrirFichier(ficsurleweb,.t.)


  quel= objet.misjour_ftp_vers_WEB( ficsurleweb, ficaenvoyer )
  if quel
    messagebox("L'envoi du fichier "+ ficaenvoyer + " a réussi" )
  else
     messagebox("L'envoi du fichier "+ ficaenvoyer + "n' a pas réussi" )
  endif
  retour=quel
  objet.destroy()
else
  messagebox("La connexion n'a pas réussi, assurez vous d'avoir une connexion internet en cours ")
endif
release objet

return retour






*-------------------------------------



FUNCTION WEB_VERS_LOCAL(ficaenvoyer,ficsurleweb)
retour=.f.
*--------------------------------------------------------------------------*
* FTP
* Classe pour le transfert FTP
* Ecrit par anatole
* modifié par aumeric
*--------------------------------------------------------------------------*

#DEFINE INTERNET_INVALID_PORT_NUMBER   0
#DEFINE INTERNET_OPEN_TYPE_DIRECT      1
#DEFINE INTERNET_SERVICE_FTP           1
#DEFINE FTP_TRANSFER_TYPE_ASCII        1
#DEFINE FTP_TRANSFER_TYPE_BINARY       2
#DEFINE INTERNET_FLAG_NEED_FILE       16
#DEFINE FILE_ATTRIBUTE_DIRECTORY      16
#DEFINE GENERIC_READ    2147483648   && &H80000000
#DEFINE GENERIC_WRITE   1073741824   && &H40000000

objet=createobject("ftp")
toto=objet.CONNEXION(ma connextion,mon login,mon  motdepasse)
if toto
     objet.changerepertoire("www/transfert")
*!*    objet.prendrefichier("eteocle.exe","c:\testeteocele.exe")

   fd_ftp=objet.OuvrirFichier(ficsurleweb)
   taillefic=FtpGetFileSize(fd_ftp, .F.)

  quel= objet.misjour_ftp_vers_local(ficsurleweb,ficaenvoyer)
  if quel
    messagebox("L'envoi du fichier "+ ficaenvoyer + " a réussi" )
  else
     messagebox("L'envoi du fichier "+ ficaenvoyer + "n' a pas réussi" )
  endif
  retour=quel
  objet.destroy()
else
  messagebox("La connexion n'a pas réussi, assurez vous d'avoir une connexion internet en cours ")
endif
release objet

return retour





define class FTP as custom

  mOpen       = null && handle de l'ouverture internet
  mConnect    = null && handle de connexion au serveur FTP

  *--------------------------------------------------------------------------*
  procedure init()

    declare integer InternetOpen in wininet;
      string  sAgent,;
      integer lAccessType,;
      string sProxyName,;
      string sProxyBypass,;
      string lFlags

    declare integer InternetCloseHandle in wininet;
      integer hInet

    declare integer InternetConnect in wininet;
      integer hInternetSession,;
      string sServerName,;
      integer nServerPort,;
      string sUsername,;
      string sPassword,;
      integer lService,;
      integer lFlags,;
      integer lContext

    declare integer FtpFindFirstFile in wininet;
      integer hFtpSession,;
      string lpszSearchFile,;
      string @lpFindFileData,;
      integer dwFlags,;
      integer dwContent

    declare integer InternetFindNextFile in wininet;
        integer hFind,;
        string @lpvFindData

    declare integer FtpGetCurrentDirectory in wininet;
      integer hFtpSession,;
      string @lpszDirectory,;
      integer @lpdwCurrentDirectory

    declare integer FtpSetCurrentDirectory in wininet;
      integer hFtpSession,;
      string @lpszDirectory

    declare integer FtpOpenFile in wininet;
      integer hFtpSession,;
      string  sFileName,;
      integer lAccess,;
      integer lFlags,;
      integer lContext

    declare integer InternetReadFile in wininet;
      integer hFile,;
      string @lpBuffer,;
      integer dwNumberOfBytesToRead,;
      integer @lpdwNumberOfBytesRead

   declare integer InternetWriteFile in wininet;
      integer  hFile,;
      string @lpBuffer,;
      integer dwNumberOfBytesToWrite,;
      integer @lpdwNumberOfBytesWritten

    declare integer FtpGetFile in wininet;
      integer hFtpSession,;
      string  lpszRemoteFile,;
      string  lpszNewFile,;
      integer fFailIfExists,;
      integer dwFlagsAndAttributes,;
      integer dwFlags,;
      integer dwContext

    declare integer FtpPutFile in wininet;
      integer hConnect,;
      string  lpszLocalFile,;
      string  lpszNewRemoteFile,;
      integer dwFlags,;
      integer dwContext

    declare integer FtpDeleteFile in wininet;
      integer hConnect,;
      string  lpszFileName

    declare integer FtpCreateDirectory in wininet;
      integer hFtpSession,;
      string  lpszDirectory

    declare integer FtpRemoveDirectory in wininet;
      integer hFtpSession,;
      string  lpszDirectory

    declare integer FtpGetFileSize in wininet;
      integer   hFile,;
      integer @ lpdwFileSizeHigh

    declare integer FtpRenameFile in wininet;
      integer hFtpSession,;
      string  lpdzExisting,;
      string  lpdzNew

    declare integer FileTimeToSystemTime in kernel32;
      string @lpFileTime,;
      string @lpSystemTime




  endproc && init

  *--------------------------------------------------------------------------*
  *---> Se connecte au serveur FTP
  procedure Connexion(strHost, strUser, strPwd)
    with this
      .mOpen = InternetOpen ("vfp", INTERNET_OPEN_TYPE_DIRECT, 0, 0, 0)
      if .mOpen = 0
         return .F.
      endif
      .mConnect = InternetConnect (.mOpen, strHost,;
         INTERNET_INVALID_PORT_NUMBER,;
         strUser, strPwd, INTERNET_SERVICE_FTP, 0, 0)
      if .mConnect = 0
         = InternetCloseHandle (.mOpen)
         return .F.
      endif
      return .T.
    endwith
  endproc && Connect

  *--------------------------------------------------------------------------*
  *---> Fermeture de la connexion à la desctruction de l'objet
  procedure destroy()
    InternetCloseHandle(this.mOpen)
  endproc && destroy

  *--------------------------------------------------------------------------*
  *---> Renvoie le répertoire courant
  procedure RepertoireCourant()
  local v_directory, v_len
    v_directory = space(250)
    v_len = len(v_directory)
    if FtpGetCurrentDirectory (this.mConnect, @v_directory, @v_len) = 1
       return left(v_directory, v_len)
    else
       return ""
    endif
  endproc

  *--------------------------------------------------------------------------*
  procedure ChangeRepertoire(p_dir  )
    return FtpSetCurrentDirectory(this.mConnect, p_dir) > 0
  endproc && ChangeRepertoire

  *--------------------------------------------------------------------------*
  *---> Envoie un fichier sur le serveur
  procedure EnvoyerFichier(p_local ,;
                           p_remote )

    return FtpPutFile(this.mConnect, p_local, p_remote, FTP_TRANSFER_TYPE_BINARY, 0) > 0
  endproc && EnvoyerFichier

  *--------------------------------------------------------------------------*
  *---> Télécharge un fichier sur le serveur
  procedure PrendreFichier(p_remote  ,;
                           p_local  )
    return FtpGetFile(this.mConnect ,;
                     p_remote ,;
                     p_local ,;
                     1 ,; && échec si existe en local
                     FILE_ATTRIBUTE_DIRECTORY ,;
                     FTP_TRANSFER_TYPE_BINARY ,;
                     0) > 0
  endproc && PrendreFichier
*------------------------------------------------------------------------*
procedure misjour_ftp_vers_local (p_remote  , p_local  )

IF FILE(p_local)  && Le fichier existe-t-il?
   gnFichierErreur = FOPEN(p_local,12)     && Si oui, ouvrir en lecture/écriture
ELSE
   gnFichierErreur = FCREATE(p_local)  && Si non, le créer
ENDIF
IF gnFichierErreur < 0     && Recherche les erreurs à l'ouverture du fichier
   WAIT "Impossible d'ouvrir ou de créer le fichier de sortie" WINDOW NOWAIT
ELSE  && S'il n'y a pas d'erreur, écrire dans le fichier



#define FTPBUFSIZ_GET  (32*1024) && ou 4 * 1024, comme tu veux


local Success
  Success = .t.
   buf = space(FTPBUFSIZ_GET)  && tu peux mettre cette ligne et la suivante avant le do while
    BytesRead = 0
    n=0
    DO FORM ATTENTEMISEAJOUR with "Réception du fichier "+p_remote+" vers " +p_local
do while m.Success


   sts = InternetReadFile(fd_ftp, @m.Buf, FTPBUFSIZ_GET, @m.BytesRead)
  do case
   case empty(m.sts)
    assert .f.
    Success = .f.
   case empty(m.BytesRead)
    exit
   otherwise
    n = m.n + m.BytesRead
   endcase
  attentemiseajour.echelle(n,taillefic)
    aretourner=.t.
*   messagebox(alltrim(str(m.n)))

   do case
   case !m.Success

   case fwrite(gnFichierErreur , m.buf, m.BytesRead) <> m.BytesRead
    =MessageBox('local Write error', 16, m.this.Class)
    Success = .f.

   endcase

enddo

ENDIF
attentemiseajour.release()
=FCLOSE(gnFichierErreur )     && Ferme le fichier
return aretourner


*-------------------------------------------------------------

procedure misjour_ftp_vers_web (p_remote  , p_local  )

Local gnDescripteurFichier,nTaille,cchaine
gnDescripteurFichier = FOPEN(p_local)
* Recherche la fin du fichier pour déterminer le nombre d'octets contenu dans le fichier
nTaille =  FSEEK(gnDescripteurFichier, 0, 2)           && Déplace le pointeur à EOF
IF nTaille <= 0
   * Si le fichier est vide, affiche un message d'erreur
   WAIT WINDOW "Ce fichier est vide!" NOWAIT
ELSE
   * Si le fichier n'est pas vide, le programme stocke son contenu
   * en mémoire, puis affiche le texte dans la fenêtre principale de Visual FoxPro
   = FSEEK(gnDescripteurFichier, 0, 0)              && Déplace le pointeur à BOF
   *!* cchaine = FREAD(gnDescripteurFichier, nTaille)

ENDIF
= FCLOSE(gnDescripteurFichier)
*----
# define FTPBUFSIZ_PUT  (32*1024)

fd = fopen( p_local)
BytesWritten = 0
DO FORM ATTENTEMISEAJOUR with "Réception du fichier "+p_remote+" vers " +p_local
  local Success
    Success = .t.
*!*     buf = space(FTPBUFSIZ)  && tu peux mettre cette ligne et la suivante   avant le do while
    BytesRead = 0
    n=0

  do while !feof(m.fd) and m.Success

   buf = fread(m.fd, FTPBUFSIZ_PUT)

   do case
   case empty(InternetWriteFile(m.fd_ftp, @m.buf, len(m.buf), @m.BytesWritten))
    =m.this.Error_Show()
    assert .f.
    Success = .f.

   case m.BytesWritten <> len(m.buf)
    =MessageBox('remote Write error', MB_ICONSTOP, m.this.Class)
    assert .f.
    Success = .f.

   otherwise
    n = m.n + m.BytesWritten
     attentemiseajour.echelle(n,ntaille)
    aretourner=.t.
   endcase
enddo
  attentemiseajour.release()
= empty(m.fd_ftp) or !empty(InternetCloseHandle(m.fd_ftp))
 = (m.fd < 0) or fclose(m.fd)

 return m.Success





  *--------------------------------------------------------------------------*
  *---> Ouvre un fichier sur le serveur en renvoie un pointeur

procedure OuvrirFichier(p_remote, JeVoudraisEcrire   )
    local flags
    flags = iif(m.JeVoudraisEcrire, GENERIC_WRITE,  GENERIC_READ)
    return FtpOpenFile(this.mConnect, p_remote, m.flags, FTP_TRANSFER_TYPE_BINARY, 0)
  endproc && OuvrirFichier




  *--------------------------------------------------------------------------*
  *---> Retourne la taille en octet d'un fichier sur le serveur
  procedure TailleFichier(p_remote   )
  local v_hinternet
    v_hinternet = this.OuvrirFichier(p_remote)
    return FtpGetFileSize(v_hinternet, .F.)
  endproc && TailleFichier

  *--------------------------------------------------------------------------*
  *---> Créer un répertoire sur le serveur
  procedure CreerRepertoire(p_dir   )
    return FtpCreateDirectory(this.mConnect, p_dir) > 0
  endproc && CreerRepertoire

  *--------------------------------------------------------------------------*
  *---> Supprime un fichier sur le serveur
  procedure SupprimerFichier(p_remote   )
    return FtpDeleteFile(this.mConnect, p_remote) > 0
  endproc && SupprimerFichier

  *--------------------------------------------------------------------------*
  *---> Supprime un répertoire sur le serveur
  procedure SupprimerRepertoire(p_dir   )
    return FtpRemoveDirectory(this.mConnect, p_dir) > 0
  endproc && SupprimerRepertoire

  *--------------------------------------------------------------------------*
  *---> Renomme un fichier sur le serveur
  procedure RenommerFichier(p_old    ,;
                            p_new   )
    return FtpRenameFile(this.mConnect, p_old, p_new) > 0
  endproc && RenommerFichier

  *--------------------------------------------------------------------------*
  *---> Renvoie .T. si le fichier existe sur le serveur
  procedure EstFichier(p_remote   )
    return this.OuvrirFichier(p_remote) > 0
  endproc && EstFichier

  *--------------------------------------------------------------------------*
  *---> Extrait la liste des objets dans le masque
  * ex de masque : /*.*
  *
  *---> Colonnes
  * 1 : nom du fichier   string
  * 2 : taille           integer
  * 3 : dernière modif.  datetime
  * 4 : attributs        integer
  *
  *---> Attributs :
  * 0   Normal      Fichier normal. Aucun attribut n'est défini.
  * 1   ReadOnly    Fichier en lecture seule. L'attribut est lecture/écriture.
  * 2   Hidden      Fichier caché. L'attribut est lecture/écriture.
  * 4   System      Fichier système. L'attribut est lecture/écriture.
  * 8   Volume      Étiquette de volume de lecteur de disque. L'attribut est lecture seule.
  * 16  Directory   Dossier ou répertoire. L'attribut est lecture seule.
  * 32  Archive     Le fichier a été modifié depuis la dernière sauvegarde. L'attribut est lecture/écriture.
  * 64  Alias       Lien ou raccourci. L'attribut est lecture seule.
  * 128 Compressed  Fichier compressé. L'attribut est lecture seule.
  procedure Fichiers2Array(p_masque ,@p_t)
  local v_fichier, v_i, v_find
    with this
      v_i = 0
      v_trame = replicate(chr(0), 320)
      v_find = FtpFindFirstFile (.mConnect, p_masque, @v_trame, INTERNET_FLAG_NEED_FILE, 0)
      if v_find > 0
        do while .T.
          v_i = v_i + 1
          dimension p_t(v_i, 4)
          p_t[v_i, 1] = ltrim(substr(v_trame, 45, 250))
          if at(chr(0), p_t[v_i, 1]) <> 0
            p_t[v_i, 1] = substr(p_t[v_i, 1], 1, at(chr(0), p_t[v_i, 1])-1)
          endif
          p_t[v_i, 2] = .buf2num(v_trame, 32, 4)
          p_t[v_i, 3] = .ftime2dtime(substr(v_trame, 21, 8))
          p_t[v_i, 4] = .buf2num(v_trame, 0, 4)
          v_trame = replicate(chr(0), 320)
          if InternetFindNextFile (v_find, @v_trame) <> 1
            exit
          endif
        enddo
      endif
      return v_i
    endwith
  empty(m.v_find) or !empty(InternetCloseHandle(m.v_find))
  endproc && PremierFichier

  *--------------------------------------------------------------------------*
  hidden procedure buf2num(lcBuffer, lnOffset, lnBytes)
  local ii
    lnResult = 0
    FOR ii=1 TO lnBytes
        lnResult = lnResult +;
            BitLShift(Asc(SUBSTR (lcBuffer, lnOffset+ii, 1)), (ii-1)*8)
    ENDFOR
    RETURN  lnResult
  endproc && bug2num

  *--------------------------------------------------------------------------*
  hidden procedure ftime2dtime(lcFileTime)
  local lcSystemTime, ltResult, lcDate, lcTime, wYear, wMonth, wDay, wHour, wMinute, wSecond, lcStoredSet
    lcSystemTime = REPLI (Chr(0), 16)
    = FileTimeToSystemTime (@lcFileTime, @lcSystemTime)
    wYear   = .buf2num(lcSystemTime,  0, 2)
    wMonth  = .buf2num(lcSystemTime,  2, 2)
    wDay    = .buf2num(lcSystemTime,  6, 2)
    wHour   = .buf2num(lcSystemTime,  8, 2)
    wMinute = .buf2num(lcSystemTime, 10, 2)
    wSecond = .buf2num(lcSystemTime, 12, 2)
    lcStoredSet = SET ("DATE")
    SET DATE TO MDY
    lcDate = STRTRAN (STR(wMonth,2) + "/" +;
        STR(wDay,2) + "/" + STR(wYear,4), " ","0")
    lcTime = STRTRAN (STR(wHour,2) + ":" +;
        STR(wMinute,2) + ":" + STR(wSecond,2), " ","0")
    ltResult = ctot(lcDate + " " + lcTime)
    set date to &lcStoredSet
    RETURN  ltResult
  endproc && ftime2dtime

enddefine && FPT
Commentaires
le 21/02/2006, eric leissler a écrit :
J'ai modifé et cela fonctionne parfaitement maintenant.
Merci Grégory
Cordialement
Aumeric
le 22/07/2006, eric leissler a écrit :
problème de droits sur le serveur peut être !
cordialement
Aumeric
le 28/05/2015, taherkefi a écrit :
Bonsoir excusez moi j'ai essayé votre programme mais il n'est pas fonctionnel y'a t'il des modifications a faire ??? merci.
le 29/05/2015, eric leissler a écrit :
Bonjour.
Ce code fonctionne sur mes programmes depuis 2006.
Quelle erreur avez vous ?
Cordialement
le 29/05/2015, taherkefi a écrit :
Bonjour.
moi j'utilise le VFP 9.0 j'ai téléchargé le programme a chaque fois que j’exécute les deux label affichent Aumeric et il n’y a rien qui ce passe.
Cordialement
le 07/06/2020, lotfi072003 a écrit :
bravo Mr
Publicité

Les pubs en cours :
www.atoutfox.org - Site de la Communauté Francophone des Professionnels FoxPro - v3.4.0 - © 2004-2024.
Cette page est générée par un composant COM+ développé en Visual FoxPro 9.0-SP2-HF3