copy CD to harddrive - FSO - VBA

[iknowu99]

I would like to copy all folders/subfolders/files from CD to hard drive and exclude files larger than 100mb. Currently i am using the following code and it's eating up my harddrive!!

Option Explicit
Private Declare Function GetVolumeInformation Lib "Kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

Declare Function mciSendString Lib "winmm" Alias "mciSendStringA" ( _
    ByVal lpstrCommand As String, _
    ByVal lpstrReturnStr As Any, _
    ByVal wReturnLen As Long, _
    ByVal hCallBack As Long) As Long

Sub CopyCD()

    Application.ScreenUpdating = False

Dim x_start As Double
x_start = Timer
Const OverWriteFiles = True

Dim sPasteFolder As String

Dim oFSO As Object



    'KPD-Team 1998
    'URL: http://www.allapi.net/
    'E-Mail: KPDTeam@Allapi.net
    Dim Serial As Long, VName As String, FSName As String
    'Create buffers
    VName = String$(255, Chr$(0))
    FSName = String$(255, Chr$(0))
    'Get the volume information
    GetVolumeInformation "D:\", VName, 255, Serial, 0, 0, FSName, 255
    'Strip the extra chr$(0)'s
    VName = Left$(VName, InStr(1, VName, Chr$(0)) - 1)
    FSName = Left$(FSName, InStr(1, FSName, Chr$(0)) - 1)
    'MsgBox "The Volume name of D:\ is '" + VName + "', the File system name of Q:\ is '" + FSName + "' and the serial number of Q:\ is '" + Trim(Str$(Serial)) + "'", vbInformation + vbOKOnly
    


sPasteFolder = "C:\Testing\"

If FileFolderExists(sPasteFolder) = False Then MkDir (sPasteFolder)

Set oFSO = CreateObject("Scripting.FileSystemObject")

oFSO.CopyFolder "D:*", sPasteFolder
oFSO.CopyFile "D:\*.*", sPasteFolder

Call OpenCD

MsgBox (Timer - x_start)

End Sub
Public Function FileFolderExists(strFullPath As String) As Boolean
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

 

[NateO]

Hello,

100 MBs? Do you mean DVD? Doesn't matter, I suppose...

You probably want to have a look at each file's 'Size on Disk'. Here's something I cooked up, some time ago:

Private Declare Function GetFileAttributes Lib "kernel32" Alias _
    "GetFileAttributesA" ( _
    ByVal lpFileName As String) As Long

Private Declare Function GetCompressedFileSize Lib "kernel32" Alias _
    "GetCompressedFileSizeA" ( _
    ByVal lpFileName As String, _
    lpFileSizeHigh As Long) As Long

Private Declare Function GetFileSize Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpFileSizeHigh As Long) As Long

Private Declare Function lOpen Lib "kernel32" Alias "_lopen" ( _
    ByVal lpPathName As String, _
    ByVal iReadWrite As Long) As Long

Private Declare Function lClose Lib "kernel32" Alias "_lclose" ( _
    ByVal hFile As Long) As Long
       
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" _
   Alias "GetDiskFreeSpaceExA" ( _
   ByVal lpcurrDrive As String, _
   lpFreeBytesAvailableToCaller As Currency, _
   lpTotalNumberOfBytes As Currency, _
   lpTotalNumberOfFreeBytes As Currency) As Long
       
Private Declare Function GetDiskFreeSpace Lib "kernel32" _
   Alias "GetDiskFreeSpaceA" ( _
   ByVal lpRootPathName As String, _
   lpSectorsPerCluster As Long, _
   lpBytesPerSector As Long, _
   lpNumberOfFreeClusters As Long, _
   lpTtoalNumberOfClusters As Long) As Long
    
Sub foo()
Dim fso As Object, f As Object, file As Object
Dim fPath As String, fSize As Double
Dim p_lngHighByte As Long

Dim BytesFreeToCaller As Currency, TotalBytes As Currency
Dim TotalFreeBytes As Currency, TotalBytesUsed As Currency

Dim DrvSectors As Long, DrvBytesPerSector As Long
Dim DrvFreeClusters As Long, DrvTotalClusters As Long
Dim BytesPerCluster As Long

Dim fCount As Long, fFolders As Long, fSizeOnDisk As Double

Const rootPath As String = "C:\temp\"

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(rootPath)

fPath = f.Path
fSize = f.Size
fCount = f.Files.Count

Call GetDiskFreeSpaceEx(rootPath, _
    BytesFreeToCaller, _
    TotalBytes, _
    TotalFreeBytes)
 
Call GetDiskFreeSpace(rootPath, _
    DrvSectors, _
    DrvBytesPerSector, _
    DrvFreeClusters, _
    DrvTotalClusters)
 
Let BytesPerCluster = (TotalBytes * 10000) / DrvTotalClusters

Call RecurseSubFolders(f, BytesPerCluster, fCount, fFolders, fSizeOnDisk)

Debug.Print "Path:   " & fPath
Debug.Print "Files:  " & fCount
Debug.Print "Folders:  " & fFolders
Debug.Print "Bytes:  " & Format$(fSize, "#,###")
Debug.Print "Bytes on Disk:  " & Format$(fSizeOnDisk, "#,###")

Set f = Nothing:    Set fso = Nothing
End Sub

Sub RecurseSubFolders(ByRef Folder As Object, ByVal BytesPerCluster As Long, _
    ByRef fCount As Long, ByRef fFolders As Long, ByRef fSizeOnDisk As Double)

Dim SubFolder As Object, file As Object
Dim p_lngHighByte As Long
Dim nClusters As Double
Dim Pointer As Long

Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800
Const OF_READ As Long = &H0&

For Each file In Folder.Files
    If (GetFileAttributes(file.Path) And FILE_ATTRIBUTE_COMPRESSED) <> 0 Then
        Let nClusters = GetCompressedFileSize( _
            file.Path, p_lngHighByte) / BytesPerCluster
        If Int(nClusters) = nClusters Then
            Let fSizeOnDisk = fSizeOnDisk + (nClusters * BytesPerCluster)
        Else
            Let fSizeOnDisk = fSizeOnDisk + (Int(nClusters) * BytesPerCluster _
                + BytesPerCluster)
        End If
    Else
        Let Pointer = lOpen(file.Path, OF_READ)
        Let nClusters = GetFileSize(Pointer, p_lngHighByte) / BytesPerCluster
        Call lClose(Pointer)
        If Int(nClusters) = nClusters Then
            Let fSizeOnDisk = fSizeOnDisk + (nClusters * BytesPerCluster)
        Else
            Let fSizeOnDisk = fSizeOnDisk + (Int(nClusters) * BytesPerCluster _
                + BytesPerCluster)
        End If
    End If
Next

For Each SubFolder In Folder.SubFolders
    fCount = fCount + SubFolder.Files.Count
    fFolders = fFolders + 1
    Call RecurseSubFolders(SubFolder, BytesPerCluster, fCount, _
        fFolders, fSizeOnDisk)
Next
End Sub

And copy from there... These procedures have some known limitations, but you may want to test it out on your D:\ drive...

At this point, you're looking at each individual file anyway, so from here, apply the FileCopy() function, if need be:

MSDN Link - FileCopy Function

Perhaps this will help.

 

[iknowu99]

foo>>

good stuff - good info :wink: