Function CopyFile(src As String, dst As String, barre As ProgressBar)

Signaler
Messages postés
1
Date d'inscription
mercredi 13 août 2003
Statut
Membre
Dernière intervention
4 novembre 2008
-
Messages postés
13280
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
-
salut lea amis
moi je ne suis pas un grand pro de vb mais j'avais fais un petit outis de sauvegarde en se basant sur la fonction  CopyFile.
Mais depuis que j'ai commancer a utilser de cles usb de 4Go, ça ne fonctionne plus et j'ai des message de depassement de capacité
merci de votre aide
-----------------------------------------------------------------

Function CopyFile(src As String, dst As String, barre As ProgressBar) As Boolean
Dim lResult As Long
    Dim liAvailable As LARGE_INTEGER
    Dim liTotal As LARGE_INTEGER
    Dim liFree As LARGE_INTEGER
    Dim dblAvailable As Double
    Dim dblTotal As Double
    Dim dblFree As Double
   
    'Determine the Available Space, Total Size and Free Space of a drive
    lResult = GetDiskFreeSpaceEx(sauve.Text3.text, liAvailable, liTotal, liFree)
   
    'Convert the return values from LARGE_INTEGER to doubles
    dblAvailable = CLargeInt(liAvailable.LowPart, liAvailable.HighPart)
    dblTotal = CLargeInt(liTotal.LowPart, liTotal.HighPart)
    dblFree = CLargeInt(liFree.LowPart, liFree.HighPart)
   
   




  


    'le buffer qui contiendra les données lues/écrites
    Static Buf As String
    'la variable qui contiendra la place disponible (octets)
    Dim Free As Long
    'variables contenant les tailles des fichiers
    Dim BTest As Single, FSize As Single
    'variable utilisée dans le cas ou le buffer n'est pas
    'utilisé complétement...
    Dim Chunk As Integer
    'les numeros des fichiers
    Dim F1 As Byte, F2 As Byte
    'la taille du buffer
    Const BUFSIZE = 1024
    'la copie n'ayant pas été effectuée
    CopyFile = False
    'si la source n'existe pas
    If Dir(src) = "" Then
        Beep
        sauve.Label1.Caption = "Problème de sauvegarde, Fichier Source non trouvé! "
        'MsgBox "Fichier Source non trouvé!", vbCritical + vbOKOnly, "Erreur"
        sauve.Label3.Caption = "Problème de sauvegarde, Fichier Source non trouvé! "
        Exit Function
    End If
    'si la destination existe déjà, on demande un écrasement
    If Len(Dir(dst)) Then
        If MsgBox(UCase(dst) & vbCrLf & "Attention le fichier existe déjà, faut-il l'écraser?", vbQuestion + vbYesNo) = vbNo Then Exit Function
        Kill dst
    End If
    'en cas d'erreur (ReadOnly, ...)
    On Error GoTo FileCopyError
    'on signale la copie en cours, pour pouvoir intercepter
    'une éventuelle touche ESC (voir les zones de texte)
    Copying = True
    'on récupère l'espace disponible sur la destination
     Free = dblFree
    'on ouvre les fichiers
    F1 = FreeFile
    Open src For Binary As F1
    F2 = FreeFile
    Open dst For Binary As F2
    'la taille du fichier source
    FSize = LOF(F1)
    'la taille restant à copier, soit la même
    BTest = FSize
    'verification d'espace disponible en destination
    If Mid(dst, 2, 1) = ":" And Free < FSize Then
        Beep
        sauve.Label1.Caption = "Attention, Espace libre  insuffisant!" & vbCr & "Fromatez votre support de sauvegarde et recomencez! "
        MsgBox "Espace libre pour la destination insuffisant!", vbCritical + vbOKOnly, "Erreur"
        sauve.Label3.Caption = "Attention, Espace libre  insuffisant!. Fromatez le zip et recomencez! "
        Close F1
        Close F2
        Kill dst
        Copying = False
        Exit Function
    End If
    'Ici commence la boucle qui va copier le fichier
    Do
        'pression de ESC
        If Touche = 27 Then
            'on remet à zéro dans le cas ou on n'interrompt pas
            Touche = 0
            'on demande confirmation pour interrompre
            If MsgBox("Souhaitez-vous interrompre la copie en cours ?", vbQuestion + vbYesNo, "Confirmation") = vbYes Then
                Close F1
                Close F2
                Kill dst
                barre.Value = 0
                Copying = False
                Exit Function
            End If
        End If
        'Si la taille restant à copier est inférieure à la
        'taille du buffer (fin de fichier), alors on "adapte"
        'ce dernier
        If BTest < BUFSIZE Then
            Chunk = BTest
        Else
            Chunk = BUFSIZE
        End If
        'le buffer utilisé pour lire/écrire, de taille soit
        '"normale" soit spéciale si < BUFSIZE (cf plus haut)
        Buf = String(Chunk, " ")
        'on lit dans la source
        Get F1, , Buf
        'pour écrire dans la destination
        Put F2, , Buf
        'permet d'intercepter les touches (éventuel ESC)
        DoEvents
        'on change la taille restant à copier - soit la taille
        'de la source moins la taille déjà copié (destination)
        BTest = FSize - LOF(F2)
        'on change la valeur de la barre de progression
        barre.Value = (100 - Int(100 * BTest / FSize))
    Loop Until BTest = 0
    'on boucle tant qu'il le faut, soit tant que la taille
    'du restant à copier n'est pas nulle
    'puis on ferme les fichiers
    Close F1
    Close F2
    'remet à zéro la barre de progression
    barre.Value = 0
    'indique la fin, correcte, de copie
    CopyFile = True
    Copying = False
    'et quittons la fonction
    Exit Function
FileCopyError:
    'en cas d'erreur, on l'annonce; puis on ferme tout
    'avec eventuellement (si necessaire) suppression de ce
    'qui etait deja copié
    Beep
    MsgBox Err.Description, vbCritical + vbOKOnly, "Erreur pendant la copie !"
    MsgBox dblTotal
    MsgBox dblFree
    MsgBox Left(dst, 2)
    MsgBox FSize
    Close F1
    Close F2
    If Dir(dst) <> "" Then Kill dst
    barre.Value = 0
    Copying = False
    Exit Function


End Function

8 réponses

Messages postés
3275
Date d'inscription
jeudi 3 avril 2008
Statut
Membre
Dernière intervention
14 septembre 2014
4
Bonjour,

NHenry a posté une source qui traite de la copie de fichiers vers cle usb !
 je t'encourage à chercher cette source

a+
Messages postés
14761
Date d'inscription
vendredi 14 mars 2003
Statut
Modérateur
Dernière intervention
21 janvier 2021
151
Bonjour,

L'erreur est surement due au fait que tu dépasse la valeur max d'un 32 bits (signé ou non) (ou 16bits non signé).

Au niveau de la source, en .NET : http://www.vbfrance.com/codes/CUTTOKEY-GESTION-COPIES-MULTISUPPORTS_37365.aspx

Sinon, tu peux t'inspirer du code pour l'adapter en VB6, mais aucune garantie.

http://nhen0039.chez-alice.fr/index.php
Messages postés
7393
Date d'inscription
mercredi 23 avril 2003
Statut
Membre
Dernière intervention
6 avril 2012
53
Salut,
C'est quoi un LARGE_INTEGER en vb6???

@+: Ju£i€n
Pensez: Réponse acceptée
Messages postés
13280
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
39
[../auteur/JRIVET/89254.aspx jrivet]

-> un type LOW& et HIGH& 
Messages postés
7393
Date d'inscription
mercredi 23 avril 2003
Statut
Membre
Dernière intervention
6 avril 2012
53
Re,
>[../auteur/PCPT/401740.aspx PCPT]: Ah parce que cela existe vraiment??? mais ou le trouve t'on?
6 ans que je suis avec VB6 et je n'en ai jamais entendu parlé. peu être est il la solution à certains de mes problèmes.
@+: Ju£i€n
Pensez: Réponse acceptée
Messages postés
13280
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
39
^^ oui oui ce n'est pas un type inventé pour l'occasion

on l'utilise en effet pour les valeurs supérieures au MAX LONG, bien qu'un currency soit suffisant

exemple avec GetDiskFreeSpaceEx, QueryPerformanceCounter, et quelques autres....

<hr size="2" width="100%" />
Prenez un instant pour répondre à [forum/sujet-SONDAGE-POP3-POUR-CS_769706.aspx ce sondage] svp 
Messages postés
7393
Date d'inscription
mercredi 23 avril 2003
Statut
Membre
Dernière intervention
6 avril 2012
53
Re,
Ah c'est pour cela que j'adore mon métier. j'en apprends encore tout les jours. en tout cas merci à cette discution. et en revanche désolé de ne pas être d'une plus grande aide.








@+: Ju£i€n


Pensez: Réponse acceptée
Messages postés
13280
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
39
un petit snippet.., me semblant plus approprié :



<hr />
'    COPIER UN DOSSIER ET TOUT SON CONTENU
'    http://www.codyx.org/snippet_copier-dossier-tout-son-contenu_127.aspx#1878
'    Posté par [ 401740 PCPT ] le 11/06/2008
<hr />




Private Const 
NOERROR 
As Long 

0&


Private Const 
FO_COPY 
As Long 

&H2


Private Const 
FOF_ALLOWUNDO 
As Long 

&H40


Private Const 
FOF_CONFIRMMOUSE 
As Long 

&H2


Private Const 
FOF_FILESONLY 
As Long 

&H80
'
on *.*, do only files


Private Const 
FOF_MULTIDESTFILES 
As Long 
=
&H1


Private Const 
FOF_NOCONFIRMATION 
As Long 
=
&H10
'
Don't prompt the user.


Private Const 
FOF_NOCONFIRMMKDIR 
As Long 
=
&H200
' don't confirm making any needed dirs


Private Const 
FOF_RENAMEONCOLLISION 
As Long

=
&H8


Private Const 
FOF_SILENT 
As Long 

&H4   
' don't create
progress/report


Private Const 
FOF_SIMPLEPROGRESS 
As Long 
=
&H100
' means don't show names of files


Private Const 
FOF_WANTMAPPINGHANDLE 
As Long

=
&H20
' Fill in SHFILEOPSTRUCT.hNameMappings


Private Type 
SHFILEOPSTRUCT

    hWnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAborted As Boolean
    hNameMaps As Long
    sProgress As String
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As Any) As Long

Public Function CopyContentDirectory(ByVal sDirSrc As String, ByVal sDirDest As String, Optional ByVal lHandle As Long = 0,
Optional ByVal bIncludeSubFolders As Boolean
= True, Optional ByVal bShowWindowsProgressBox As Boolean
False, Optional ByVal bRenameIfExists As Boolean False,
Optional ByVal bShowWindowsAskActionBox As Boolean
= True) As Boolean
'sDirSrc                    -> répertoire
source
'sDirDest                   ->
répertoire destination
'lHandle                    -> handle appelant (peut rester à
0)
'bIncludeSubFolders         -> copie
récursive, donc avec les sous-dossiers et leur contenu
'bShowWindowsProgressBox    -> affiche la progressbox
windows
'bRenameIfExists            -> pas
d'écrasement, renomme directement les nouveaux fichiers du
dossier
'bShowWindowsAskActionBox   -> boite de
dialogue "renommer écraser oui tous etc...". NB : si FALSE, il n'y a pas non
plus de ProgressBox
    On Error GoTo Err_Handler
    Dim tFOS As SHFILEOPSTRUCT
    
'   formate
les chemins
    If bIncludeSubFolders Then
        If RightB$(sDirSrc, 2) = "" Then sDirSrc = LeftB$(sDirSrc, LenB(sDirSrc) - 2)
    Else
        If Not (RightB$(sDirSrc, 2) = "") Then sDirSrc = sDirSrc & ""
        sDirSrc = sDirSrc & "*.*"
    End If
    If Not (RightB$(sDirDest, 2) = "") Then sDirDest = sDirDest & ""
    
'  
structure
    With tFOS
        .hWnd = lHandle
        .wFunc = FO_COPY
        .pFrom = sDirSrc & vbNullChar
        .pTo = sDirDest & vbNullChar
        .fFlags = CInt(SetFOSFlag(bIncludeSubFolders, bShowWindowsProgressBox,
bRenameIfExists, bShowWindowsAskActionBox, False, True))
        .fAborted = False
        .hNameMaps = 0&
        .sProgress = vbNullChar
    End With
'   API /
retour
    CopyContentDirectory = (SHFileOperation(tFOS) =
NOERROR)
    
Err_Handler:
'   en IDE on peut avoir un message "Mémoire insuffisante" en fin
d'action malgré la réussite
    If Err.Number = 7 Then CopyContentDirectory =
True
End Function
Private Function SetFOSFlag(Optional ByVal bIncludeSubFolders As Boolean
= True, Optional ByVal bShowWindowsProgressBox As Boolean
False, Optional ByVal bRenameIfExists As Boolean False,
Optional ByVal bShowWindowsAskActionBox As Boolean
False, Optional ByVal bAllowUndo As Boolean False,
Optional ByVal bMulti
As Boolean = True) As
Long
    SetFOSFlag = FOF_WANTMAPPINGHANDLE Or
FOF_NOCONFIRMMKDIR
    If Not bIncludeSubFolders Then SetFOSFlag = SetFOSFlag
Or FOF_FILESONLY
    If Not bShowWindowsProgressBox Then SetFOSFlag = SetFOSFlag
Or FOF_SILENT
    If bRenameIfExists Then SetFOSFlag = SetFOSFlag Or FOF_RENAMEONCOLLISION
    If Not bShowWindowsAskActionBox Then SetFOSFlag = SetFOSFlag
Or FOF_NOCONFIRMATION
    If bAllowUndo Then SetFOSFlag = SetFOSFlag
Or FOF_ALLOWUNDO
    If bMulti Then SetFOSFlag = SetFOSFlag Or FOF_MULTIDESTFILES
End Function





'----------------------------------------------------------------



'Remarques :


'bReussite = CopyContentDirectory("C:\test", "D:\test",
lHandle:=0, bIncludeSubFolders:=True, bShowWindowsProgressBox:=True,
bRenameIfExists:=False, bShowWindowsAskActionBox:=False) 





++

<hr size="2" width="100%" />
Prenez un instant pour répondre à [forum/sujet-SONDAGE-POP3-POUR-CS_769706.aspx ce sondage] svp