Populate GPO from Text File using VBScript or other - vbscript

Ok, so we need to create a GPO that allows our users to only use specific programs.
GPO Location:
User Configuration
Policies
Administrative Templates [...]
System
Run only specified Windows applications
Then setting the GPO to enabled and clicking on List of allowed applications --> Show...
I have created an excel spreadsheet containing the names of all the programs and their associated executable files with other pertinent information so that we can easily organize, add, delete, etc. the executable files that we need to allow our users access to.
This spreadsheet then dumps all the executable files into a text file.
Here is an example of what the text file looks like:
Acrobat.exe
chrome.exe
calc.exe
.
.
.
There are a lot of entries and these are likely subject to change. What I am trying to do is create a script that will take that text file and populate the GPO automatically. I don't care if we have to open the window and then run it, it does not need to run from the task scheduler (although that would be amazing if someone has that code ready). We just need it to populate this ridiculous amount of executable filenames into the fields.
Here is code I found (VBScript) that when run, should populate the fields automatically, however I cannot get it to run in the Group Policy Management Editor (it runs in the windows explorer window instead and ends up searching for some of the files)
' Open the text file, located in the same path as the script
Set objFSO = CreateObject("Scripting.FileSystemObject")
strPath = Mid(Wscript.ScriptFullName, 1, InStrRev(Wscript.ScriptFullName, wscript.ScriptName) -1)
Set objFile = objFSO.OpenTextFile(strPath & "appList.txt")
' Activate the "Show Contents" window with the "List of allowed applications".
' Note the window must be opened already and we should have selected where in
' the list we want to enter the data before running the script
set WshShell = WScript.CreateObject("WScript.Shell")
WScript.Sleep 1000
WshShell.AppActivate "Show Contents"
' Read the file line by line
Do While objFile.AtEndOfStream <> True
' Each line contains one EXE name
exeName = objFile.ReadLine
' Escape forbidden chars { } [ ] ( ) + ^ % ~
exeName = Replace(exeName, "[", "{[}")
exeName = Replace(exeName, "]", "{]}")
exeName = Replace(exeName, "(", "{(}")
exeName = Replace(exeName, ")", "{)}")
exeName = Replace(exeName, "+", "{+}")
exeName = Replace(exeName, "^", "{^}")
exeName = Replace(exeName, "%", "{%}")
exeName = Replace(exeName, "~", "{~}")
' Send the EXE name to the window
WScript.Sleep 100
WshShell.SendKeys exeName
' Move to the next one
WshShell.SendKeys "{TAB}"
Loop
objFile.Close
from: http://blogs.msdn.com/b/alejacma/archive/2011/03/24/how-to-update-quot-run-only-specified-windows-applications-quot-gpo-programmatically-vbscript.aspx

"C:\Windows\System32\GroupPolicy\User\Registry.pol"
Is where my policies are stored. It's a semi text file. Try writing to that file.

Ok, so I tried it many different ways. If anyone is looking for an answer to do this, this is the way I've figured it out and the way I've decided to proceed. I will post all relevant code below.
In Excel, the format of my table is as follows:
(With obviously WAY more entries)
Here is the VBA code I used to turn the data from this file into the proper format for the registry key:
VBA - In Excel
Public Sub ExportToTextFile(FName As String, _
Sep As String, SelectionOnly As Boolean, _
AppendData As Boolean)
Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile
StartRow = 2
If SelectionOnly = True Then
With Selection
StartCol = .Cells(2).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(2).Column
End With
Else
With ActiveSheet.UsedRange
StartCol = .Cells(2).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(2).Column
End With
End If
If AppendData = True Then
Open FName For Append Access Write As #FNum
Else
Open FName For Output Access Write As #FNum
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & Chr(34) & CellValue & ".exe" & Chr(34) & "=" & Chr(34) & CellValue & ".exe" & Chr(34) & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine; ""
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum
End Sub
Sub PipeExport()
Dim FileName As Variant
Dim Sep As String
FileName = Application.GetSaveAsFilename(InitialFileName:="appList", filefilter:="Text (*.txt),*.txt")
If FileName = False Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Sep = "|"
If Sep = vbNullString Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
Debug.Print "FileName: " & FileName, "Extension: " & Sep
ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), _
SelectionOnly:=False, AppendData:=False
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
PipeExport
End Sub
The file that is created is appList.txt and its format is the same format as the registry key:
"Acrobat.exe"="Acrobat.exe"
"AcroRd32.exe"="AcroRd32.exe"
Now in your GPO, add a unique program name to the allowed applications list (say test1234.exe) and in your registry editor, go to Edit > Find test1234.exe.
Export that registry key under File > Export. Remove the test1234.exe line and paste in your text file. Then reimport that file and you're done!

