Hi, I should copy only and exclusively certain types of image files, for example only .jpg, .gif, .tif files.
Now I use this code to copy only one type of file, but I would like to be able
to copy all image files with that type of extension in one command
Code:
Private Declare Function SHFileOperation _
Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long
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 Const FO_MOVE = &H1
Private Const FO_COPY = &H2
Private Const FO_DELETE = &H3
Private Const FO_RENAME = &H4
Private Const FOF_SILENT = &H4
Dim SHF As SHFILEOPSTRUCT
Dim lret As Long
ArrayCount = 1
Do While ArrayCount <= ArrayLimit
SHF.wFunc = FO_COPY
SHF.hwnd = Me.hwnd
SHF.pFrom = Backup(ArrayCount)
SHF.pTo = SaveLocation
SHF.fFlags = FOF_SILENT
lret = SHFileOperation(SHF)
ArrayCount = ArrayCount + 1
Loop
Dim sDesktop As String
Dim SHF As SHFILEOPSTRUCT
Dim lRet As Long
SHF.wFunc = FO_COPY
SHF.hWnd = Me.hWnd
SHF.pFrom = sDesktop & "\*.txt"
SHF.pTo = sFolder
SHF.fFlags = FOF_SILENT
lRet = SHFileOperation(SHF)
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
You can first get a list of files in a directory by mask. For example, with this code. Then copy via FileCopy.
Do you probably want to separate several file types by mask at the same time?
I do not know how to do this using the API, so I remember writing my script in order to separate several types of files by mask.
I have written a program specifically for you that copies files by mask, from folder to folder, only of the file types you select (image formats).
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 Sub
Last edited by HackerVlad; Jan 6th, 2025 at 10:30 AM.
That is, as you can see, I wrote my own IsStrMaskEquivalentFileName function in order to accomplish this difficult task.
I also decided to post this complex code in ready-made solutions, maybe it will be useful to someone else. Follow: https://www.vbforums.com/showthread....lder-to-folder
Thanks, great work. For example, if I wanted to implement a function that checks whether the files being
copied are present in the destination folder, how should I proceed?
With your work the present files are overwritten, it would be better to be able to check and possibly copy them or not.
Thanks, great work. For example, if I wanted to implement a function that checks whether the files being
copied are present in the destination folder, how should I proceed?
With your work the present files are overwritten, it would be better to be able to check and possibly copy them or not.
To prevent existing files from being overwritten, find and rewrite just 1 line of code.:
It turns out that you can list several file types in a mask at once, for copying. I have written a new version of the project, where there are much fewer lines of code.
Code:
Option Explicit
' *---------------------------------------------------------------*
' | App to copy only certain types of files from folder to folder |
' | Version: SHFileOperation |
' | Copyright (c) 2025-01-08 by HackerVlad |
' | email: vladislavpeshkov@ya.ru |
' *---------------------------------------------------------------*
Private Declare Function SHFileOperation Lib "shell32" Alias "SHFileOperationW" (ByVal lpFileOp As Long) As Long
Private Const FO_COPY = &H2
Private Const FOF_SILENT = &H4
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
' Copy only certain types of files from folder to folder
Public Function CopyFilesWithMaskSH(ByVal Source As String, ByVal Destination As String, Optional MaskStr As String, Optional ShowProgress As Boolean) As Boolean
Dim SHF As SHFILEOPSTRUCT
Dim Masks() As String
Dim cntMask As Byte
Dim pFrom As String
MaskStr = Trim$(MaskStr)
If Right$(MaskStr, 1) = ";" Then MaskStr = Mid$(MaskStr, 1, Len(MaskStr) - 1)
If Len(MaskStr) > 0 Then
If InStr(1, MaskStr, ";") > 0 Then ' The mask contains several file types
Masks = Split(MaskStr, ";") ' Split a string into an array only once
For cntMask = 0 To UBound(Masks)
pFrom = pFrom & Source & "\" & Trim$(Masks(cntMask)) & vbNullChar
Next
Else ' One file type
pFrom = Source & "\" & MaskStr & vbNullChar
End If
Else
pFrom = Source & "\*.*" & vbNullChar
End If
SHF.hwnd = hwnd
SHF.wFunc = FO_COPY
If Not ShowProgress Then SHF.fFlags = FOF_SILENT
SHF.pFrom = pFrom & vbNullChar
SHF.pTo = Destination
If SHFileOperation(VarPtr(SHF)) = 0 Then CopyFilesWithMaskSH = True
End Function
Private Sub Command1_Click()
' All image formats: "*.bmp; *.jpg; *.jpeg; *.png; *.gif; *.dib; *.jfif; *.jpe; *.tif; *.tiff; *.wdp; *.pcx"
Screen.MousePointer = 13
If CopyFilesWithMaskSH(Text1.Text, Text2.Text, "*.jpg; *.gif; *.tif") = True Then ' Only 3 image formats
Screen.MousePointer = 0
MsgBox "All files have been successfully copied!", vbInformation
Else
Screen.MousePointer = 0
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 Sub
Last edited by HackerVlad; Jan 7th, 2025 at 06:25 PM.
First of all, thanks for the great work. I am truly grateful for the help you give me.
Only one thing doesn't add up to me. If there are no files in the source folder the message always says that the files have been copied successfully.
Same thing when I choose not to copy files.
Thanks again
SatFab, Yes, the SHFileOperation function is weird with the return value. I noticed that too. It's probably best to check the existence of the files yourself.
Yes, I try to use If FileExists for the destination folder, but to cancel the copy of the files if they exist in the destination folder the api module does not provide anything
I do not know how to use the SHFileOperation function to skip existing files when copying. You'll have to use my first version then. With the CopyFile function, although it is clear how to do this, there is such a flag.
SHFileOperation can only be configured to automatically replace existing files when copying (flag FOF_NOCONFIRMATION), but I have no idea how to configure SHFileOperation to automatically skip existing files, I just did not find this in the documentation...
Last edited by HackerVlad; Jan 8th, 2025 at 10:57 AM.
Therefore, the only solution here is to return to the original code that I wrote the very first time, it only needs to be slightly upgraded, here is a new version (but it works as you need):
Code:
Option Explicit
' *---------------------------------------------------------------*
' | App to copy only certain types of files from folder to folder |
' | Version 1.2 |
' | Copyright (c) 2025-01-08 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, Optional SkipExistingFiles As Boolean) 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
If SkipExistingFiles = False Then
If CopyFile(StrPtr(Source & "\" & filesSourceFolder(i)), StrPtr(Destination & "\" & filesSourceFolder(i)), 0) <> 0 Then CountFileCopies = CountFileCopies + 1
Else
If CopyFile(StrPtr(Source & "\" & filesSourceFolder(i)), StrPtr(Destination & "\" & filesSourceFolder(i)), 1) <> 0 Then CountFileCopies = CountFileCopies + 1
End If
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", True) ' Only 3 image formats
Screen.MousePointer = 0
If CountFileCopies > 0 Then
MsgBox CountFileCopies & " files have been successfully copied!", vbInformation
Else
MsgBox "Zero files were copied. An error occurred or all the files already existed in the destination folder.", vbExclamation
End If
End Sub
Private Sub Form_Load()
Text1.Text = AppPath & "\TestSource"
Text2.Text = AppPath & "\TestDestination"
End Sub
Unlike using the SHFileOperation function, here we know exactly how many files were successfully copied. And here we can definitely set a flag to skip when copying existing files! SHFileOperation is a limited function and does not allow us to do this.
Thanks again, you're right, it's better to go back to the old system which allows us to have more control over the code.
Now it does exactly what I ask. Now I will try to have an alternative that allows me to copy or move the files at will.
If these exist I will see that I have the option "overwrite or skip and do not copy or move the files".
Is there a method for the move files function or do I copy and then delete?
Thanks again
Thanks again, you're right, it's better to go back to the old system which allows us to have more control over the code.
Now it does exactly what I ask. Now I will try to have an alternative that allows me to copy or move the files at will.
If these exist I will see that I have the option "overwrite or skip and do not copy or move the files".
Is there a method for the move files function or do I copy and then delete?
Thanks again
Of course, you can also move it. There is a MoveFile function for this.
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileW" (ByVal lpExistingFileName As Long, ByVal lpNewFileName As Long) As Long
This is how this function is declared. However, I do not know what will happen if the file already exists in the destination directory. Would it be better to manually check for the existence of files?
Code:
Private Declare Function IsFileAPI Lib "shlwapi" Alias "PathFileExistsW" (ByVal pszPath As Long) As Long
I can't understand why the function that counts a specific file type counts a doc file twice.
Let me explain better: I have a .doc file and a .docx file ( two files only ) for which reason when the function
counts the .doc files it also takes the .docx files into consideration and therefore counts Two files
Code:
Private Function CountFiles(strFolder As String, strPattern As String) As Integer
Dim strFile As String
strFile = Dir$(strFolder & "\" & strPattern)
Do Until strFile = ""
CountFiles = CountFiles + 1
strFile = Dir$()
Loop
End Function
Code:
MsgBox CountFiles(sFolder, "\*.doc")
if instead I insert the .docx extension it counts perfectly as one
Did you come up with this CountFiles feature yourself? Did you write it yourself?
Well, what's the question anyway? I do not know what files you have in the folder.
I also have the same function, you've seen it already, I think.
Code:
' 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
Do your function and my function work the same way?
I only have a .doc file and a .docx file in the same folder. When I use the function for .doc files the count shows 2 and not 1.
I don't understand why.
Code:
MsgBox CountFiles(sFolder & "\", True, "*.docx")
Exact only one file on the folder
I used your function
same result for .xls to .xlsx , ppt to pptx and other office new and old files
Last edited by SatFab; Jan 10th, 2025 at 12:18 PM.
The exact same error occurs in my ListFiles function. In general, using the internal functions of the VB6 language is bad. Here we will have to rewrite these functions completely to the API so that there will definitely be no such error anymore.
You know, I'm very surprised by the behavior of the OS, I completely rewrote it to the API. And I specified a mask for the FindFirstFile function, and the result is exactly the same error. It's very strange. I am quite surprised by this behavior of Windows...
You need to read MSDN, maybe there are some explanations in the Microsoft documentation why functions behave this way.
As we just found out, Microsoft's standard functions don't give us the results we need. Therefore, we will have to use the IsStrMaskEquivalentFileName function again, which I wrote myself in order to get the 100% correct result that we expect.
Last edited by HackerVlad; Jan 10th, 2025 at 02:50 PM.
By the way, I just checked the entire operating system, both Windows and DOS, behaves this way with masks for some reason.
If you run the console (cmd.exe ) or a DOS window and enter the command "dir *.doc" in the folder you need, you will also get two files as a result, along with the docx file instead of one file as we expect... It's weird, isn't it? Maybe that's what Microsoft intended.
Thanks again, in fact I imagined there was an error at API level, because it confuses .docx with .doc and counts it as a .doc file.
This is really strange, and this also happens with other office formats.
Well, it's Microsoft's fault, not my fault.
I conducted an experiment. I just tested my file copying project, which uses the SHFileOperation function. And what do you think? I specified the mask "*.doc" and what do you think the result was? Only one file was copied! I'm shocked!
We conclude from this that the error in the FindFirstFile function is a Microsoft error.
Since the FindFirstFile and SHFileOperation functions behave differently, it turns out.
Thus, I want to note that my two projects for copying files from folder to folder are working correctly and copy only one doc file.
This means that we need to write our own correct function for counting the number of files in a folder using the IsStrMaskEquivalentFileName technology. Then the result will be correct.
Reply With Quote
Originally Posted by SatFab
