I have a list of PDF files saved in a folder, and I am trying to get the total page number of each PDF file and save it to an excel spreadsheet.
The code works fine with normal PDF files, but the code would not work and return total page number = 0 when the PDFs is password protected, does anyone know how to get around this?
Option Explicit
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Function ClearClipboard()
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
End Function
Sub CountPages()
Dim MyPath As String, MyFile As String
Dim i As Long
MyPath = Cells(1, 7)
MyFile = Dir(MyPath & Application.PathSeparator & "*.pdf", vbDirectory)
Range("A:B").ClearContents
Range("A1") = "File Name": Range("B1") = "Pages"
Range("A1:B1").Font.Bold = True
i = 1
Do While MyFile <> ""
i = i + 1
Cells(i, 1) = MyFile
Cells(i, 2) = GetPageNum(MyPath & Application.PathSeparator & MyFile)
MyFile = Dir
Loop
Columns("A:B").AutoFit
MsgBox "Total of " & i - 1 & " PDF files have been found" & vbCrLf _
& " File names and corresponding count of pages have been written on " _
& ActiveSheet.Name, vbInformation, "Report..."
End Sub
Function GetPageNum(PDF_File As String)
Dim FileNum As Long
Dim strRetVal As String
Dim RegExp
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
FileNum = FreeFile
Open PDF_File For Binary As #FileNum
strRetVal = Space(LOF(FileNum))
Get #FileNum, , strRetVal
Close #FileNum
GetPageNum = RegExp.Execute(strRetVal).Count
End Function
Related
I am trying to download all jpg files whose url are placed in an excel sheet in one columns. I am having an error error 53 in mac its 64 bit version. Would changing long variable type to longptr help?
Here is my code
`Option Explicit
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr
Public Function DownloadURLtoFile(sSourceURL As String, _
sLocalFileName As String) As Boolean
Debug.Print sSourceURL
Debug.Print sLocalFileName
DownloadURLtoFile = URLDownloadToFile(0&, _
sSourceURL, sLocalFileName, &H10, 0&) = 0&
End Function
Sub DownLoadFiles()
Dim cell As Range, rngListOfURL As Range, FirstName As String, LastName As String, spacepos As Integer, lastrow As Long
Dim FolderName As String, FolderString As String
FolderName = ThisWorkbook.Worksheets("CANDIDATURE").Range("B2").Value & "_" & ThisWorkbook.Worksheets("CANDIDATURE").Range("A2").Value 'Choose Folder Name
FolderString = CreateFolderinMacOffice(NameFolder:=FolderName) 'Create Folder
FolderString = FolderString & Application.PathSeparator
'Const PTH = FolderString & Application.PathSeparator 'this is your save to location
lastrow = ThisWorkbook.Worksheets("CANDIDATURE").Range("C999999").End(xlUp).Row
'Set rngListOfURL = ThisWorkbook.Worksheets("database").Range("AL2:AL26") 'amend as appropriate
Set rngListOfURL = ThisWorkbook.Worksheets("CANDIDATURE").Range("I2", Range("I" & lastrow)) 'amend as appropriate
Debug.Print rngListOfURL.Address
i = 2
For Each cell In rngListOfURL
LastName = ThisWorkbook.Worksheets("CANDIDATURE").Cells(i, 6).Value
FirstName = ThisWorkbook.Worksheets("CANDIDATURE").Cells(i, 5).Value
spacepos = InStr(1, LastName, " ")
If spacepos <> 0 Then
LastName = Left(LastName, spacepos - 1)
End If
Debug.Print cell.Address
If DownloadURLtoFile(cell.Value, FolderString & FirstName & "_" & LastName & ".jpg") Then
cell.Offset(, 3).Value = "Successfully downloaded"
Else
cell.Offset(, 3).Value = "Error - no download"
End If
i = i + 1
Next cell
End Sub
Function CreateFolderinMacOffice(NameFolder As String) As String
'Function to create folder if it not exists in the Microsoft Office Folder
Dim OfficeFolder As String
Dim PathToFolder As String
Dim TestStr As String
OfficeFolder = MacScript("return POSIX path of (path to desktop folder) as string")
OfficeFolder = Replace(OfficeFolder, "/Desktop", "") & _
"Library/Group Containers/UBF8T346G9.Office/"
'OfficeFolder = "C:\Users\Dell\Desktop\New folder\"
PathToFolder = OfficeFolder & NameFolder
Debug.Print PathToFolder
On Error Resume Next
TestStr = Dir(PathToFolder & "*", vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then
MkDir PathToFolder
'You can use this msgbox line for testing if you want
'MsgBox "You find the new folder in this location :" & PathToFolder
End If
CreateFolderinMacOffice = PathToFolder
End Function
`
My SheetName is "CANDIDATURE" and URL of Images are Placed in Column I (URL of images) of sheet. The Names of the images would be the name in column F (LastName) & Column E (First Name). The images would be placed in a folder which would be named with column B (Person to which task is assigned) and A (Date). I dont have any experience of VBA in Mac so please leave suggestions.
The hyperlink below appears in a cell in an Excel Sheet. It opens and displays a file if clicked on (permissions given to anyone with the link)
How can I download a linked file to a local folder using Excel vba?
URLDownloadToFile on Google Drive
The folder C:\Test has to exist for this example to work.
For more info on URLDownloadToFile try to search SO or Google.
The Code
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownLoadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If
Function downloadFile( _
ByVal FileURL As String, _
ByVal FilePath As String) _
As Boolean
Const ProcName As String = "downloadFile"
On Error GoTo clearError
URLDownloadToFile 0, FileURL, FilePath, 0, 0
downloadFile = True
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
Sub downloadGoogleDrive()
Const UrlLeft As String = "http://drive.google.com/u/0/uc?id="
Const UrlRight As String = "&export=download"
Const FileID As String = "17bw2KgzD1ifcA7rdXdxiN9bN70g8jnMO"
Const FilePath As String _
= "C:\Test\Type1 and Type 2 errors - Atyati Temp.jpg"
Dim Url As String: Url = UrlLeft & FileID & UrlRight
Dim wasDownloaded As Boolean
wasDownloaded = downloadFile(Url, FilePath)
If wasDownloaded Then
MsgBox "Success"
Else
MsgBox "Fail"
End If
End Sub
Download File from Google Drive with original file name
Sub DownloadGoogleDriveWithFilename()
Dim myOriginalURL As String
Dim myURL As String
Dim FileID As String
Dim xmlhttp As Object
Dim FolderPath As String
Dim FilePath As String
Dim name0 As Variant
Dim oStream As Object
Dim wasDownloaded As Boolean
Application.ScreenUpdating = False
''URL from share link or Google sheet URL or Google doc URL
myOriginalURL = "https://drive.google.com/file/d/1MnaC9-adPeEjkv7AEARchoYLLSWELBsy/view?usp=sharing"
FileID = Split(myOriginalURL, "/d/")(1) ''split after "/d/"
FileID = Split(FileID, "/")(0) ''split before "/"
Const UrlLeft As String = "http://drive.google.com/u/0/uc?id="
Const UrlRight As String = "&export=download"
myURL = UrlLeft & FileID & UrlRight
Debug.Print myURL
Set xmlhttp = CreateObject("winhttp.winhttprequest.5.1")
xmlhttp.Open "GET", myURL, False ', "username", "password"
xmlhttp.Send
name0 = xmlhttp.getResponseHeader("Content-Disposition")
If name0 = "" Then
MsgBox "file name not found"
Exit Sub
End If
Debug.Print name0
name0 = Split(name0, "=""")(1) ''split after "=""
name0 = Split(name0, """;")(0) ''split before "";"
' name0 = Replace(name0, """", "") ' Remove double quotes
Debug.Print name0
FolderPath = ThisWorkbook.path
FilePath = FolderPath & "\" & name0
''This part is equvualent to URLDownloadToFile(0, myURL, FolderPath & "\" & name0, 0, 0)
''just without having to write Windows API code for 32 bit and 64 bit.
If xmlhttp.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write xmlhttp.responseBody
oStream.SaveToFile FilePath, 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
Application.ScreenUpdating = True
If FileExists(FilePath) Then
wasDownloaded = True
''open folder path location to look at the downloded file
Call Shell("explorer.exe" & " " & FolderPath, vbNormalFocus)
Else
wasDownloaded = False
MsgBox "failed"
End If
End Sub
Function FileExists(FilePath As String) As Boolean
Dim TestStr As String
TestStr = ""
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
If TestStr = "" Then
FileExists = False
Else
FileExists = True
End If
End Function
I got CSV dataset every day from 5 partners after 8PM. The files are in the same structure, the range of the size 4- 130 KB in the same folder. I want to merge all files to one by macro, the today result is days from 10-15th are missing. Data of 16th (the last day) are good. When I run the macro for only one partner, I get full result. What can be the problem?
Dim MyFolder As String
Dim MyFile As String
Dim last As Integer
Dim newrow As Integer
Dim sh As Worksheet
Dim name As String
Dim name2 As String
Dim myYear As Variant
Dim myMonth As Variant
Sheets("Munka1").Select
name = ActiveWorkbook.name
ScreenUpdating = False
Range(Cells(2, 1), Cells(300000, 200)).Select
Selection.Clear
Cells(2, 1).Select
MyFolder = "InputFolder"
MyFile = Dir(MyFolder & "\FILE_*" & "*.csv")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile, Local:=True
name2 = ActiveWorkbook.name
On Error Resume Next
Range(Cells(2, 1), Cells(3000, 11)).Select
Selection.Copy
Windows(name).Activate
Cells(newrow, 1).Select
ActiveSheet.Paste
last= Range("A1", Range("A1").End(xlDown)).Rows.Count
newrow = last + 1
Application.CutCopyMode = False
Windows(name2).Close savechanges:=False
MyFile = Dir
Loop
Can you try it like this and feedback?
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#Else
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#End If
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
Dim hProg As Long
Dim hProcess As Long, ExitCode As Long
'fill in the missing parameter and execute the program
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
'hProg is a "process ID under Win32. To get the process handle:
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do
'populate Exitcode variable
GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub
Sub Merge_CSV_Files()
Dim BatFileName As String
Dim TXTFileName As String
Dim XLSFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim DefPath As String
Dim Wb As Workbook
Dim oApp As Object
Dim oFolder
Dim foldername
'Create two temporary file names
BatFileName = Environ("Temp") & _
"\CollectCSVData" & Format(Now, "dd-mm-yy-h-mm-ss") & ".bat"
TXTFileName = Environ("Temp") & _
"\AllCSV" & Format(Now, "dd-mm-yy-h-mm-ss") & ".txt"
'Folder where you want to save the Excel file
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Set the extension and file format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007 or higher
FileExtStr = ".xlsx": FileFormatNum = 51
'If you want to save as xls(97-2003 format) in 2007 use
'FileExtStr = ".xls": FileFormatNum = 56
End If
'Name of the Excel file with a date/time stamp
XLSFileName = DefPath & "MasterCSV " & _
Format(Now, "dd-mmm-yyyy h-mm-ss") & FileExtStr
'Browse to the folder with CSV files
Set oApp = CreateObject("Shell.Application")
Set oFolder = oApp.BrowseForFolder(0, "Select folder with CSV files", 512)
If Not oFolder Is Nothing Then
foldername = oFolder.Self.Path
If Right(foldername, 1) <> "\" Then
foldername = foldername & "\"
End If
'Create the bat file
Open BatFileName For Output As #1
Print #1, "Copy " & Chr(34) & foldername & "*.csv" _
& Chr(34) & " " & TXTFileName
Close #1
'Run the Bat file to collect all data from the CSV files into a TXT file
ShellAndWait BatFileName, 0
If Dir(TXTFileName) = "" Then
MsgBox "There are no csv files in this folder"
Kill BatFileName
Exit Sub
End If
'Open the TXT file in Excel
Application.ScreenUpdating = False
Workbooks.OpenText Filename:=TXTFileName, Origin:=xlWindows, StartRow _
:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, _
Space:=False, Other:=False
'Save text file as a Excel file
Set Wb = ActiveWorkbook
Application.DisplayAlerts = False
Wb.SaveAs Filename:=XLSFileName, FileFormat:=FileFormatNum
Application.DisplayAlerts = True
Wb.Close savechanges:=False
MsgBox "You find the Excel file here: " & vbNewLine & XLSFileName
'Delete the bat and text file you temporary used
Kill BatFileName
Kill TXTFileName
Application.ScreenUpdating = True
End If
End Sub
https://www.rondebruin.nl/win/s3/win021.htm
I just had to change last and newraw variable to long.
I have a table of file locations in a separate sheet that the user has specified in a different macro. I want to take the CSV files in these locations and make them one large table in a sheet in the same workbook so I can process the values all at once. The code is running but I am only getting the last files values in the table. Thank you in advance!
Sheets("Sheet3").Cells.ClearContents
Dim ws_merge As Worksheet
Dim row_insert As Long
Dim wb_temp As Workbook
Dim temp_count As Integer
Dim i As Integer
Dim last_row As Long
row_insert = 2
temp_count = file_count
Set ws_merge = ThisWorkbook.Worksheets("Sheet3")
For i = 1 To temp_count Step 1
Set wb_temp = Workbooks.Open(Worksheets("Sheet2").Range("A" + CStr(i)).Value)
With wb_temp.Worksheets(1)
last_row = Cells(Rows.count, "A").End(xlUp).Row
.Range("A1:E" & last_row).Copy
ws_merge.Range("A1" & row_insert).PasteSpecial xlPasteValues
Application.DisplayAlerts = False
wb_temp.Close False
Application.DisplayAlerts = True
row_insert = row_insert + last_row - 1
End With
Next i
MsgBox "File Merge Complete", vbInformation
Right now I only have four files I am reading and the values of the last file are being inserted in: A12-E12. Expected: A1-E1,......, A4-E4
If you want to merge all CSV files in a folder into one master file, run the code below.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#Else
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#End If
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
Dim hProg As Long
Dim hProcess As Long, ExitCode As Long
'fill in the missing parameter and execute the program
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
'hProg is a "process ID under Win32. To get the process handle:
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do
'populate Exitcode variable
GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub
Sub Merge_CSV_Files()
Dim BatFileName As String
Dim TXTFileName As String
Dim XLSFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim DefPath As String
Dim Wb As Workbook
Dim oApp As Object
Dim oFolder
Dim foldername
'Create two temporary file names
BatFileName = Environ("Temp") & _
"\CollectCSVData" & Format(Now, "dd-mm-yy-h-mm-ss") & ".bat"
TXTFileName = Environ("Temp") & _
"\AllCSV" & Format(Now, "dd-mm-yy-h-mm-ss") & ".txt"
'Folder where you want to save the Excel file
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Set the extension and file format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007 or higher
FileExtStr = ".xlsx": FileFormatNum = 51
'If you want to save as xls(97-2003 format) in 2007 use
'FileExtStr = ".xls": FileFormatNum = 56
End If
'Name of the Excel file with a date/time stamp
XLSFileName = DefPath & "MasterCSV " & _
Format(Now, "dd-mmm-yyyy h-mm-ss") & FileExtStr
'Browse to the folder with CSV files
Set oApp = CreateObject("Shell.Application")
Set oFolder = oApp.BrowseForFolder(0, "Select folder with CSV files", 512)
If Not oFolder Is Nothing Then
foldername = oFolder.Self.Path
If Right(foldername, 1) <> "\" Then
foldername = foldername & "\"
End If
'Create the bat file
Open BatFileName For Output As #1
Print #1, "Copy " & Chr(34) & foldername & "*.csv" _
& Chr(34) & " " & TXTFileName
Close #1
'Run the Bat file to collect all data from the CSV files into a TXT file
ShellAndWait BatFileName, 0
If Dir(TXTFileName) = "" Then
MsgBox "There are no csv files in this folder"
Kill BatFileName
Exit Sub
End If
'Open the TXT file in Excel
Application.ScreenUpdating = False
Workbooks.OpenText Filename:=TXTFileName, Origin:=xlWindows, StartRow _
:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, _
Space:=False, Other:=False
'Save text file as a Excel file
Set Wb = ActiveWorkbook
Application.DisplayAlerts = False
Wb.SaveAs Filename:=XLSFileName, FileFormat:=FileFormatNum
Application.DisplayAlerts = True
Wb.Close savechanges:=False
MsgBox "You find the Excel file here: " & vbNewLine & XLSFileName
'Delete the bat and text file you temporary used
Kill BatFileName
Kill TXTFileName
Application.ScreenUpdating = True
End If
End Sub
https://www.rondebruin.nl/win/s3/win021.htm
I have about 100 macros in a folder, and I'm looking for one in particular that contains a VBA module with function called addGBE - I forget WHICH file it's in though. Is there any software program that allows me to search within the VBA code of files in a specific folder?
Make Windows Search look within MS Office and other Compressed files
Starting with Microsoft Office 2007, the Office Open XML (OOXML) file formats have become the default file format.
File types such as .XLSX, .XLSM and .DOCX use XML architecture and ZIP compression to store things like text and formulas into cells that are organized into rows and columns. For example, simply changing a .XLSM' file's extension to.ZIP` allows you to open it as a compressed file and view the files that make up the Excel workbook.
By tweaking a few settings we can ensure that Windows Search always searches within OOXML and other compressed file formats.
My example uses Windows 7, but Windows 10 has equivalent settings.
Specify which filetypes should be indexed
Hit +E an browse to the folder where you keep your Office or Compressed files are stored.
Hit Alt+T to open the Tools menu and click Folder Options
Specify which filetypes to always search within
Go to the Search tab
Make sure Always search filenames and contents is selected
Make sure Include compressed is checked
Apply change to other folders:
At this point you can either:
repeat the above steps on any other folders on which you want to change these options, or,
go to the View tab and click Apply to Folders to make all folders look/act like the current one.
Caution! This will copy all of the current folder settings to all other folders, including displayed columns, sort order, view, etc., so be aware that you may lose unique setups for individual folders.
Personally, I'll take the time to setup one folder exactly how I like it, and implement everywhere with a single click.
Open Indexing Options:
Hit the Windows Key
Type index click Indexing Options or hit Enter
click Modify to open a filetree to specify which folders should be included in the Index.
I like to include all folders, but this negatively impacts overall performance if you have a ton of data on the drive(s).
In the Indexing Options dialog:
click the Advanced tab
in the Advanced Options dialog, go to the File Types tab.
This is where you specify which filetypes the indexer should always search within.
Go through the list looking for each Open Office XML filetype (like .XLSM and DOCX)
Select Index Properties and File Contents.
Repeat for any compressed filetypes you want to include (such as .ZIP and .RAR)
When finished click OK
]10
Force re-index:
When you're finished customizing the Indexing options:
On the Indexing Options dialog, click Rebuild to build a new index file.
Note that re-indexing can take a really long time to complete, especially if you're actively using the device and/or you have a ton of data stored locally.
You can optionally close the Indexing dialog with the × and the process will continue in the background.
I found some old code (2006) that I've updated. It will open a box to enter search string then open a dir dialog box to select folder. It will then search through all modules and display a msgbox displaying file name and sheet/module name where string was found. I did not make this, just updated. Orig found here. See here for Microsoft documentation on checking for 64bit and declaring data types properly.
Option Explicit
#If VBA7 And Win64 Then ' VBA7
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Type BROWSEINFO
hOwner As LongPtr
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
End Type
#Else ' Downlevel when using previous version of VBA7
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
#End If
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim R As Long
Dim x As Long
Dim pos As Integer
'Root folder (&H0 for Desktop, &H11 for My Computer)
bInfo.pidlRoot = &H0
'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
Function RecursiveFindFiles(strPath As String, _
strSearch As String, _
Optional bSubFolders As Boolean = True, _
Optional bSheet As Boolean = False, _
Optional lFileCount As Long = 0, _
Optional lDirCount As Long = 0) As Variant
'adapted from the MS example:
'http://support.microsoft.com/default.aspx?scid=kb;en-us;185476
'---------------------------------------------------------------
'will list all the files in the supplied folder and it's
'subfolders that fit the strSearch criteria
'lFileCount and lDirCount will always have to start as 0
'---------------------------------------------------------------
Dim strFileName As String 'Walking strFileName variable.
Dim strDirName As String 'SubDirectory Name.
Dim arrDirNames() As String 'Buffer for directory name entries.
Dim nDir As Long 'Number of directories in this strPath.
Dim i As Long 'For-loop counter.
Dim n As Long
Dim arrFiles
Static strStartDirName As String
Static strpathOld As String
On Error GoTo sysFileERR
If lFileCount = 0 Then
Static collFiles As Collection
Set collFiles = New Collection
Application.Cursor = xlWait
End If
If Right$(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
If lFileCount = 0 And lDirCount = 0 Then
strStartDirName = strPath
End If
'search for subdirectories
'-------------------------
nDir = 0
ReDim arrDirNames(nDir)
strDirName = Dir(strPath, _
vbDirectory Or _
vbHidden Or _
vbArchive Or _
vbReadOnly Or _
vbSystem) 'Even if hidden, and so on.
Do While Len(strDirName) > 0
'ignore the current and encompassing directories
'-----------------------------------------------
If (strDirName <> ".") And (strDirName <> "..") Then
'check for directory with bitwise comparison
'-------------------------------------------
If GetAttr(strPath & strDirName) And vbDirectory Then
arrDirNames(nDir) = strDirName
lDirCount = lDirCount + 1
nDir = nDir + 1
DoEvents
ReDim Preserve arrDirNames(nDir)
End If 'directories.
sysFileERRCont1:
End If
strDirName = Dir() 'Get next subdirectory
DoEvents
Loop
'Search through this directory
'-----------------------------
strFileName = Dir(strPath & strSearch, _
vbNormal Or _
vbHidden Or _
vbSystem Or _
vbReadOnly Or _
vbArchive)
While Len(strFileName) <> 0
'dump file in sheet
'------------------
If bSheet Then
If lFileCount < 65536 Then
Cells(lFileCount + 1, 1) = strPath & strFileName
End If
End If
lFileCount = lFileCount + 1
collFiles.Add strPath & strFileName
If strPath <> strpathOld Then
Application.StatusBar = " " & lFileCount & _
" " & strSearch & " files found. " & _
"Now searching " & strPath
End If
strpathOld = strPath
strFileName = Dir() 'Get next file
DoEvents
Wend
If bSubFolders Then
'If there are sub-directories..
'------------------------------
If nDir > 0 Then
'Recursively walk into them
'--------------------------
For i = 0 To nDir - 1
RecursiveFindFiles strPath & arrDirNames(i) & "\", _
strSearch, _
bSubFolders, _
bSheet, _
lFileCount, _
lDirCount
DoEvents
Next
End If 'If nDir > 0
'only bare main folder left, so get out
'--------------------------------------
If strPath & arrDirNames(i) = strStartDirName Then
ReDim arrFiles(1 To lFileCount) As String
For n = 1 To lFileCount
arrFiles(n) = collFiles(n)
Next
RecursiveFindFiles = arrFiles
Application.Cursor = xlDefault
Application.StatusBar = False
End If
Else 'If bSubFolders
ReDim arrFiles(1 To lFileCount) As String
For n = 1 To lFileCount
arrFiles(n) = collFiles(n)
Next
RecursiveFindFiles = arrFiles
Application.Cursor = xlDefault
Application.StatusBar = False
End If 'If bSubFolders
Exit Function
sysFileERR:
Resume sysFileERRCont1
End Function
Function FileFromPath(ByVal strFullPath As String, _
Optional bExtensionOff As Boolean = False) _
As String
Dim FPL As Long 'len of full path
Dim PLS As Long 'position of last slash
Dim pd As Long 'position of dot before exension
Dim strFile As String
On Error GoTo ERROROUT
FPL = Len(strFullPath)
PLS = InStrRev(strFullPath, "\", , vbBinaryCompare)
strFile = Right$(strFullPath, FPL - PLS)
If bExtensionOff = False Then
FileFromPath = strFile
Else
pd = InStr(1, strFile, ".", vbBinaryCompare)
FileFromPath = Left$(strFile, pd - 1)
End If
Exit Function
ERROROUT:
On Error GoTo 0
FileFromPath = ""
End Function
Sub SearchWBsForCode()
Dim strTextToFind As String
Dim strFolder As String
Dim arr
Dim i As Long
Dim strWB As String
Dim VBProj As VBProject
Dim VBComp As VBComponent
Dim lStartLine As Long
Dim lEndLine As Long
Dim lFound As Long
Dim lType As Long
Dim lSkipped As Long
Dim oWB As Workbook
Dim bOpen As Boolean
Dim bNewBook As Boolean
strTextToFind = InputBox("Type the text to find", _
"finding text in VBE")
If Len(strTextToFind) = 0 Or StrPtr(strTextToFind) = 0 Then
Exit Sub
End If
strFolder = GetDirectory()
If Len(strFolder) = 0 Then
Exit Sub
End If
lType = Application.InputBox("Type file type to search" & _
vbCrLf & vbCrLf & _
"1. Only .xls files" & vbCrLf & _
"2. Only .xla files" & vbCrLf & _
"3. Either file type", _
"finding text in VBE", 1, Type:=1)
Select Case lType
Case 1
arr = RecursiveFindFiles(strFolder, "*.xls", True, True)
Case 2
arr = RecursiveFindFiles(strFolder, "*.xla", True, True)
Case 3
arr = RecursiveFindFiles(strFolder, "*.xl*", True, True)
Case Else
Exit Sub
End Select
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
For i = 1 To UBound(arr)
Application.StatusBar = i & "/" & UBound(arr) & _
" - Searching " & arr(i)
strWB = FileFromPath(arr(i))
On Error Resume Next
Set oWB = Workbooks(strWB)
If oWB Is Nothing Then
bOpen = False
Workbooks.Open arr(i)
Else
'for preventing closing WB's that are open already
bOpen = True
Set oWB = Nothing
End If
bNewBook = True
For Each VBComp In Workbooks(strWB).VBProject.VBComponents
If Err.Number = 50289 Then 'for protected WB's
lSkipped = lSkipped + 1
Err.Clear
GoTo PAST
End If
lEndLine = VBComp.CodeModule.CountOfLines
If VBComp.CodeModule.Find(strTextToFind, _
lStartLine, _
1, _
lEndLine, _
-1, _
False, _
False) = True Then
If bNewBook = True Then
lFound = lFound + 1
bNewBook = False
End If
Application.ScreenUpdating = True
If MsgBox("Workbook: " & arr(i) & vbCrLf & _
"VBComponent: " & VBComp.Name & vbCrLf & _
"Line number: " & lStartLine & _
vbCrLf & vbCrLf & _
"WB's found so far: " & lFound & vbCrLf & _
"Protected WB's skipped: " & lSkipped & _
vbCrLf & vbCrLf & _
"Stop searching?", _
vbYesNo + vbDefaultButton1 + vbQuestion, _
i & "/" & UBound(arr) & _
" - found " & strTextToFind) = vbYes Then
With Application
.StatusBar = False
.EnableEvents = True
.DisplayAlerts = True
End With
With VBComp.CodeModule.CodePane
.SetSelection lStartLine, 1, lStartLine, 1
.Show
End With
Exit Sub
End If
Application.ScreenUpdating = False
End If
Next
PAST:
If bOpen = False Then
Workbooks(strWB).Close savechanges:=False
End If
On Error GoTo 0
Next
On Error Resume Next
If bOpen = False Then
Workbooks(strWB).Close savechanges:=False
End If
With Application
.ScreenUpdating = True
.StatusBar = False
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox lFound & " WB's found with " & strTextToFind & " in VBE" & _
vbCrLf & vbCrLf & _
"protected WB's skipped: " & lSkipped, , _
"finding text in VBE"
End Sub