Related

Merging last slides from multiple PowerPoint Presentations [duplicate]

We have some set of (powerpoint) pptx files which are targeted for different audiences
I was thinking of merging different slide sets based on target audiance
I want to know if it's possible to
Merge multiple powerpoint files into one
If a single file is changed, i want the same change to reflect into the merged file
Is this possible graphically or by a VBA?
Ex:
A.pptx
B.pptx
C.pptx
D.pptx
E.pptx
Set 1 (Dev.pptx):
A.pptx
B.pptx
D.pptx
Set 2 (Manager.pptx)
A.pptx
D.pptx
E.pptx
Set 3 (all.pptx)
A.pptx
B.pptx
C.pptx
D.pptx
E.pptx
If i change any one of the Pptx (A,b,c,d,e) the combined files should be updated automatically
The simplest and probably most reliable solution would be to put all of the slides into one file and then create custom shows, one for each target audience.
Another approach would be to have a main "menu" presentation, one slide with links to sub-presentations, one per audience. Each of those presentations would have its own "menu" slide that links to A.pptx, B.pptx etc. as needed.
At the end of A.pptx, add an End Presentation link; click on that (or just press ESC to quit the presentation) and you'll be returned to the sub-menu presentation.
This is possible with VBS on a Windows with installed PowerPoint.exe.
Create a script named merge.vbs with this content:
Option Explicit
Sub WriteLine ( strLine )
WScript.Stdout.WriteLine strLine
End Sub
Sub WriteError ( strLine )
WScript.Stderr.WriteLine strLine
End Sub
Dim inputFile1
Dim inputFile2
Dim outputFile
Dim objPPT
Dim objFso
Dim objPresentation
If WScript.Arguments.Count <> 3 Then
WriteError "You need to specify 2 input files and one output file."
WScript.Quit 1
End If
inputFile1 = WScript.Arguments(0)
inputFile2 = WScript.Arguments(1)
outputFile = WScript.Arguments(2)
Set objFso = CreateObject("Scripting.FileSystemObject")
If Not objFso.FileExists( inputFile1 ) Then
WriteError "Unable to find your input file " & inputFile1
WScript.Quit 1
End If
If Not objFso.FileExists( inputFile2 ) Then
WriteError "Unable to find your input file " & inputFile2
WScript.Quit 1
End If
WriteLine "Input File 1 : " & inputFile1
WriteLine "Input File 2 : " & inputFile2
WriteLine "Output File: " & outputFile
Set objPPT = CreateObject( "PowerPoint.Application" )
' Open presentation with window hidden
Set objPresentation = objPPT.Presentations.Open(inputFile1, True, False, False)
mergeAndKeepSourceFormatting objPresentation, inputFile2
' Reference for this at https://learn.microsoft.com/en-us/office/vba/api/powerpoint.presentation.saveas
WriteLine "Saving File: " & outputFile
objPresentation.SaveAs outputFile
objPresentation.Close
ObjPPT.Quit
'
' Add the file to the loaded presentation
'
Sub mergeAndKeepSourceFormatting(ByRef objPresentation, ByVal newPptxFile)
WriteLine "Merging file: " & newPptxFile
Dim newSlides
Dim oldSlides
oldSlides = objPresentation.Slides.Count
newSlides = objPresentation.Slides.InsertFromFile( newPptxFile, objPresentation.Slides.Count)
objPresentation.Slides.Range(FillRangeArray(oldSlides + 1, oldSlides + newSlides)).ApplyTemplate newPptxFile
End Sub
Function FillRangeArray(n1, n2)
Dim myArr()
Redim myArr(n2 - n1)
Dim i
For i = 0 to (n2 - n1)
myArr(i) = n1 + i
Next
FillRangeArray = myArr
End Function
Then from the command line you can call it:
CSCRIPT merge.vbs "A.pptx" "B.pptx" "resultA_B.pptx"
Please adjust the script to your needs or call it several times to merge the resulting file with the next one.

