I decided to write a program that copies only the selected file types from folder to folder. At the same time, you can specify many different file formats. The usual APIs allow you to filter only one file type by mask, so I had to manually write a function myself in order to filter out several different file types by mask at once when copying.
This example finds all files in the "*.jpg; *.gif; *.tif" format in the test folder. But you can also increase the number of supported image formats, for example, write "*.bmp; *.jpg; *.jpeg; *.png; *.gif; *.dib; *.jpeg; *.jpe; *.tif; *.tiff; *.wdp; *.pcx" or you can use any other file types by mask.
App form code:
Program catalog get module:
The module for reading the list of files and directories:
This example finds all files in the "*.jpg; *.gif; *.tif" format in the test folder. But you can also increase the number of supported image formats, for example, write "*.bmp; *.jpg; *.jpeg; *.png; *.gif; *.dib; *.jpeg; *.jpe; *.tif; *.tiff; *.wdp; *.pcx" or you can use any other file types by mask.
App form code:
Code:
Option Explicit
' *---------------------------------------------------------------*
' | App to copy only certain types of files from folder to folder |
' | Version 1.0 |
' | Copyright (c) 2025-01-06 by HackerVlad |
' | email: vladislavpeshkov@ya.ru |
' *---------------------------------------------------------------*
Private Declare Function PathRemoveExtensionW Lib "shlwapi" (ByVal pszPath As Long) As Long
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileW" (ByVal lpExistingFileName As Long, ByVal lpNewFileName As Long, ByVal bFailIfExists As Long) As Long
' Manually comparing file type masks function by HackerVlad
Private Function IsStrMaskEquivalentFileName(ByVal MaskStr As String, ByVal FileName As String) As Boolean
Dim lNullPos As Long
Dim StrMask As String
Dim PathFileName As String
Dim SearchExtension As String
StrMask = Trim$(MaskStr)
If StrMask <> "*.*" And StrMask <> "*" Then
If Mid$(StrMask, 1, 1) = "*" Then ' Any file name
If Mid$(StrMask, 2, 1) = "." Then
SearchExtension = Mid$(StrMask, 3)
If StrComp(Right$(FileName, Len(SearchExtension)), SearchExtension, vbTextCompare) = 0 Then
IsStrMaskEquivalentFileName = True
End If
End If
Else ' The specific file name
If Right$(StrMask, 2) = ".*" Then ' Any extension
' Get the file name up to a point
PathRemoveExtensionW StrPtr(StrMask)
lNullPos = InStr(1, StrMask, vbNullChar)
If lNullPos Then StrMask = Left$(StrMask, lNullPos - 1)
PathFileName = FileName
PathRemoveExtensionW StrPtr(PathFileName)
lNullPos = InStr(1, PathFileName, vbNullChar)
If lNullPos Then PathFileName = Left$(PathFileName, lNullPos - 1)
If StrComp(StrMask, PathFileName, vbTextCompare) = 0 Then
IsStrMaskEquivalentFileName = True
End If
Else ' A specific file name and a specific extension
If StrComp(StrMask, FileName, vbTextCompare) = 0 Then
IsStrMaskEquivalentFileName = True
End If
End If
End If
Else
IsStrMaskEquivalentFileName = True
End If
End Function
' Copy only certain types of files from directory to directory
Public Function CopyFilesWithMask(ByVal Source As String, ByVal Destination As String, Optional MaskStr As String) As Long
Dim filesSourceFolder() As String
Dim CopyThisFile As Boolean
Dim CountFileCopies As Long
Dim Masks() As String
Dim cntMask As Byte
Dim i As Long
If ListFilesOrDirsAPI(Text1.Text, filesSourceFolder, True) > 0 Then
For i = 0 To UBound(filesSourceFolder) ' Enumerated all files
CopyThisFile = False
If Len(MaskStr) > 0 Then
If InStr(1, MaskStr, ";") > 0 Then ' The mask contains several file types
If CountFileCopies = 0 Then ' The first time
Masks = Split(MaskStr, ";") ' Split a string into an array only once
End If
For cntMask = 0 To UBound(Masks)
If IsStrMaskEquivalentFileName(Masks(cntMask), filesSourceFolder(i)) = True Then
CopyThisFile = True
End If
Next
Else
CopyThisFile = IsStrMaskEquivalentFileName(MaskStr, filesSourceFolder(i))
End If
Else
CopyThisFile = True
End If
If CopyThisFile = True Then
CopyFile StrPtr(Source & "\" & filesSourceFolder(i)), StrPtr(Destination & "\" & filesSourceFolder(i)), 0
CountFileCopies = CountFileCopies + 1
End If
Next
CopyFilesWithMask = CountFileCopies
End If
End Function
Private Sub Command1_Click()
Dim CountFileCopies As Long
' All image formats: "*.bmp; *.jpg; *.jpeg; *.png; *.gif; *.dib; *.jfif; *.jpe; *.tif; *.tiff; *.wdp; *.pcx"
Screen.MousePointer = 13
CountFileCopies = CopyFilesWithMask(Text1.Text, Text2.Text, "*.jpg; *.gif; *.tif") ' Only 3 image formats
Screen.MousePointer = 0
If CountFileCopies > 0 Then
MsgBox CountFileCopies & " files have been successfully copied!", vbInformation
Else
MsgBox "File copying error, 0 files were copied.", vbCritical
End If
End Sub
Private Sub Form_Load()
Text1.Text = AppPath & "\TestSource"
Text2.Text = AppPath & "\TestDestination"
End SubCode:
Option Explicit
'////////////////////////////////////////////
'// Program catalog get module //
'// Copyright (c) 2023-08-08 by HackerVlad //
'// email: vladislavpeshkov@ya.ru //
'// Version 2.0 //
'////////////////////////////////////////////
Private Declare Function GetModuleFileNameW Lib "kernel32" (ByVal hModule As Long, ByVal lpFileName As Long, ByVal nSize As Long) As Long
Private Declare Function PathRemoveFileSpecW Lib "shlwapi" (ByVal pszPath As Long) As Long
Private Declare Function PathStripPathW Lib "shlwapi" (ByVal pszPath As Long) As Long
Private Declare Function PathRemoveExtensionW Lib "shlwapi" (ByVal pszPath As Long) As Long
Private Const MAX_PATH As Long = 260
Dim SaveAppPath As String
Dim SaveEXEName As String
Dim SaveAppEXEName As String
Private Function MakeTrue(ByRef bValue As Boolean) As Boolean
MakeTrue = True
bValue = True
End Function
' Returns the directory where the program is located
Public Function AppPath() As String
Dim bInIDE As Boolean
Dim lNullPos As Long
If Len(SaveAppPath) > 0 Then
AppPath = SaveAppPath
Else
Debug.Assert MakeTrue(bInIDE)
If bInIDE Then
AppPath = App.Path
SaveAppPath = AppPath
Else
AppPath = Space$(MAX_PATH)
GetModuleFileNameW 0, StrPtr(AppPath), MAX_PATH
PathRemoveFileSpecW StrPtr(AppPath)
lNullPos = InStr(1, AppPath, vbNullChar)
If lNullPos Then
AppPath = Left$(AppPath, lNullPos - 1)
Else
AppPath = App.Path
End If
If Right$(AppPath, 1) = "\" Then AppPath = Mid$(AppPath, 1, Len(AppPath) - 1)
SaveAppPath = AppPath
End If
End If
End Function
' Returns the name of the EXE file
Public Function AppEXEName() As String
Dim bInIDE As Boolean
Dim lNullPos As Long
If Len(SaveEXEName) > 0 Then
AppEXEName = SaveEXEName
Else
Debug.Assert MakeTrue(bInIDE)
If bInIDE Then
SaveEXEName = App.EXEName & ".exe"
AppEXEName = SaveEXEName
Else
SaveEXEName = Space$(MAX_PATH)
GetModuleFileNameW 0, StrPtr(SaveEXEName), MAX_PATH
PathStripPathW StrPtr(SaveEXEName)
lNullPos = InStr(1, SaveEXEName, vbNullChar)
If lNullPos Then
SaveEXEName = Left$(SaveEXEName, lNullPos - 1)
Else
SaveEXEName = App.EXEName & ".exe"
End If
AppEXEName = SaveEXEName
End If
End If
End Function
' Returns the name of the EXE file, without the extension
Public Function AppEXENameWithoutExtension() As String
Dim bInIDE As Boolean
Dim lNullPos As Long
If Len(SaveAppEXEName) > 0 Then
AppEXENameWithoutExtension = SaveAppEXEName
Else
Debug.Assert MakeTrue(bInIDE)
If bInIDE Then
SaveAppEXEName = App.EXEName
AppEXENameWithoutExtension = SaveAppEXEName
Else
SaveAppEXEName = Space$(MAX_PATH)
GetModuleFileNameW 0, StrPtr(SaveAppEXEName), MAX_PATH
PathStripPathW StrPtr(SaveAppEXEName)
PathRemoveExtensionW StrPtr(SaveAppEXEName)
lNullPos = InStr(1, SaveAppEXEName, vbNullChar)
If lNullPos Then
SaveAppEXEName = Left$(SaveAppEXEName, lNullPos - 1)
Else
SaveAppEXEName = App.EXEName
End If
AppEXENameWithoutExtension = SaveAppEXEName
End If
End If
End FunctionCode:
Option Explicit
'//////////////////////////////////////////////////////////////
'// The module for reading the list of files and directories //
'// Copyright 2021-12-02 by HackerVlad //
'// email: vladislavpeshkov@yandex.ru //
'// Version 2.5 //
'//////////////////////////////////////////////////////////////
' API declarations ...
Private Declare Function FindFirstFileA Lib "kernel32" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFileA Lib "kernel32" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFileW Lib "kernel32" (ByVal lpFileName As Long, lpFindFileData As WIN32_FIND_DATA_UNICODE) As Long
Private Declare Function FindNextFileW Lib "kernel32" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA_UNICODE) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Private Declare Function SysAllocStringLen Lib "oleaut32" (ByVal olestr As Long, ByVal BLen As Long) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value As Long)
' Constants ...
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
' Types ...
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Type WIN32_FIND_DATA_UNICODE
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName(MAX_PATH) As Integer
cAlternate(14) As Integer
End Type
' Number of files in a directory using VB6
Public Function CountFiles(Directory As String, Optional HiddenFiles As Boolean = True, Optional Mask As String = "*.*") As Long
Dim FileName As String
Dim cnt As Long
If Right(Directory, 1) <> "\" Then
Directory = Directory + "\"
Else
If Mid(Directory, Len(Directory) - 1, 1) = "\" Then Exit Function
End If
If HiddenFiles = True Then
FileName = Dir(Directory + Mask, 7)
Else
FileName = Dir(Directory + Mask, vbNormal)
End If
Do While FileName <> vbNullString
cnt = cnt + 1
FileName = Dir$
Loop
If cnt > 0 Then CountFiles = cnt
End Function
' List files in a directory using VB6 (ANSI file names only)
Public Function ListFiles(Directory As String, StrArray() As String, Optional HiddenFiles As Boolean = True, Optional Mask As String = "*.*") As Long
Dim FileName As String
Dim cnt As Long
If Right(Directory, 1) <> "\" Then
Directory = Directory + "\"
Else
If Mid(Directory, Len(Directory) - 1, 1) = "\" Then Exit Function
End If
If HiddenFiles = True Then
FileName = Dir(Directory + Mask, 7)
Else
FileName = Dir(Directory + Mask, vbNormal)
End If
Do While FileName <> vbNullString
ReDim Preserve StrArray(cnt)
StrArray(cnt) = FileName
cnt = cnt + 1
FileName = Dir$
Loop
If cnt > 0 Then ListFiles = cnt
End Function
' List of subdirectories in a directory using WMI
Public Function ListDirsWMI(Directory As String, StrArray() As String) As Long
Dim fso As Object, objFolder As Object, SubFolder As Object
Dim cnt As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFolder = fso.GetFolder(Directory)
For Each SubFolder In objFolder.SubFolders
ReDim Preserve StrArray(cnt)
StrArray(cnt) = SubFolder.Name
cnt = cnt + 1
Next SubFolder
If cnt > 0 Then ListDirsWMI = cnt
Set SubFolder = Nothing
Set objFolder = Nothing
Set fso = Nothing
End Function
' A list of files or subdirectories in a directory using API (with unicode support)
Public Function ListFilesOrDirsAPI(Directory As String, StrArray() As String, Optional ListFiles As Boolean) As Long
Dim DirName As String
Dim hSearch As Long
Dim WFD As WIN32_FIND_DATA_UNICODE
Dim Cont As Long
Dim cnt As Long
Dim lpStr As Long
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
Cont = True
hSearch = FindFirstFileW(StrPtr(Directory & "*"), WFD)
If hSearch <> INVALID_HANDLE_VALUE Then
Do While Cont
lpStr = VarPtr(WFD.dwReserved1) + 4
PutMem4 VarPtr(DirName), SysAllocStringLen(0, lstrlen(lpStr))
lstrcpy StrPtr(DirName), lpStr
If DirName <> "." And DirName <> ".." Then
If ListFiles = False Then
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> 0 Then
ReDim Preserve StrArray(cnt)
StrArray(cnt) = DirName
cnt = cnt + 1
End If
Else
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = 0 Then
ReDim Preserve StrArray(cnt)
StrArray(cnt) = DirName
cnt = cnt + 1
End If
End If
End If
Cont = FindNextFileW(hSearch, WFD)
Loop
Cont = FindClose(hSearch)
End If
If cnt > 0 Then ListFilesOrDirsAPI = cnt
End Function
' The number of subdirectories in a directory using the API (based on the ANSI version)
Public Function CountDirsAPI(Directory As String) As Long
Dim DirName As String
Dim hSearch As Long
Dim WFD As WIN32_FIND_DATA
Dim Cont As Long
Dim cnt As Long
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
Cont = True
hSearch = FindFirstFileA(Directory & "*", WFD)
If hSearch <> INVALID_HANDLE_VALUE Then
Do While Cont
DirName = Left$(WFD.cFileName, lstrlen(StrPtr(WFD.cFileName)))
If (DirName <> ".") And (DirName <> "..") Then
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> 0 Then ' ???? ??? FILE_ATTRIBUTE_DIRECTORY ??????????, ?????...
cnt = cnt + 1
End If
End If
Cont = FindNextFileA(hSearch, WFD)
Loop
Cont = FindClose(hSearch)
End If
If cnt > 0 Then CountDirsAPI = cnt
End Function