Function CopyFile(src As String, dst As String, barre As ProgressBar)
zmoumen
Messages postés1Date d'inscriptionmercredi 13 août 2003StatutMembreDernière intervention 4 novembre 2008
-
4 nov. 2008 à 12:53
PCPT
Messages postés13272Date d'inscriptionlundi 13 décembre 2004StatutMembreDernière intervention 3 février 2018
-
4 nov. 2008 à 15:51
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
jrivet
Messages postés7392Date d'inscriptionmercredi 23 avril 2003StatutMembreDernière intervention 6 avril 201260 4 nov. 2008 à 14:31
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
jrivet
Messages postés7392Date d'inscriptionmercredi 23 avril 2003StatutMembreDernière intervention 6 avril 201260 4 nov. 2008 à 15:45
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.
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 & ""
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