Using vbscript to save OpenOffice/Spreadsheet csv file [duplicate]

I'm trying to write a script for a while now but it seems that one part of it just does not work.
Situation: I need a VB script that can use any LibreOffice (/ OpenOffice) Calc (3.5.4 in my case) installation on any Windows XP or 7 system for export of xls to csv (as many csv files as there are sheets in the xls). It has to be VBS and LibreOffice in this case. No macro installed, everything controlled externally by vbscript.
So, first step was to use the macro recorder in order to get the right filter settings.
StarBasic macro:
dim document as object
dim dispatcher as object
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
dim args1(2) as new com.sun.star.beans.PropertyValue
args1(0).Name = "URL"
args1(0).Value = "file:///C:/Users/lutz/Desktop/test.csv"
args1(1).Name = "FilterName"
args1(1).Value = "Text - txt - csv (StarCalc)"
args1(2).Name = "FilterOptions"
args1(2).Value = "9,0,76,1,,0,false,true,true"
dispatcher.executeDispatch(document, ".uno:SaveAs", "", 0, args1())
This macro (in LibreOffice) writes a CSV of the current sheet (after LO telling me that only the current sheet will be saved), encoding UTF-8, field separator Tab, no text separator. This works.
I tried to get this to work in my vbs but it absolutely did not. So I searched a lot in OpenOffice and LibreOffice forums, here at stackoverflow, etc. and used another method.
Problem: Everytime it saves the file(s) it saves them as ODS, no matter which filter or filter options I use. It always saves to zipped OpenDocument. I tried numerous Filters, even PDF. It seems that it works with pdf when I only use the FilterName property but somehow it doesn't work anymore. And I don't know why.
The code:
' Scripting object
Dim wshshell
' File system object
Dim objFSO
' OpenOffice / LibreOffice Service Manager
Dim objServiceManager
' OpenOffice / LibreOffice Desktop
Dim objDesktop
' Runcommand, if script does not run with Cscript
Dim runcommand
Dim Path
Dim Savepath
Dim Filename
Dim url
Dim args0(0)
Dim args1(3)
' Create File system object
Set wshshell = CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
' If not run in cscript, run in cscript
if instr(1, wscript.fullname, "cscript.exe")=0 then
runcommand = "cscript //Nologo xyz.vbs"
wshshell.run runcommand, 1, true
wscript.quit
end if
' If files present, run Calc
If objFSO.GetFolder(".").Files.Count>0 then
Set objServiceManager = WScript.CreateObject("com.sun.star.ServiceManager")
' Create Desktop
Set objDesktop = objServiceManager.createInstance("com.sun.star.frame.Desktop")
else
' If no files in directory
wscript.echo "No files found!"
wscript.quit
End If
on error resume next
bError=False
For each File in objFSO.GetFolder(".").Files
if lcase(right(File.Name,3))="xls" then
' Access file
url = ConvertToURL(File.Path)
objDesktop = GlobalScope.BasicLibraries.loadLIbrary( "Tools" )
Set args0(0) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set objDocument = objDesktop.loadComponentFromURL(url, "_blank", 0, args0 )
' Read filenames without extension or path
Path = ConvertToURL( File.ParentFolder ) & "/"
Filename = objFSO.GetBaseName( File.Path )
Savepath = ConvertToURL( File.ParentFolder )
' set arguments
Set args1(0) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set args1(1) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set args1(2) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
sFilterName = "Text - txt - csv (StarCalc)"
sFilterOptions = "9,0,76,1,,0,false,true,true"
sOverwrite = True
Set args1(0) = MakePropertyValue( "FilterName", sFilterName )
Set args1(1) = MakePropertyValue( "FilterOptions", sFilterOptions )
Set args1(2) = MakePropertyValue( "Overwrite", sOverwrite )
' Save every sheet in separate csv file
objSheets = objDocument.Sheets
For i = 0 to objDocument.Sheets.getcount -1
objSheet = objDocument.Sheets.getByIndex(i)
Call objDocument.CurrentController.setActiveSheet(objSheet)
Call objDocument.storeToURL( ConvertToURL( File.ParentFolder & "\" & Filename & "_" & objDocument.sheets.getByIndex(i).Name & ".csv" ), args1 )
Next
' Close document
objDocument.close(True)
Set objDocument = Nothing
Path = ""
Savepath = ""
Filename = ""
Else
End If
Next
' Close / terminate LibreOffice
objDesktop.terminate
Set objDesktop = nothing
Set objServiceManager = nothing
The function ConvertToUrl is not listed here. It is a vbscript function that converts Windows paths to URL paths (file:/// etc.). It is tested and works.
What I also tried:
Saving in ods first (StoreAsUrl) then try to save in different format.
Use MakePropertyValue( "SelectionOnly", true )
None of that worked nor did it combined. I used http://extensions.services.openoffice.org/de/project/OOcalc_multi_sheets_export as a source of inspiration. But it is a macro, not direct access from an external vb script.
It seems that the problem is a general one with StoreToUrl or the properties / arguments:
Even FilterName "writer_pdf" or "Calc MS Excel 2007 XML" don't work. Problem is: I don't know what's the culprit here. The settings that the macro recorder uses are the same and if one uses the macro directly in LibreOffice it works.
Maybe someone knows what needs to get changed in the code or how I can get the dispatcher used in the macro to work.
Thank you for your help in advance!
Ok, I found the solution after days of research and tiny little information scattered everywhere. I hope that this code will serve someone well:
' Variables
Dim wshshell ' Scripting object
Dim oFSO ' Filesystem object
Dim runcommand ' Runcommand, if not run in Cscript
Dim oSM ' OpenOffice / LibreOffice Service Manager
Dim oDesk ' OpenOffice / LibreOffice Desktop
Dim oCRef ' OpenOffice / LibreOffice Core Reflections
Dim sFileName ' Filename without extension
Dim sLoadUrl ' Url for file loading
Dim sSaveUrl ' Url for file writing
Dim args0(0) ' Load arguments
' Create file system object
Set wshshell = CreateObject("Wscript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
' If not run in cscript, run in cscript
if instr(1, wscript.fullname, "cscript.exe")=0 then
runcommand = "cscript //Nologo xyz.vbs"
wshshell.run runcommand, 1, true
wscript.quit
end if
' If there are files, start Calc
If oFSO.GetFolder(".").Files.Count>0 then
' If no LibreOffice open -> run
Set oSM = WScript.CreateObject("com.sun.star.ServiceManager")
' Create desktop
Set oDesk = oSM.createInstance("com.sun.star.frame.Desktop")
Set oCRef = oSM.createInstance( "com.sun.star.reflection.CoreReflection" )
else
' If no files in directory
wscript.quit
End If
' Error handling
on error resume next
' CSV settings for saving of file(s)
sFilterName = "Text - txt - csv (StarCalc)"
sFilterOptions = "9,0,76,1,,0,false,true,true"
sOverwrite = True
' load component for file access
oDesk = GlobalScope.BasicLibraries.loadLIbrary( "Tools" )
' load argument "hidden"
Set args0(0) = oSM.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set args0(0) = MakePropertyValue("Hidden", True)
For each oFile in oFSO.GetFolder(".").Files
if lcase(right(oFile.Name,3))="xls" then
' open file
sLoadUrl = ConvertToURL(oFile.Path)
Set oDoc = oDesk.loadComponentFromURL(sLoadUrl, "_blank", 0, args0 )
' read filename without extension or path
sFileName = oFSO.GetBaseName( oFile.Path )
' save sheets in CSVs
For i = 0 to oDoc.Sheets.getcount -1
oActSheet = oDoc.CurrentController.setActiveSheet( oDoc.Sheets.getByIndex(i) )
sSaveUrl = ConvertToURL( oFile.ParentFolder & "\" & sFileName & "_" & oDoc.sheets.getByIndex(i).Name & ".csv" )
saveCSV oSM, oDoc, sSaveUrl, sFilterName, sFilterOptions, sOverwrite
Next
' Close document
oDoc.close(True)
Set oDoc = Nothing
Set oActSheet = Nothing
sFileName = ""
sLoadUrl = ""
sSaveUrl = ""
Else
End If
Next
' Close LibreOffice
oDesk.terminate
Set oDesk = nothing
Set oSM = nothing
Function ConvertToURL(sFileName)
' Convert Windows pathnames to url
Dim sTmpFile
If Left(sFileName, 7) = "file://" Then
ConvertToURL = sFileName
Exit Function
End If
ConvertToURL = "file:///"
sTmpFile = oFSO.GetAbsolutePathName(sFileName)
' replace any "\" by "/"
sTmpFile = Replace(sTmpFile,"\","/")
' replace any "%" by "%25"
sTmpFile = Replace(sTmpFile,"%","%25")
' replace any " " by "%20"
sTmpFile = Replace(sTmpFile," ","%20")
ConvertToURL = ConvertToURL & sTmpFile
End Function
Function saveCSV( oSM, oDoc, sSaveUrl, sFilterName, sFilterOptions, sOverwrite )
' Saves the open document resp. active sheet in a single file
Dim aProps( 2 ), oProp0, oProp1, oProp2, vRet
' Set filter name and write into property array
Set oProp0 = oSM.Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oProp0.Name = "FilterName"
oProp0.Value = sFilterName
Set aProps( 0 ) = oProp0
' Set filter options and write into property array
Set oProp1 = oSM.Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oProp1.Name = "FilterOptions"
oProp1.Value = sFilterOptions
Set aProps( 1 ) = oProp1
' Set file overwrite and write into property array
Set oProp2 = oSM.Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oProp2.Name = "Overwrite"
oProp2.Value = sOverwrite
Set aProps( 2 ) = oProp2
' Save
vRet = oDoc.storeToURL( sSaveUrl, aProps )
End Function
I hope that at least this small contribution from me helps others.

Export all charts from multiple Excel files in one folder

I want to create a macro for exporting all Excel charts from several workbooks in one folder.
I'm a beginner in VBA and I need your help with the following code:
P.S. The code seems to work (I don't have errors) but does not export any graph to the selected folder.
Could you, please, help me with some hints? I don`t know where is the problem.
Thank you in advance! :)
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them (export all charts in one folder)
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim objChart As Excel.Chart
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
'myExtension = "*.xls*"
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
For Each objChart In wb.Charts
objChart.Export myPath & Left(wb.Name, Len(wb.Name) - 5) & "_" & objChart.Name & ".png"
Next objChart
For Each objSheet In wb.Worksheets
For Each objChartObject In objSheet.ChartObjects
With objChartObject.Chart
.Export myPath & Left(wb.Name, Len(wb.Name) - 4) & "_" & .Name & "png" '/export graphs with WorkbookName + _worksheet name
End With
Next
Next
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'Open the windows folder
Shell "Explorer.exe" & " " & myPath, vbNormalFocus
End Sub
Maybe is useful to mention that I wanted to adapt one of my oldest macro (this one export all the charts from a workbook in one folder. Now I need to export all the charts from multiple workbooks in one folder).
Sub ExportAllCharts()
'
' '
' This macro extracts all the graphs from an Excel document and imports them into the selected folder as .PNG images. '
'
' '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim objShell As Object
Dim objWindowsFolder As Object
Dim strWindowsFolder As String
Dim objSheet As Excel.Worksheet
Dim objChartObject As Excel.ChartObject
Dim objChart As Excel.Chart
'Sheets.Select
'ActiveSheet.Select
'Select a Windows folder
Set objShell = CreateObject("Shell.Application")
Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows folder:", 0, "")
If Not objWindowsFolder Is Nothing Then
strWindowsFolder = objWindowsFolder.self.Path & "\"
''''''''''''''''''''''''''
' charts on chart sheets '
''''''''''''''''''''''''''
'For Each objChart In ThisWorkbook.Charts
For Each objChart In ActiveWorkbook.Charts
objChart.Export strWindowsFolder & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & "_" & objChart.Name & ".png" '/export graphs with workbook name prefix + _ + worksheet name ( ex: WorkbookName_WorksheetName.png ---> OK)
Next objChart
'Open the windows folder
Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus
End If
End Sub

How to recover the outlook emails for a deleted email account

I accidentally delete my email account and so all of the emails in that account. Is there a chance to recover the emails? How can I recover it? Thanks.
Four months ago I would have agreed with Om3r's comment giving the location of the Outlook stores. But I bought a new laptop in December and now the Outlook files are not where all the documentation says they should be. Worse, I cannot reach the folders containing the Outlook files using File Explorer although I can find them with VBA.
The macro below searches drive C for files with an extension of OST or PST. I cannot promise this macro will find your lost store but, if it is still on your disc, it will find it. If you find the missing store, you will probably have to use VBA to move it to somewhere accessible.
Copy the macro below to a macro-enabled workbook and run it. While it is running the active worksheet will look like:
1923 Folders to search
327 Folders searched
Store Size Date Folder
$ILJARJ0.pst 212 28Mar20 C:\$Recycle.Bin\S-1-5-21-3957073674-21115239-22921093-1001
$IMS96DJ.pst 212 28Mar20 C:\$Recycle.Bin\S-1-5-21-3957073674-21115239-22921093-1001
The top two rows give a crude progress indicator. On my laptop, the routine ends with 69190 folders searched. I do not know why there are PST files in my recycle bin. I did nothing relevant on 28 March. When the routine has finished, there will be a auto-fitted list of every store the macro found. On my laptop none are where I would expect and some are duplicates. I hope you find your store.
Option Explicit
Sub SearchForStoresOnC()
' Searches drive C for files with an extension of PST or OST
' Warning: overwrites the active workbook
Dim ErrNum As Long
Dim FileAttr As Long
Dim FileName As String
Dim FldrName As String
Dim RowCrnt As Long
Dim ToSearch As Collection
Cells.EntireRow.Delete
Range("A1").Value = 0
Range("A2").Value = 0
Range("B1").Value = "Folders to search"
Range("B2").Value = "Folders searched"
Range("B4").Value = "Store"
With Range("C4")
.Value = "Size"
.HorizontalAlignment = xlRight
End With
With Range("D4")
.Value = "Date"
.HorizontalAlignment = xlRight
End With
Range("E4") = "Folder"
RowCrnt = 5
Set ToSearch = New Collection
' Load ToSearch with drive to search.
ToSearch.Add "C:"
Do While ToSearch.Count > 0
FldrName = ToSearch(1)
ToSearch.Remove 1
Err.Clear
ErrNum = 0
On Error Resume Next
' Stores are unlikely to be hidden but can be in folders that are hidden
FileName = Dir$(FldrName & "\*.*", vbDirectory + vbHidden + vbSystem)
ErrNum = Err.Number
On Error GoTo 0
If ErrNum <> 0 Then
'Debug.Print "Dir error: " & FldrName
Else
Do While FileName <> ""
If FileName = "." Or FileName = ".." Then
' Ignore pointers
Else
Err.Clear
On Error Resume Next
FileAttr = GetAttr(FldrName & "\" & FileName)
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
' Ignore file and folders which give errors
If (FileAttr And vbDirectory) = 0 Then
' File
'Debug.Assert False
Select Case Right$(FileName, 4)
Case ".pst", ".ost"
Cells(RowCrnt, "B").Value = FileName
With Cells(RowCrnt, "C")
.Value = FileLen(FldrName & "\" & FileName)
.NumberFormat = "#,##0"
End With
With Cells(RowCrnt, "D")
.Value = FileDateTime(FldrName & "\" & FileName)
.NumberFormat = "dmmmyy"
End With
Cells(RowCrnt, "E").Value = FldrName
RowCrnt = RowCrnt + 1
End Select
Else
' Directory
ToSearch.Add FldrName & "\" & FileName
End If ' File or Directory
Else
'Debug.Print "FileAttr error: " & FldrName & "\" & FileName
End If ' FileAttr does not give an error
End If ' Pointer or (File or Directory)
FileName = Dir$
Loop ' For each pointer, file and sub-directory in folder
End If ' Dir$ gives error
Range("A1") = ToSearch.Count
Range("A2") = Range("A2") + 1
DoEvents
Loop 'until ToSearch empty
Columns.AutoFit
End Sub

Excel VB Open File OSX and Windows

I've got a spreadsheet that uses some basic code to get the user to select a file (txt file). It works flawlessly on Windows but fails on OSX obviously due to the difference in FileDialog calls. I've done some research though and can't seem to find much information about opening a File Dialog on both OSX and Windows for Excel/VB.
The current code is,
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a file to import", _
FileFilter:="Excel Files *.xls (*.xls),")
''
If FileToOpen = False Then
MsgBox "No file specified.", vbExclamation, "Duh!!!"
Exit Sub
Else
Workbooks.Open Filename:=FileToOpen
End If
Answer can be found here - http://msdn.microsoft.com/en-us/library/office/hh710200%28v=office.14%29.aspx
Code is as follows,
OSX
Sub Select_File_Or_Files_Mac()
Dim MyPath As String
Dim MyScript As String
Dim MyFiles As String
Dim MySplit As Variant
Dim N As Long
Dim Fname As String
Dim mybook As Workbook
On Error Resume Next
MyPath = MacScript("return (path to documents folder) as String")
'Or use MyPath = "Macintosh HD:Users:Ron:Desktop:TestFolder:"
' In the following statement, change true to false in the line "multiple
' selections allowed true" if you do not want to be able to select more
' than one file. Additionally, if you want to filter for multiple files, change
' {""com.microsoft.Excel.xls""} to
' {""com.microsoft.excel.xls"",""public.comma-separated-values-text""}
' if you want to filter on xls and csv files, for example.
MyScript = _
"set applescript's text item delimiters to "","" " & vbNewLine & _
"set theFiles to (choose file of type " & _
" {""com.microsoft.Excel.xls""} " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ multiple selections allowed true) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return theFiles"
MyFiles = MacScript(MyScript)
On Error GoTo 0
If MyFiles <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
MySplit = Split(MyFiles, ",")
For N = LBound(MySplit) To UBound(MySplit)
' Get the file name only and test to see if it is open.
Fname = Right(MySplit(N), Len(MySplit(N)) - InStrRev(MySplit(N), Application.PathSeparator, , 1))
If bIsBookOpen(Fname) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MySplit(N))
On Error GoTo 0
If Not mybook Is Nothing Then
MsgBox "You open this file : " & MySplit(N) & vbNewLine & _
"And after you press OK it will be closed" & vbNewLine & _
"without saving, replace this line with your own code."
mybook.Close SaveChanges:=False
End If
Else
MsgBox "We skipped this file : " & MySplit(N) & " because it Is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Windows
Sub Select_File_Or_Files_Windows()
Dim SaveDriveDir As String
Dim MyPath As String
Dim Fname As Variant
Dim N As Long
Dim FnameInLoop As String
Dim mybook As Workbook
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' You can also use a fixed path.
'MyPath = "C:\Users\Ron de Bruin\Test"
' Change drive/directory to MyPath.
ChDrive MyPath
ChDir MyPath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="Excel 97-2003 Files (*.xls), *.xls", _
Title:="Select a file or files", _
MultiSelect:=True)
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
If Not mybook Is Nothing Then
MsgBox "You opened this file : " & Fname(N) & vbNewLine & _
"And after you press OK, it will be closed" & vbNewLine & _
"without saving. You can replace this line with your own code."
mybook.Close SaveChanges:=False
End If
Else
MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Picker Function
Sub WINorMAC()
' Test for the operating system.
If Not Application.OperatingSystem Like "*Mac*" Then
' Is Windows.
Call Select_File_Or_Files_Windows
Else
' Is a Mac and will test if running Excel 2011 or higher.
If Val(Application.Version) > 14 Then
Call Select_File_Or_Files_Mac
End If
End If
End Sub
Sub WINorMAC_2()
' Test the conditional compiler constants.
#If Win32 Or Win64 Then
' Is Windows.
Call Select_File_Or_Files_Windows
#Else
' Is a Mac and will test if running Excel 2011 or higher.
If Val(Application.Version) > 14 Then
Call Select_File_Or_Files_Mac
End If
#End If
End Sub

Resources