Related
I have some Excel x64 VBA code that gets MP3 files, along with track#, size, length, etc., and puts them in some worksheets. The basic code came from John Walkenbach's page and can be found here: http://spreadsheetpage.com/index.php/file/mp3_file_lister/. I have modified it to run in 64-bit Excel by adding the PtrSafe keyword in the function declarations and changing some data types from Long to either LongLong or LongPtr (and maybe a few others). The code works wonderfully with one not too minor exception, it will not return any files in folders that contain leading periods. For example, I have an album by .38 Special ripped using WMP. The folder is: D:\Users\username\Music\Music.38 Special\Rock & Roll Strategy... This path does not appear in the list generated. I also have: D:\Users\username\Music\Music\Norah Jones...Featuring Nora Jones... and this folder is missing, too (the trailing ellipses represent the list of songs) . I have contacted John Walkenbach via email, and he has no idea why this is happening either.
Here is the code as I've modified it:
Option Explicit
Dim Sht1Row As Integer
Dim Sht2Row As Integer
' By John Walkenbach
' Maybe be distributed freely, but not sold
'API declarations
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
Public Type BROWSEINFO
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As LongPtr
lpfn As LongPtr
lParam As LongPtr
iImage As LongPtr
End Type
Sub GetAllFiles()
Dim Msg As String
Dim Directory As String
Dim lastRow1C As Integer
Dim lastRow2C As Integer
Dim lastRow1D As Integer
Dim lastRow2D As Integer
Msg = "Select the directory that contains the MP3 files. All subdirectories will be included."
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) "\" Then Directory = Directory & "\"
With Sheet1
lastRow1C = .Cells(.Rows.Count, "C").End(xlUp).Row
If lastRow1C lastRow2D Then
.Range("D" & lastRow2D, "F" & lastRow2D).Select
Selection.AutoFill Destination:=Range("D" & lastRow2D, "F" & lastRow2C)
End If
.Range("E2:E" & lastRow2C).Copy
.Range("A2:A" & lastRow2C).PasteSpecial xlPasteValues
Columns("A:J").Sort key1:=Range("G2"), order1:=xlAscending, key2:=Range("H2"), order2:=xlAscending, Header:=xlYes
Range("A1").Select
End With
With Sheet1
Worksheets("Music_Library_Full").Activate
lastRow1C = .Cells(.Rows.Count, "C").End(xlUp).Row
lastRow1D = .Cells(.Rows.Count, "D").End(xlUp).Row
If lastRow1C > lastRow1D Then
.Range("D" & lastRow1D, "F" & lastRow1D).Select
Selection.AutoFill Destination:=Range("D" & lastRow1D, "F" & lastRow1C)
End If
.Range("E2:E" & lastRow1C).Copy
.Range("A2:A" & lastRow1C).PasteSpecial xlPasteValues
Columns("A:J").Sort key1:=Range("G2"), order1:=xlAscending, key2:=Range("H2"), order2:=xlAscending, Header:=xlYes
Range("A1").Select
End With
Application.ScreenUpdating = True
End Sub
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As String
Dim x As String
Dim pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Public Sub RecursiveDir(ByVal currdir As String)
Dim Dirs() As Variant
Dim NumDirs As Long
Dim FileName As String
Dim PathAndName As String
Dim i As Long
Dim PathName As String
Dim TrackNum As Variant
Dim Genre As String
Dim Duration As Variant
Dim FileSize As Variant
' Make sure path ends in backslash
If Right(currdir, 1) "\" Then currdir = currdir & "\"
' Put column headings on active sheet
Worksheets("Music_Library_Full").Activate
Cells(1, 1) = "Artist & Filename Lookup"
Cells(1, 2) = "Filename Lookup"
Cells(1, 3) = "Full Pathname"
Cells(1, 4) = "Artist"
Cells(1, 5) = "Artist & Filename"
Cells(1, 6) = "Filename"
Cells(1, 7) = "Path"
Cells(1, 8) = "Track#"
Cells(1, 9) = "Duration"
Cells(1, 10) = "Size"
Range("1:1").Font.Bold = True
Range("1:1").Font.Italic = True
Range("1:1").Font.Name = "Consolas"
Worksheets("Best_Greatest").Activate
Cells(1, 1) = "Artist & Filename Lookup"
Cells(1, 2) = "Filename Lookup"
Cells(1, 3) = "Full Pathname"
Cells(1, 4) = "Artist"
Cells(1, 5) = "Artist & Filename"
Cells(1, 6) = "Filename"
Cells(1, 7) = "Path"
Cells(1, 8) = "Track#"
Cells(1, 9) = "Duration"
Cells(1, 10) = "Size"
Range("1:1").Font.Bold = True
Range("1:1").Font.Italic = True
Range("1:1").Font.Name = "Consolas"
' Get files
FileName = Dir(currdir & "*.*", vbDirectory)
Do While Len(FileName) 0
If Left$(FileName, 1) "." Then 'Current dir
PathAndName = currdir & FileName
If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
'store found directories
ReDim Preserve Dirs(0 To NumDirs) As Variant
Dirs(NumDirs) = PathAndName
NumDirs = NumDirs + 1
Else
If UCase(Right(FileName, 3)) = "MP3" Then
PathName = currdir 'path
FileName = FileName 'filename
TrackNum = FileInfo(currdir, FileName, 26) 'track
Duration = FileInfo(currdir, FileName, 27) 'duration
FileSize = Application.Round(FileLen(currdir & FileName) / 1024, 0) 'size
'Application.StatusBar = Row
If InStr(1, LCase(PathName), LCase("Best of"), vbTextCompare) Or InStr(1, LCase(PathName), LCase("Greatest"), vbTextCompare) Then
'Sht2Row = WorksheetFunction.CountA(Range("C:C")) + 1
Worksheets("Best_Greatest").Activate
Cells(Sht2Row, 2) = FileName
Cells(Sht2Row, 3) = PathName & FileName
Cells(Sht2Row, 7) = PathName
Cells(Sht2Row, 8) = TrackNum
Cells(Sht2Row, 9) = Duration
Cells(Sht2Row, 10) = FileSize
Sht2Row = Sht2Row + 1
Else
'Sht1Row = WorksheetFunction.CountA(Range("C:C")) + 1
Worksheets("Music_Library_Full").Activate
Cells(Sht1Row, 2) = FileName
Cells(Sht1Row, 3) = PathName & FileName
Cells(Sht1Row, 7) = PathName
Cells(Sht1Row, 8) = TrackNum
Cells(Sht1Row, 9) = Duration
Cells(Sht1Row, 10) = FileSize
Sht1Row = Sht1Row + 1
End If
End If
End If
End If
FileName = Dir()
Loop
' Process the found directories, recursively
For i = 0 To NumDirs - 1
RecursiveDir Dirs(i)
Next i
End Sub
Function FileInfo(path, FileName, item) As Variant
Dim objShell As IShellDispatch4
Dim objFolder As Folder3
Dim objFolderItem As FolderItem2
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(path)
Set objFolderItem = objFolder.ParseName(FileName)
FileInfo = objFolder.GetDetailsOf(objFolderItem, item)
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function
If anyone has any idea how to modify this so that pathnames containing a leading period as any part of the path can be returned, I'd be very glad to see it. I'd just rename those particular paths by removing the leading periods, but I'm afraid WMP will just one day put everything back the way it was (has happened before). Also, if you pick the actual folder in the BrowseForFolder API, that folder with the leading periods actually makes it into the sheet, but of course, only that folder.
Thanks
Look at this line in your code sample:
If Left$(FileName, 1) "." Then 'Current dir
Since the current directory is defined as a single '.' character, and this code only checks the initial character, it drops out before recursively examining it. Change the condition to check the length of the string as well as the initial character, e.g.
If (Left$(FileName, 1) = "." And FileName.Length = 1) Then 'Current dir
N.B. This code has not been tested; I hope it works for your use.
I was able to fix this by separating the test for root and subdirectory into separate IF statements, i.e.:
If filename <> "." Then
If filename <> ".." Then
*Code here*
End If
End If
Might be clunky, but it works.
The original If statement was:
If filename <> "." or filename <> ".." Then
This never worked. But then it occurred to me that maybe I needed to use a NAND statement. NAND = Not And. So I tried this:
if Not filename = "." And Not Filename = ".." then
This actually worked and seems to execute more rapidly than the earlier solution.
Option Explicit
' By John Walkenbach
' Maybe be distributed freely, but not sold
Sub GetAllFiles()
Dim Msg As String
Dim Directory
Msg = "Select the directory that contains the MP3 files. All subdirectories will be included."
Set Directory = Application.FileDialog(msoFileDialogFolderPicker)
With Directory
.Title = Msg
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
Directory = .SelectedItems.item(1)
Else
Exit Sub
End If
End With
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
Worksheets("Sheet1").Activate
Cells.Clear
' Put column headings on active sheet
Cells(1, 1) = "Path"
Cells(1, 2) = "Filename"
Cells(1, 3) = "FullPath"
Cells(1, 4) = "Artist"
Cells(1, 5) = "Album"
Cells(1, 6) = "Title"
Cells(1, 7) = "Track#"
Cells(1, 8) = "Genre"
Cells(1, 9) = "Duration"
Cells(1, 10) = "Year"
Cells(1, 12) = "Size"
Range("1:1").Font.Bold = True
Call RecursiveDir(Directory)
End Sub
Public Sub RecursiveDir(ByVal currdir As String)
Dim Dirs() As Variant
Dim NumDirs As Long
Dim filename As String
Dim PathAndName As String
Dim i As Variant
Dim Row As Variant
' Make sure path ends in backslash
If Right(currdir, 1) <> "\" Then currdir = currdir & "\"
Application.ScreenUpdating = False
' Get files
filename = Dir(currdir & "*.*", vbDirectory)
Do While Len(filename) <> 0
DoEvents
If Not filename = "." And Not filename = ".." Then 'Current dir
PathAndName = currdir & filename
If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
'store found directories
ReDim Preserve Dirs(0 To NumDirs) As Variant
Dirs(NumDirs) = PathAndName
NumDirs = NumDirs + 1
Else
If UCase(Right(filename, 3)) = "MP3" Then
Row = WorksheetFunction.CountA(Range("A:A")) + 1
Cells(Row, 1) = currdir 'path
Cells(Row, 2) = filename 'filename
Cells(Row, 3) = PathAndName
Cells(Row, 4) = FileInfo(currdir, filename, 20) 'artist
Cells(Row, 5) = FileInfo(currdir, filename, 14) 'album
Cells(Row, 6) = FileInfo(currdir, filename, 21) 'title
Cells(Row, 7) = FileInfo(currdir, filename, 26) 'track
Cells(Row, 8) = FileInfo(currdir, filename, 16) 'genre
Cells(Row, 9) = FileInfo(currdir, filename, 27) 'duration
Cells(Row, 10) = FileInfo(currdir, filename, 15) 'Year
Cells(Row, 11) = FileInfo(currdir, filename, 5)
Cells(Row, 12) = Application.Round(FileLen(currdir & filename) / 1024, 0) 'size
Application.StatusBar = Row
End If
End If
End If
filename = Dir()
Loop
' Process the found directories, recursively
For i = 0 To NumDirs - 1
RecursiveDir Dirs(i)
Next i
Application.StatusBar = False
End Sub
Function FileInfo(path, filename, item) As Variant
Dim objShell As IShellDispatch4
Dim objFolder As Folder3
Dim objFolderItem As FolderItem2
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(path)
Set objFolderItem = objFolder.ParseName(filename)
FileInfo = objFolder.GetDetailsOf(objFolderItem, item)
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function
Also, other fileinfo items: 27 = duration, 28 = bit rate, 26 = track number.
I have inherited a VB6 program that uses Crystal Reports 8.5 to run reports & then export the output to a PDF. It then uses the Adobe Acrobat 5.0 Type Library to merge the resulting PDFs into a single PDF document. Our problem is that we need to upgrade the Acrobat 5.0 Type Library but it appears that the most current version of Acrobat doesn’t provide a type library that will work with VB6. Does anyone know the most recent version of Acrobat that is supported within VB6? Also, does anyone have any suggestions of how this can be upgraded without upgrading the entire application to .Net? Thanks in advance for any help that can be provided.
I'd shell out to pdftk. Example from the man page:
Merge Two or More PDFs into a New Document
pdftk 1.pdf 2.pdf 3.pdf cat output 123.pdf
Note that if your app is distributed and non-GPL you'll need a commercial license for it, but it's only $24 at the moment.
I had this same requirement 15 years ago and created a mod in vb6 to do just that:
modMergePDF
Public Function MergePDFFiles
I recently updated the code to handle Acrobat 10.0 Type Library, so you would need to install the latest as of 8/1/2020, Acrobat DC Pro, to...
Use the below code
Use the compiled MergePDF.exe
Also, the mod adds bookmarks using the file names of the many PDF, with scrub code to
get rid of some ugly file names (you may have to expound upon that if you need to
scrub the file names to bookmark names), into the single pdf file.
Also included a function to generate batch file code:
Public Function BuildBatchFileCode
to call the MergePDF.exe passing in a command
line which consists of the Many pdf directory and the single pdf merged file directory
and file name. You can also pass in a flag to sort CaseSensitive (Any Capitalized
file names will sort above lowercase) and you can pass in another flag to maintain the .pdf extension in the bookmark name.
Find the MergePDF.exe on git up with all supporting code here:
https://github.com/Brad-Skidmore/MergePDF
Note: the error handling refers to goUtil.utErrorLog you can also find that on GitHub or you can replace it with your own error handling.
Here's the Mod code: modMergePDF
' http://www.xlsure.com 2020.07.30
' *********************************************************************
' You are free to use this code within your own applications, but you
' are expressly forbidden from selling or otherwise distributing this
' source code without prior written consent.
' Merge PDF Files - modMergePDF
' *********************************************************************
Option Explicit
'PDF documents must be declared in general declaration space and not local!
Private moMainDoc As Acrobat.AcroPDDoc
Private moTempDoc As Acrobat.AcroPDDoc
Private Property Get msClassName() As String
msClassName = "modMergePDF"
End Property
Public Function MergePDFFiles(psRawPDFFilesDir As String, _
psSinglePDFOutputDir As String, _
psSinglePDFOutputName As String, _
Optional ByVal pbRemovePdfExtFromBookMark As Boolean = True, _
Optional pbCaseSensitiveSort As Boolean = False, _
Optional ByVal pbShowError As Boolean = False) As Boolean
On Error GoTo EH
Dim bFirstDoc As Boolean
Dim sRawPDFFilesDir As String
Dim sSinglePDFOutputDir As String
Dim sSinglePDFOutputName As String
Dim saryFileSort() As String
Dim sBMName As String
'Track pos of things
Dim lBMPageNo As Long
Dim lPos As Long
Dim lFile As Long
Dim lInsertPageAfter As Long
Dim lNumPages As Long
Dim lRet As Long
'Need to use Adobe internal Java Object
'in order to Add Book marks
Dim oJSO As Object 'JavaScript Object
Dim oBookMarkRoot As Object
'File I/O
Dim oFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim oFSO As Scripting.FileSystemObject
sRawPDFFilesDir = psRawPDFFilesDir
'ensure backslash for the 2 b merged PDF files directory
If StrComp(Right(sRawPDFFilesDir, 1), "\", vbBinaryCompare) <> 0 Then
sRawPDFFilesDir = sRawPDFFilesDir & "\"
psRawPDFFilesDir = sRawPDFFilesDir
End If
sSinglePDFOutputDir = psSinglePDFOutputDir
sSinglePDFOutputName = psSinglePDFOutputName
'ensure .pdf for the PDFOutputName (If it's CAP .PDF should be okay)
If StrComp(Right(sSinglePDFOutputName, 4), ".pdf", vbTextCompare) <> 0 Then
sSinglePDFOutputName = sSinglePDFOutputName & ".pdf"
psSinglePDFOutputName = sSinglePDFOutputName
End If
Set oFSO = New Scripting.FileSystemObject
Set oFolder = oFSO.GetFolder(sRawPDFFilesDir)
bFirstDoc = True
If oFolder.Files.Count = 0 Then
Exit Function
End If
'Because the FSO folder files collection does not allow for
'Native sorting, need to plug all the files into an array and sort that motha
ReDim saryFileSort(1 To oFolder.Files.Count)
lFile = 0
For Each oFile In oFolder.Files
lFile = lFile + 1
saryFileSort(lFile) = oFile.Name
Next
'Once they is all in der sor the array
'Sort is Case Sensitive
If pbCaseSensitiveSort Then
goUtil.utBubbleSort saryFileSort
End If
For lFile = 1 To UBound(saryFileSort, 1)
If LCase(Right(saryFileSort(lFile), 4)) = ".pdf" Then
If bFirstDoc Then
bFirstDoc = False
Set moMainDoc = CreateObject("AcroExch.PDDoc") 'New AcroPDDoc
lRet = moMainDoc.Open(sRawPDFFilesDir & saryFileSort(lFile))
Set oJSO = moMainDoc.GetJSObject
Set oBookMarkRoot = oJSO.BookMarkRoot
sBMName = saryFileSort(lFile)
lPos = InStr(1, sBMName, "_{", vbBinaryCompare)
If lPos > 0 Then
sBMName = left(sBMName, lPos - 1) & ".pdf"
End If
If pbRemovePdfExtFromBookMark Then
sBMName = Replace(sBMName, ".pdf", vbNullString, , , vbTextCompare)
End If
lRet = oBookMarkRoot.CreateChild(sBMName, "this.pageNum =0", lFile - 1)
Else
Set moTempDoc = CreateObject("AcroExch.PDDoc") 'New AcroPDDoc
lRet = moTempDoc.Open(sRawPDFFilesDir & saryFileSort(lFile))
'get the Book mark page number before the actual instert of new pages
lBMPageNo = moMainDoc.GetNumPages
lInsertPageAfter = lBMPageNo - 1
lNumPages = moTempDoc.GetNumPages
lRet = moMainDoc.InsertPages(lInsertPageAfter, moTempDoc, 0, lNumPages, 0)
moTempDoc.Close
If lRet = 0 Then
sBMName = saryFileSort(lFile)
lPos = InStr(1, sBMName, "_{", vbBinaryCompare)
If lPos > 0 Then
sBMName = left(sBMName, lPos - 1) & ".pdf"
End If
'Need to copy the errored document over to be included in the enitre document
goUtil.utCopyFile sRawPDFFilesDir & saryFileSort(lFile), sSinglePDFOutputDir & "\" & sBMName
sBMName = "PDF Insert Page Error_" & sBMName
Else
sBMName = saryFileSort(lFile)
lPos = InStr(1, sBMName, "_{", vbBinaryCompare)
If lPos > 0 Then
sBMName = left(sBMName, lPos - 1) & ".pdf"
End If
End If
If pbRemovePdfExtFromBookMark Then
sBMName = Replace(sBMName, ".pdf", vbNullString, , , vbTextCompare)
End If
lRet = oBookMarkRoot.CreateChild(sBMName, "this.pageNum =" & lBMPageNo, lFile - 1)
End If
End If
Next
lRet = moMainDoc.Save(1, sSinglePDFOutputDir & "\" & sSinglePDFOutputName)
moMainDoc.Close
MergePDFFiles = True
CLEAN_UP:
Set oFolder = Nothing
Set oFile = Nothing
Set oFSO = Nothing
Set oBookMarkRoot = Nothing
Set oJSO = Nothing
Set moMainDoc = Nothing
Set moTempDoc = Nothing
Exit Function
EH:
goUtil.utErrorLog Err, App.EXEName, msClassName, "Public Function MergePDFFiles", pbShowError
End Function
Public Function BuildBatchFileCode(psRawPDFFilesDir As String, _
psSinglePDFOutputDir As String, _
psSinglePDFOutputName As String, _
pbRemovePdfExtFromBookMark As Boolean, _
pbCaseSensitiveSort As Boolean) As String
On Error GoTo EH
Dim sRawPDFFilesDir As String: sRawPDFFilesDir = psRawPDFFilesDir
Dim sSinglePDFOutputDir As String: sSinglePDFOutputDir = psSinglePDFOutputDir
Dim sSinglePDFOutputName As String: sSinglePDFOutputName = psSinglePDFOutputName
Dim bRemovePdfExtFromBookMark As Boolean: bRemovePdfExtFromBookMark = pbRemovePdfExtFromBookMark
'ensure backslash for the 2 b merged PDF files directory
If StrComp(Right(sRawPDFFilesDir, 1), "\", vbBinaryCompare) <> 0 Then
sRawPDFFilesDir = sRawPDFFilesDir & "\"
psRawPDFFilesDir = sRawPDFFilesDir
End If
'ensure .pdf for the PDFOutputName (If it's CAP .PDF should be okay)
If StrComp(Right(sSinglePDFOutputName, 3), ".pdf", vbTextCompare) <> 0 Then
sSinglePDFOutputName = sSinglePDFOutputName & ".pdf"
psSinglePDFOutputName = sSinglePDFOutputName
End If
Dim sCommandLine As String
sCommandLine = "RawPDFFilesDir|" & sRawPDFFilesDir _
& "|SinglePDFOutputDir|" & sSinglePDFOutputDir _
& "|SinglePDFOutputName|" & sSinglePDFOutputName _
& "|RemovePdfExtFromBookMark|" & CStr(bRemovePdfExtFromBookMark) _
& "|CaseSensitiveSort|" & CStr(pbCaseSensitiveSort)
BuildBatchFileCode = """" & App.Path & "\" & App.EXEName & ".exe"" """ & sCommandLine
Exit Function
EH:
goUtil.utErrorLog Err, App.EXEName, msClassName, "Public Function BuildBatchFileCode"
End Function
Good afternoon, I wish to have a script that will look for all files with the name pattern LCP-??? and/or FSA-??? in c:\streetweeper and copy them to D:\java\temp\sz-files.
This script will run on startup.
I found a vbscript which has very similar functionality yet it uses a text file to read the files which need to be copied. can anyone help me transform this script to function as described above?
thanks for your time, the script is below:
Option Explicit
'The source path for the copy operation.
Const strSourceFolder = "c:\streetweeper"
'The target path for the copy operation.
Const strTargetFolder = "D:\java\temp\sz-files"
'The list of files to copy. Should be a text file with one file on each row. No paths - just file name.
Const strFileList = "C:\filelist.txt"
'Should files be overwriten if they already exist? TRUE or FALSE.
Const blnOverwrite = FALSE
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
Const ForReading = 1
Dim objFileList
Set objFileList = objFSO.OpenTextFile(strFileList, ForReading, False)
Dim strFileToCopy, strSourceFilePath, strTargetFilePath
On Error Resume Next
Do Until objFileList.AtEndOfStream
'Read next line from file list and build filepaths
strFileToCopy = objFileList.Readline
strSourceFilePath = objFSO.BuildPath(strSourceFolder, strFileToCopy)
strTargetFilePath = objFSO.BuildPath(strTargetFolder, strFileToCopy)
'Copy file to specified target folder.
Err.Clear
objFSO.CopyFile strSourceFilePath, strTargetFilePath, blnOverwrite
If Err.Number = 0 Then
'File copied successfully
Else
'Error copying file
Wscript.Echo "Error " & Err.Number & " (" & Err.Description & "). Copying " & strFileToCopy
End If
Loop
in copystuff.cmd
REM The following statement will have no effect if the directory does exist.
mkdir D:\java\temp\sz-files
XCOPY /Y /E c:\streetweeper\LCP-*.* D:\java\temp\sz-files
IF ERRORLEVEL 0 GOTO COPYNEXT
GOTO END
:COPYNEXT
XCOPY /Y /E c:\streetweeper\FSA-*.* D:\java\temp\sz-files
IF ERRORLEVEL 0 GOTO DELETEFILES
GOTO End
:DELETEFILES
DEL /Q LCP-*.*
DEL /Q FSA-*.*
:End
OR
REM The following statement will have no effect if the directory does exist.
mkdir D:\java\temp\sz-files
MOVE /Y C:\StreetSweeper\LCP-*.* D:\Java\Temp\sz-files
MOVE /Y C:\StreetSweeper\FSA-*.* D:\Java\Temp\sz-files
Stuff in the startup folder of your start menu and you're good to go!
This is a VBScript file that copies file patterns using regular expressions. The Directory functionality is written by Christian d'Heureuse
I did not do argument parsing in full detail. So the script will only work, if source and destiation patterns contain an *.
The call should look like:
cscript myscript.vbs "C:\temp\filesToCopy_*.txt" "D:\temp\newName_*.txd"
' ___ _ _ ___
' | _ \__ _| |_| |_ ___ _ _ _ _ / __|___ _ __ _ _
' | _/ _` | _| _/ -_) '_| ' \ (__/ _ \ '_ \ || |
' |_| \__,_|\__|\__\___|_| |_||_\___\___/ .__/\_, |
' |_| |__/
' Copy files using patterns
' any given String is split into three parts {part1}{*}{part3}
' the replacement String is used in the same pattern to replace the three parts
' (c) m.wallner-novak
'
' vbCopyFile
' Usage cscript vbCopyFile.vbs {Source} {Destination}
'
Option Explicit
Main
'''
' Main Procedure
'
Sub Main
dim SourcePattern
dim DestPattern
dim sFile
if Wscript.Arguments.count = 2 then
SourcePattern = WScript.arguments(0)
DestPattern = WScript.arguments(1)
Dim a
a = ListDir(SourcePattern)
If UBound(a) = -1 then
WScript.Echo "No files found with specified source path:"
WScript.Echo SourcePattern
Exit Sub
End If
Dim FileName
dim regEx
Set regEx = new regexp 'Create the RegExp object
dim sPattern
sPattern = SourcePattern
sPattern = replace(sPattern,"\","\\")
sPattern = replace(sPattern,".","\.")
sPattern = replace(sPattern,"*",")(.*)(")
sPattern = "(" & sPattern & ")"
dim part1
dim part3
dim pos1
pos1 = instr(DestPattern,"*")
if pos1>0 then
part1 = left(DestPattern,pos1-1)
part3 = mid(DestPattern,pos1+1,999)
end if
regEx.Pattern = sPattern
regEx.IgnoreCase = True
Dim Fso
Set Fso = WScript.CreateObject("Scripting.FileSystemObject")
on error resume next
For Each FileName In a
WScript.Echo "copying """ & FileName & """ to """ & regEx.Replace(FileName, part1 & "$2" & part3) & """"
Fso.CopyFile FileName, regEx.Replace(FileName, part1 & "$2" & part3)
if err.number <> 0 then
Wscript.echo "ERROR #" & err.number & vbcrlf & err.Description
exit sub
end if
Next
else
WScript.echo "Wrong number of arguments"
WScript.echo Wscript.ScriptName & " SourcePattern DestinationPattern"
WScript.echo "SourcePattern and DestinationPattern are {part1}{*}{part3}"
WScript.echo "Example: Hello*.exe Hello_World*_prefix.exe"
WScript.echo " will copy Hello123.exe to Hello_World123_prefix.exe"
end if
end sub
'''
' Test program for the ListDir function.
' Lists file names using wildcards.
'
' Author: Christian d'Heureuse (www.source-code.biz)
' License: GNU/LGPL (http://www.gnu.org/licenses/lgpl.html)
'
' Changes:
' 2006-01-19 Extended to handle the special case of filter masks
' ending with a ".". Thanks to Dave Casey for the hint.
Sub Main2
Dim Path
Select Case WScript.Arguments.Count
Case 0: Path = "*.*" ' list current directory
Case 1: Path = WScript.Arguments(0)
Case Else: WScript.Echo "Invalid number of arguments.": Exit Sub
End Select
Dim a: a = ListDir(Path)
If UBound(a) = -1 then
WScript.Echo "No files found."
Exit Sub
End If
Dim FileName
For Each FileName In a
WScript.Echo FileName
Next
End Sub
' Returns an array with the file names that match Path.
' The Path string may contain the wildcard characters "*"
' and "?" in the file name component. The same rules apply
' as with the MSDOS DIR command.
' If Path is a directory, the contents of this directory is listed.
' If Path is empty, the current directory is listed.
' Author: Christian d'Heureuse (www.source-code.biz)
Public Function ListDir (ByVal Path)
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
If Path = "" then Path = "*.*"
Dim Parent, Filter
if fso.FolderExists(Path) then ' Path is a directory
Parent = Path
Filter = "*"
Else
Parent = fso.GetParentFolderName(Path)
If Parent = "" Then If Right(Path,1) = ":" Then Parent = Path: Else Parent = "."
Filter = fso.GetFileName(Path)
If Filter = "" Then Filter = "*"
End If
ReDim a(10)
Dim n: n = 0
Dim Folder: Set Folder = fso.GetFolder(Parent)
Dim Files: Set Files = Folder.Files
Dim File
For Each File In Files
If CompareFileName(File.Name,Filter) Then
If n > UBound(a) Then ReDim Preserve a(n*2)
a(n) = File.Path
n = n + 1
End If
Next
ReDim Preserve a(n-1)
ListDir = a
End Function
Private Function CompareFileName (ByVal Name, ByVal Filter) ' (recursive)
CompareFileName = False
Dim np, fp: np = 1: fp = 1
Do
If fp > Len(Filter) Then CompareFileName = np > len(name): Exit Function
If Mid(Filter,fp) = ".*" Then ' special case: ".*" at end of filter
If np > Len(Name) Then CompareFileName = True: Exit Function
End If
If Mid(Filter,fp) = "." Then ' special case: "." at end of filter
CompareFileName = np > Len(Name): Exit Function
End If
Dim fc: fc = Mid(Filter,fp,1): fp = fp + 1
Select Case fc
Case "*"
CompareFileName = CompareFileName2(name,np,filter,fp)
Exit Function
Case "?"
If np <= Len(Name) And Mid(Name,np,1) <> "." Then np = np + 1
Case Else
If np > Len(Name) Then Exit Function
Dim nc: nc = Mid(Name,np,1): np = np + 1
If Strcomp(fc,nc,vbTextCompare)<>0 Then Exit Function
End Select
Loop
End Function
Private Function CompareFileName2 (ByVal Name, ByVal np0, ByVal Filter, ByVal fp0)
Dim fp: fp = fp0
Dim fc2
Do ' skip over "*" and "?" characters in filter
If fp > Len(Filter) Then CompareFileName2 = True: Exit Function
fc2 = Mid(Filter,fp,1): fp = fp + 1
If fc2 <> "*" And fc2 <> "?" Then Exit Do
Loop
If fc2 = "." Then
If Mid(Filter,fp) = "*" Then ' special case: ".*" at end of filter
CompareFileName2 = True: Exit Function
End If
If fp > Len(Filter) Then ' special case: "." at end of filter
CompareFileName2 = InStr(np0,Name,".") = 0: Exit Function
End If
End If
Dim np
For np = np0 To Len(Name)
Dim nc: nc = Mid(Name,np,1)
If StrComp(fc2,nc,vbTextCompare)=0 Then
If CompareFileName(Mid(Name,np+1),Mid(Filter,fp)) Then
CompareFileName2 = True: Exit Function
End If
End If
Next
CompareFileName2 = False
End Function
I want to store some addresses in a text file and then read specific portions of the file, based on group membership. I've done all of the group membership stuff so I don't need any help for that.
But I'm not sure if I should use a plain text file or an INI file?
The thing is, the post addresses are in two or three lines and I need line break.
I tried using a plain text file, but I couldn't manage to get a line break correctly.
So INI files would be preferable?
The INI file could look like this:
[London]
Address 1
Postbox 3245
58348 London
[Copenhagen]
Address 2
Postbox 2455
5478347 Copenhagen
I'm not quite sure if this is possible in an INI file though, perhaps I need to name each line as well. OR, I could possibly use a plain text file and search for the word [london] and then read each line until there's a line break. Then store all of those lines in a variable that I'll pass along?
How would you guys solve this?
I have written a small VBScript Class that handles "real' ini files written with such format:
[section_name]
key1 = value1
key2 = value2
The code for the class is:
Class IniFileObject
Private m_Data
Private Sub Class_Initialize
Set m_Data = Server.CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate
Dim key
If IsObject(m_Data) Then
For Each key In m_Data
m_Data(key).RemoveAll
Set m_Data(key) = Nothing
Next
m_Data.RemoveAll
Set m_Data = Nothing
End If
End Sub
Public Function Init(sFilePath)
Dim arrLines, sLine, x
Dim sCurSection, oSectionDict
Set Init = Me
arrLines = GetFileLines(sFilePath)
If Not(IsArray(arrLines)) Then Exit Function
sCurSection = ""
For x = 0 To UBound(arrLines)
sLine = Trim(arrLines(x))
If Len(sLine)>0 Then
If Left(sLine, 1)="[" Then
If Not(HandleSectionLine(sLine, sCurSection)) Then Exit Function
Else
If Len(sCurSection)=0 Then
Err.Raise 1005, "IniFileObject init", "Found value outside any section (" & Server.HTMLEncode(sLine) & ")"
Exit Function
End If
Set oSectionDict = m_Data(sCurSection)
If Not(ParseOneLine(sLine, oSectionDict)) Then Exit Function
Set m_Data(sCurSection) = oSectionDict
End If
End If
Next
End Function
Public Property Get ReadValue(section, key)
Dim oSectionDict
ReadValue = ""
If m_Data.Exists(section) Then
Set oSectionDict = m_Data(section)
If oSectionDict.Exists(key) Then ReadValue = oSectionDict(key)
End If
End Property
Private Function ParseOneLine(ByVal sLine, ByRef oSectionDict)
Dim arrTemp, sErrorMsg, sKey
sErrorMsg = ""
ParseOneLine = True
If Left(sLine, 2)="//" Or Left(sLine, 1)="'" Or Left(sLine, 1)="{" Then Exit Function
arrTemp = Split(sLine, "=")
If UBound(arrTemp)=1 Then
sKey = Trim(arrTemp(0))
If (Len(sKey)>0) And (Len(arrTemp(1))>0) Then
If Not(oSectionDict.Exists(sKey)) Then
oSectionDict.Add sKey, Trim(arrTemp(1))
Else
sErrorMsg = "Key already exists"
End If
Else
sErrorMsg = "Empty key or value"
End If
Else
sErrorMsg = "Missing or too much '=' characters"
End If
Erase arrTemp
If Len(sErrorMsg)>0 Then
ParseOneLine = False
Err.Raise 1006, "IniFileObject Init", "Failed to parse single line (" & Server.HTMLEncode(sLine) & "): " & sErrorMsg
End If
End Function
Private Function HandleSectionLine(ByVal sLine, ByRef sCurSection)
HandleSectionLine = False
If (Len(sLine)<3) Or (Right(sLine, 1)<>"]") Then
Err.Raise 1002, "IniFileObject init", "Invalid line found: " & Server.HTMLEncode(sLine)
Exit Function
End If
sCurSection = Mid(sLine, 2, Len(sLine) - 2)
If m_Data.Exists(sCurSection) Then
Err.Raise 1003, "IniFileObject init", "Section exists more than once: " & Server.HTMLEncode(sCurSection)
Exit Function
End If
m_Data.Add sCurSection, Server.CreateObject("Scripting.Dictionary")
HandleSectionLine = True
End Function
Private Function GetFileLines(sFilePath)
Dim objFSO, oFile
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If Not(objFSO.FileExists(sFilePath)) Then
Set objFSO = Nothing
Err.Raise 1001, "IniFileObject init", "file path '" & Server.HTMLEncode(sFilePath) & "' does not exist, check permissions"
Exit Function
End If
Set oFile = objFSO.OpenTextFile(sFilePath)
GetFileLines = Split(oFile.ReadAll, VBCrLf)
oFile.Close
Set oFile = Nothing
Set objFSO = Nothing
End Function
End Class
Usage example:
Dim filePath, ini
filePath = Server.MapPath("config.ini")
Set ini = New IniFileObject.Init(filePath)
Response.Write("Value for 'Key001': " & ini.ReadValue("MySection", "Key001") & "<br />")
Set ini = Nothing
The code throw various errors when the file does not exist or contains invalid lines, the errors are pretty much clear. It's possible to "suppress" the errors and not display error page by using such code when consuming:
On Error Resume Next
Set ini = New IniFileObject.Init(filePath)
If Err.Number<>0 Then
Response.Write("Error reading ini file")
End If
On Error Goto 0
If IsObject(ini) Then
Response.Write("Value for 'IP001': " & ini.ReadValue("IPaddress", "IP001") & "<br />")
Set ini = Nothing
End If
I would probably use CSV file instead where each row will represent a country.
Country,Address1,Address2,Address3,Address4
London,Address 1,Postbox 3245,58348 London
Copenhagen,Address 2,Postbox 2455,5478347,Copenhagen
If you can easily identify your data then you could probably have more descriptive column names (i.e. Street1, Street2, Town, Postcode, etc.).
This file format is also easy to read since you only read one line of the input file at a time and split it using something like
aAddress = split(sLine, ",")
To make it even easier to work with you could use dictionary object and use country as a key and array as a value
'sLine should be read from input file'
sLine = "Copenhagen,Address 2,Postbox 2455,5478347,Copenhagen"
'Create dictionary for addresses'
Set dic = CreateObject("Scripting.Dictionary")
'Split line into array'
aAddressParts = Split(sLine, ",")
'Remove the first element of the array'
sValues = Mid(sLine, InStr(sLine, ",")+1)
aValues = Split(sValues, ",")
'Add new entry into dictionary'
dic.Add aAddressParts(0), aValues
'Usage'
MsgBox "Address for Copenhagen: " & vbNewLine & _
Join(dic("Copenhagen"), "," & vbNewLine)
Thanks,
Maciej
You could store the addresses in one line and use a special character, for example an underscore, to indicate a line break. When you read the address, you just need to replace the special character with a line break.
[London]
Address = "Postbox 3245_58348
London"
[Copenhagen]
Address = "Postbox
2455_5478347 Copenhagen"
That allows you to store addresses with more lines or without a postbox line, as well. In my experience, information like "our addresses always have exactly two lines and the first one is always a postbox" is very often incorrect...
I use a small executable that launches native api for that: GetPrivateProfileString and WritePrivateProfileString.
The executable is called like that:
Set sh = CreateObject("WScript.Shell")
Set exec = sh.Exec("ini.exe get %APPDATA%\sth\file.ini ""Section name"" key")
sFirma1 = exec.StdOut.ReadLine
Call sh.Run("ini.exe set %APPDATA%\sth\file.ini ""Section name"" key set_value", 0)
See also Running command line silently with VbScript and getting output?.
This is the code of the executable:
#include <stdio.h>
#include <windows.h>
void usage()
{
puts("ini <get>/<set> <file> <section> <key> <value>");
exit(1);
}
int main(int cArg, char **aszArg)
{
int iFile = 2;
int iSection = 3;
int iKey = 4;
int iValue = 5;
if (cArg < 5) usage();
if (strcmp(aszArg[1], "get") != 0 && strcmp(aszArg[1], "set") != 0) usage();
if (strcmp(aszArg[1], "set") == 0 && cArg < iValue + 1) usage();
if (strcmp(aszArg[1], "set") == 0) {
if (!WritePrivateProfileString(aszArg[iSection], aszArg[iKey],
aszArg[iValue], aszArg[iFile]))
puts("Failure in WriteProfileString.");
} else {
char buf[1000];
buf[0] = 0;
GetPrivateProfileString(
aszArg[iSection], aszArg[iKey], "", buf, 999, aszArg[iFile]);
puts(buf);
}
return 0;
}
You need to compile it using a c compiler for Windows. I did it with gcc, but a free compiler from ms should also work. If this page with a 32-bit executable is still available, you may give it a try, but on your own responsibility. Hackers already visited my site once.
I want to to create a full path directory, like "C:\temp1\temp2\temp2" without having to make multiple "MakeDir", for each directory.
Is this possible?
Is there any reference that I can add to my project that has this kind of function?
Thanks
You can use these functions to make the task a little easier:
Const PATH_SEPARATOR As String = "\"
'"' Creates a directory and its parent directories '''
Public Sub MakeDirectoryStructure(strDir As String)
Dim sTemp As String
If Right$(strDir, 1) = PATH_SEPARATOR Then
sTemp = Left$(strDir, Len(strDir) - 1)
Else
sTemp = strDir
End If
If Dir(strDir, vbDirectory) <> "" Then
' Already exists.'
Else
'We have to create it'
On Error Resume Next
MkDir strDir
If Err > 0 Then
' Create parent subdirectory first.'
Err.Clear
'New path'
sTemp = ExtractPath(strDir)
'Recurse'
MakeDirectoryStructure sTemp
End If
MkDir strDir
End If
End Sub
Public Function ExtractPath(strPath As String) As String
ExtractPath = MiscExtractPathName(strPath, True)
End Function
Private Function MiscExtractPathName(strPath As String, ByVal bFlag) As String
'The string is treated as if it contains '
'a path and file name. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If bFlag = TRUE: '
' Function extracts the path from '
' the input string and returns it. '
' If bFlag = FALSE: '
' Function extracts the File name from '
' the input string and returns it. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim lPos As Long
Dim lOldPos As Long
'Shorten the path one level'
lPos = 1
lOldPos = 1
Do
lPos = InStr(lPos, strPath, PATH_SEPARATOR)
If lPos > 0 Then
lOldPos = lPos
lPos = lPos + 1
Else
If lOldPos = 1 And Not bFlag Then
lOldPos = 0
End If
Exit Do
End If
Loop
If bFlag Then
MiscExtractPathName = Left$(strPath, lOldPos - 1)
Else
MiscExtractPathName = Mid$(strPath, lOldPos + 1)
End If
End Function ' MiscExtractPathName'
I'm not sure where I got this code.
Asked and answered before:
equivalent-of-directory-createdirectory-in-vb6
Private Declare Function MakeSureDirectoryPathExists Lib
"imagehlp.dll" (ByVal lpPath As String) As Long
Dim mF As String
mF = FolderPath
If Right(mF, 1) <> "\" Then
mF = mF & "\"
MakeSureDirectoryPathExists mF
End If
'//Create nested folders in one call
Public Function MkDirs(ByVal PathIn As String) _
As Boolean
Dim nPos As Long
MkDirs = True 'assume success
If Right$(PathIn, 1) <> "\" Then PathIn = PathIn + "\" nPos = InStr(1, PathIn, "\")
Do While nPos > 0
If Dir$(Left$(PathIn, nPos), vbDirectory) = "" Then
On Error GoTo Failed
MkDir Left$(PathIn, nPos)
On Error GoTo 0
End If
nPos = InStr(nPos + 1, PathIn, "\")
Loop
Exit Function
Failed:
MkDirs = False
End Function