VB Script referencing a Variable which is defined from a macro - vbscript

I need some help with this VB script (edit: it is being used in QlikView)- it is copying a file to a different location (checks if the file already exists in the destination folder).
It works when the source filename and location is hardcoded but this is going to be a variable which is defined in a different macro.
So the source filename and location will be defined by varFileOpen.
Basically in the code, instead of:
SourceFile = "C:\file_path\file_name.txt"
to be like this:
SourceFile = varFileOpen
where varFileOpen has been defined from a different SUB (it is the full file path).... I can't get it to work?
Sub that creates the varFileOpen:
'Sub to get open file dialog
SUB ShowOpen
OpenSave "varFileOpen", 0, "Text file (*.txt)|*.txt|All files (*.*)|*.*", "h:\", "Select a file to open"
END SUB
' Sub to show browse folder dialog
SUB Folder (objVariable)
ON ERROR RESUME NEXT
SET objShell = CREATEOBJECT("Shell.Application")
SET objFolder = objShell.BrowseForFolder (WINDOW_HANDLE, TITLE, OPTIONS, ROOT)
SET objFolderItem = objFolder.Self
strPathAndFile = objFolderItem.Path
SET objSavePath = ActiveDocument.Variables(objVariable)
objSavePath.SetContent strPathAndFile, TRUE
ON ERROR GOTO 0
END SUB
' Sub to show open/save dialog
SUB OpenSave (objVariable, intType, strFilter, strInitialDirectory, strDialogText)
' Create objects
SET objShell = CREATEOBJECT("WScript.Shell")
SET objFSO = CREATEOBJECT("Scripting.FileSystemObject")
strTempDir = objShell.ExpandEnvironmentStrings("%TEMP%")
strTempFile = strTempDir & "\" & objFSO.GetTempName
' Temporary powershell script file to be invoked
strPSFile = tempFile & ".ps1"
' Temporary file to store standard output from command
strPSOutFile = tempFile & ".txt"
' Create script to run
strPSScript = strPSScript & "[System.Reflection.Assembly]::LoadWithPartialName(""System.windows.forms"") | Out-Null" & vbCRLF
' Check type (Open (0) or Save (1))
IF intType = 1 THEN
strPSScript = strPSScript & "$dlg = New-Object System.Windows.Forms.SaveFileDialog" & vbCRLF
ELSE
strPSScript = strPSScript & "$dlg = New-Object System.Windows.Forms.OpenFileDialog" & vbCRLF
END IF
' Set initial directory
strPSScript = strPSScript & "$dlg.initialDirectory = " & CHR(34) & strInitialDirectory & CHR(34) & vbCRLF
' Set file filter/s
strPSScript = strPSScript & "$dlg.filter = " & CHR(34) & strFilter & CHR(34) & vbCRLF
strPSScript = strPSScript & "$dlg.FilterIndex = 1" & vbCRLF
' Set dialog text
strPSScript = strPSScript & "$dlg.Title = " & CHR(34) & strDialogText & CHR(34) & vbCRLF
' Show help (seems it must be set to true)
strPSScript = strPSScript & "$dlg.ShowHelp = $True" & vbCRLF
' Show the dialog
strPSScript = strPSScript & "$dlg.ShowDialog() | Out-Null" & vbCRLF
strPSScript = strPSScript & "Set-Content """ &strPSOutFile & """ $dlg.FileName" & vbCRLF
' Write result
SET objResultFile = objFSO.CreateTextFile(strPSFile, TRUE)
objResultFile.WriteLine(strPSScript)
objResultFile.Close
SET objResultFile = NOTHING
' Run command in PowerShell
strPSCMD = "powershell -ExecutionPolicy unrestricted &'" & strPSFile & "'"
objShell.Run strPSCMD, 0, TRUE
' Open result file and read result
SET objResultFile = objFSO.OpenTextFile(strPSOutFile, 1, 0, -2)
strPathAndFile = objResultFile.ReadLine
objResultFile.Close
SET objResultFile = NOTHING
' Add to result to variable
SET objSavePath = ActiveDocument.Variables(objVariable)
objSavePath.SetContent strPathAndFile, TRUE
' Delete temp-files
objFSO.DeleteFile(strPSFile)
objFSO.DeleteFile(strPSOutFile)
END SUB
The above code opens explorer & you are able to select a file and the path is copied - varFileOpen.
The following SUB moves the file:
SUB movefile
Const DestinationFile = "c:\destfolder\anyfile.txt"
Const SourceFile = "C:\file_path\file_name.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
'Check to see if the file already exists in the destination folder
If fso.FileExists(DestinationFile) Then
'Check to see if the file is read-only
If Not fso.GetFile(DestinationFile).Attributes And 1 Then
'The file exists and is not read-only. Safe to replace the file.
fso.CopyFile SourceFile, "C:\destfolder\", True
Else
'The file exists and is read-only.
'Remove the read-only attribute
fso.GetFile(DestinationFile).Attributes = fso.GetFile(DestinationFile).Attributes - 1
'Replace the file
fso.CopyFile SourceFile, "C:\destfolder\", True
'Reapply the read-only attribute
fso.GetFile(DestinationFile).Attributes = fso.GetFile(DestinationFile).Attributes + 1
End If
Else
'The file does not exist in the destination folder. Safe to copy file to this folder.
fso.CopyFile SourceFile, "C:\destfolder\", True
End If
Set fso = Nothing
END SUB

You will need to pass the value into the Sub for it to have scope, which means you will need to define the sub like this so that it accepts a parameter
Public Sub MySub(byVal SourceFile)
ByVal just means you pass the Value of the variable rather than the actual variable itself.
And you would call it from the other sub with
MySub varFileOpen
EDIT: Based on the code displayed above, you would need to change Sub movefile to Sub movefile(byVal SourceFile) and remove the Const delaration of SourceFile. Once that was done, all you would have to do is change whatever is calling movefile (I can't see anything in the code you've posted doing this?) to call it with movefile varToOpen instead

Try my CustomFileDialog.
Usage:
Dim fDialog
Set fDialog = New CustomFileDialog
fDialog.FilterString = "Text Files (*.txt)|*.txt"
fDialog.InitialDirectory = "C:\"
fDialog.DialogText = "Select a file to open"
fDialog.Show
fDialog.MoveFile "C:\stackoverflow\temp\New File Name.TXT"
CustomFileDialog
Class CustomFileDialog
Public SourceFile
Public FilterString
Public InitialDirectory
Public DialogText
Public Sub Show
Set toolkit = CreateObject("Vbsedit.toolkit")
Files = toolkit.OpenFileDialog(InitialDirectory, FilterString, False, DialogText)
If UBound(Files) >= 0 Then
SourceFile = Files(0)
Else
SourceFile = ""
End If
End Sub
Public Sub MoveFile(DestinationFile)
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(DestinationFile) Then fso.DeleteFile DestinationFile, True
fso.CopyFile SourceFile, DestinationFile, True
End Sub
End Class

Related

How can I pass the argument in vbs

I'm a linux guy and new to windows, im trying to create a small vbs script to create bunch of folders.
Im trying to create a mainfolder according to user input and 4 subfolder in it with static names. I somehow got two seperate working scripts for mainfolder and subfolder but I would like to combine them both which means once the mainfolder is created as per user input next it should create subfolders below that.
Script which creates Mainfolder.vbs as per user input:
strfolder = InputBox("Please enter a name for your new folder:")
set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.CreateFolder "C:\test\" & strfolder
Script which creates subfolders.vbs folders:
Option Explicit
dim wshShell
set wshShell = wscript.CreateObject("WScript.Shell")
DIM fSO
DIM foldername1
DIM foldername2
DIM foldername3
DIM foldername4
foldername1=("subfolder1")
foldername2=("subfolder2")
foldername3=("subfolder3")
foldername4=("subfolder4")
dim folderpath
SET FSO=CreateObject("Scripting.FileSystemObject")
folderpath = "C:\test" & _
"\" & foldername1
wscript.echo "Creating folder: " & folderpath
FSO.CREATEFOLDER(folderpath)
folderpath = "C:\test" & _
"\" & foldername2
wscript.echo "Creating folder: " & folderpath
FSO.CREATEFOLDER(folderpath)
folderpath = "C:\test" & _
"\" & foldername3
wscript.echo "Creating folder: " & folderpath
FSO.CREATEFOLDER(folderpath)
folderpath = "C:\test" & _
"\" & foldername4
wscript.echo "Creating folder: " & folderpath
FSO.CREATEFOLDER(folderpath)
In short, how can I create a mainfolder as per user input and subfolders with static names?
would like to combine these both and work together as a single script.
You can try with this subroutine : SmartCreateFolder(strFolder)
Sub SmartCreateFolder(strFolder)
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(strFolder) then
SmartCreateFolder(.getparentfoldername(strFolder))
.CreateFolder(strFolder)
End If
End With
End Sub
The combined whole script can be written like that :
Option Explicit
Const Title = "SmartCreateFolder"
Const Time2Wait = 2
Dim ws,MainFolderPath,MainFolderName,SubFolderPath,Arr_SubFolder_Name,i
Set ws = CreateObject("wscript.shell")
Arr_SubFolder_Name = Array("subfolder1","subfolder2","subfolder3","subfolder4")
MainfolderName = InputBox(_
"Please enter a name for your new folder :",Title,"Type the name here")
If MainfolderName = "" Then Wscript.Quit(1)
MainFolderPath = "C:\test\" & MainfolderName
For i=LBound(Arr_SubFolder_Name) To UBound(Arr_SubFolder_Name)
Call SmartCreateFolder(MainFolderPath)
SubFolderPath = MainFolderPath & "\" & Arr_SubFolder_Name(i)
Call SmartCreateFolder(SubFolderPath)
Next
ws.run "Explorer " & MainFolderPath
'---------------------------------------------------------------
Sub SmartCreateFolder(strFolder)
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(strFolder) then
ws.Popup "Creating folder: " & StrFolder,Time2Wait,_
Title,vbInformation+vbSystemModal
SmartCreateFolder(.getparentfoldername(strFolder))
.CreateFolder(strFolder)
End If
End With
End Sub
'---------------------------------------------------------------

VBS - File Created But I Can't See It Or Open It

I was trying to build a VBS to test creating files because a larger script I wrote isn't creating an output file. The point of the following script is to test functionality; which I'm not currently seeing.
Option Explicit
Dim objFSO, objFSOText, objFolder, objFile
Dim strDirectory, strFile
strDirectory = "C:\Test\next"
strFile = "\Try.txt"
' Create the File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Create the Folder specified by strDirectory on line 10
Set objFolder = objFSO.CreateFolder(strDirectory)
' -- The heart of the create file script
'-----------------------
'Creates the file using the value of strFile on Line 11
' -----------------------------------------------
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
Wscript.Echo "Just created " & strDirectory & strFile
Wscript.Quit
While running this code, everything works the first time but there isn't an output file in the destination directory. When I run it again it throws an error that the file already exists.
I think the problem is that you are trying to create the path "C:\Test\next", which is a structure of two nested folders) in one go and also do not test if that path already exists.
To create a nested folder structure, I have added a small helper function CreateNestedFolder to your code and tidied it up a bit:
Option Explicit
Dim strDirectory, strFile, overwrite
strDirectory = "C:\Test\next"
strFile = "Try.txt"
overwrite = True 'set this to False if you do not wish to overwrite an existing file
'Create the (nested) Folder Structure specified by strDirectory if it does not exist yet
If Not CreateNestedFolder(strDirectory) Then
Wscript.Echo "Could not create folder " & strDirectory
Else
Dim objFSO, objFile
' Create the File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
' -- The heart of the create file script
'-----------------------
'Creates the file using the value of strFile
' -----------------------------------------------
'combine the directory and filename
strFile = strDirectory & "\" & strFile
'Create the new file and write something in it
Set objFile = objFSO.CreateTextFile(strFile, overwrite)
objFile.WriteLine("This is a test.")
objFile.Close
Wscript.Echo "Just created " & strFile
'Clean up the used objects
Set objFile = Nothing
Set objFSO = Nothing
End If
Function CreateNestedFolder(ByVal sPath)
'Helper function to create a nested folder structure.
'Returns True on success, False otherwise
Dim aFolders, oFso, i, firstIndex
On Error Resume Next
Set oFso = CreateObject("Scripting.FileSystemObject")
'Check if the path already exists
If Not oFso.FolderExists(sPath) Then
'Find the root drive and split the path in subfolder parts
aFolders = Split(sPath, "\")
'Get the root path from the complete path
If Left(sPath, 2) = "\\" Then
'If this is a UNC path then the root will be "\\server\share"
sPath = "\\" & aFolders(2) & "\" & aFolders(3)
firstIndex = 4
Else
'For a local path, the root is "X:"
aFolders = Split(sPath, "\")
sPath = aFolders(0)
firstIndex = 1
End If
'Loop through the aFolders array and create new folders if needed
For i = firstIndex to UBound(aFolders)
If Len(aFolders(i)) > 0 Then
sPath = sPath & "\" & aFolders(i)
If Not oFso.FolderExists(sPath) Then oFso.CreateFolder sPath
End If
Next
End If
CreateNestedFolder = (Err.Number = 0)
On Error GoTo 0
Set oFso = Nothing
End Function

Copy file names at Recycle Bin

I'm trying to copy all filenames list on the Recycle Bin in Windows 10.
I go to Command Prompt:
C:\>cd C:/$Recycle.Bin
C:\$Recycle.Bin>dir S-1-5-21-2370250818-2711005194-4184312249-1165
$R8CQG1I.txt
$IURO2ZD.txt
$RV2TEJ7.txt
I have 3 files I want to copy the real file names not the names like this result.
After some search I found this VBScript. I run the code and I get this error:
Expected end of statement
Option Explicit
DIM g_objWshShell, g_objFSO, g_sLogFile, g_objWshNetwork, g_sScriptName, g_sComputerName, g_sUserName Dim g_sVer, g_objLogFile, g_sLogDir
'Setup main variables and objects Set g_objWshShell = WScript.CreateObject("WScript.Shell") 'Create a Shell Object Set g_objFSO = CreateObject("Scripting.FileSystemObject") 'create a File System Object Set g_objWshNetwork = WScript.CreateObject("WScript.Network") 'Create Network Object g_sComputerName
= g_objWshNetwork.Computername 'Gets machine Computer name g_sUserName = g_objWshNetwork.UserName 'Gets logged-on username g_sScriptName=UCase(WScript.ScriptName) '
*** Name of the script
' *** START LogFile Information - use Delete or Append info below; don't use both *** Const FORREADING = 1, FORWRITING = 2, FORAPPENDING
= 8 'Setup constants for writing, appending, etc g_sLogDir = "C:\TEMP" If Not (g_objFSO.FolderExists(g_sLogDir)) Then g_objFSO.CreateFolder(g_sLogDir) End If g_sLogFile = g_sLogDir & "\" & Left(g_sScriptName,len(g_sScriptName)
- 3) & "LOG" 'Makes log file the SCRIPTNAME.Log g_sVer = "1.0"
'To delete a logfile and create a new one each time script is ran If g_objFSO.FileExists(g_sLogFile) Then g_objFSO.DeleteFile(g_sLogFile) 'Delete logfile if it exists. End If Set g_objLogFile = g_objFSO.CreateTextFile(g_sLogFile, FORWRITING) 'Setup the logfile for writing
Call Main() Call ExitScript()
'Start main script HERE *** Sub Main() Dim objRecycleBin, objFolderItems, objItem, strSpecialFolderName strSpecialFolderName = "Recycle Bin" 'Call WriteLine("Starting " & g_sScriptName & " at " & Date & " " & Time, g_objLogFile) Set objRecycleBin
= GetSpecialFolderObject(strSpecialFolderName) 'Get Special Folder based upon input name Set objFolderItems = objRecycleBin.Items() 'Get items within Recycle Bin For Each objItem In objFolderItems 'Delete all items within Special Folder If (objItem.Type = "File Folder") Then 'Check for file type g_objFSO.DeleteFolder(objItem.Path) 'Delete Folders Else g_objFSO.DeleteFile(objItem.Path) 'Delete Files End If WScript.Echo "Deleted " & objItem.Name Next End Sub
'*-*-*-*-*- Start Subroutines here
*-*-*-*-*- 'Returns SpecialFolder based upon name of folder Function GetSpecialFolderObject(NameOfFolder) Dim objShellApp, i, objSpecialFolder Set objShellApp = CreateObject("Shell.Application") On Error Resume Next For i=0 To 40 '40 is highest value for special folders Set objSpecialFolder = objShellApp.NameSpace(i) If (StrComp(objSpecialFolder.Title,NameOfFolder,vbTextCompare)=0) Then Set GetSpecialFolderObject = objSpecialFolder Exit For End If Next Err.Clear End Function
'Closes logfile and exits script Sub ExitScript() 'Call WriteLine(Date & " " & Time & "; Completed " & g_sScriptName, g_objLogFile) If IsObject(g_objLogFile) Then
g_objLogFile.Close End If Wscript.Quit End Sub
Sub EndOnError(sErrorString) WScript.Echo sErrorString & vbcrlf & "Check " & chr(34) & g_sLogFile & Chr(34) & " for details" Call WriteLine (sErrorString, g_objLogFile) WScript.Quit() End Sub
'Shows usage if input is wrong sub ShowUsage() WScript.Echo g_sScriptName & " v" & g_sVer & " Empties Recycle Bin for logged on user" & vbcrlf _ & vbcrlf & "USAGE: [CSCRIPT] " & g_sScriptName WScript.Quit end sub
'Writes to log Sub WriteLine(ByVal strMessage, ByVal objFile)
On Error Resume Next
If IsObject(objFile) then 'objFile should be a file object
objFile.WriteLine strMessage
Else
Call Wscript.Echo( strMessage )
End If End Sub
The VBScript version of #boxdog answer:
Set objShellApp = CreateObject("Shell.Application")
Set objSpecialFolder = objShellApp.NameSpace(10) '10 = Recyle Bin
For Each objFolder In objSpecialFolder.Items
WScript.Echo "FileName = " & objFolder.Name & vbTab & "Original Path = " & objFolder.ExtendedProperty("{9B174B33-40FF-11D2-A27E-00C04FC30871} 2")
Next
Answering this in case anyone is looking for VBS only solution.
In PowerShell, you can list the current path and original name/location of the Recycle Bin contents like This:
$shell = New-Object -ComObject Shell.Application
$shell.NameSpace(0x0a).Items() |
Select-Object #{Label="OriginalLocation";Expression={$_.ExtendedProperty("{9B174B33-40FF-11D2-A27E-00C04FC30871} 2")}},Name, Path
To copy the items, you can do this:
$shell.NameSpace(0x0a).Items() |
Copy-Item -Destination "C:\RecoveredFiles\$($_.Name)" -Recurse -Force
Note that this doesn't take into account any name-clashes - you'll need to test for that and adjust accordingly.

Replace a specific string with the filename?

How to replace a specific string with the filename? Example: I have several files with different names (like: Test.asp, Constant.asp, Letter.asp, etc.) within a subfolder that contain the text "ABC123". I would like to replace the "ABC123" in each file with the filename.
Below is the code I have that finds string and replaces it with a specific string but it doesn't do the job that I listed above.
Option Explicit
Dim objFilesystem, objFolder, objFiles, objFile, tFile, objShell, objLogFile,objFSO, objStartFolder, colFiles
Dim SubFolder, FileText, bolWriteLog, strLogName, strLogPath, strCount, strCount2, strOldText, strNewText, strEXT
bolWriteLog = True
Const ForReading = 1
Const ForWriting = 2
Const TriStateUseDefault = -2
Set objFilesystem = WScript.CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
strLogName = "log.txt"
strLogPath = "C:\" & strLogName
strCount = 0
strCount2 = 0
strOldText = "ABC123"
strNewText = ""
strEXT = "asp"
'Initialize log file
If bolWriteLog Then
On Error Resume Next
Set objLogFile = objFileSystem.OpenTextFile(strLogPath, 2, True)
WriteLog "############### Start Log ##################"
If Not Err.Number = 0 Then
MsgBox "There was a problem opening the log file for writing." & Chr(10) & _
"Please check whether """ & strLogPath & """ is a valid file and can be openend for writing." & _
Chr(10) & Chr(10) & "If you're not sure what to do, please contact your support person.", vbCritical, "Script Error"
WScript.Quit
End If
On Error Goto 0
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
objStartFolder = "D:\MyFolder"
Set objFolder = objFSO.GetFolder(objStartFolder)
WScript.Echo objFolder.Path
Set colFiles = objFolder.Files
For Each objFile In colFiles
'WScript.Echo objFile.Name
' Now we have an exception for all files that can not be opened in text modus: all extensions such as "exe" should be listed upfront.
ReplaceText(objFile)
Next
ShowSubfolders objFSO.GetFolder(objStartFolder)
Sub ReplaceText(objFile)
If InStr(1, strEXT, Right(LCase(objFile.Name), 3)) = 0 Or objFile.Size = 0 Then
Else
strCount = strCount + 1
WriteLog("Opening " & objFile.Name)
Set tFile = objFile.OpenAsTextStream(ForReading, TriStateUseDefault)
FileText = tFile.ReadAll
tFile.Close
If InStr(FileText, strOldText) Then
WriteLog("Replacing " & strOldText & " with " & strNewText & ".")
FileText = Replace(FileText, strOldText, strNewText)
WriteLog("Text replaced")
Else
WriteLog(strOldText & " was not found in the file.")
strCount2 = strCount2 + 1
End If
Set tFile = objFile.OpenAsTextStream(ForWriting, TriStateUseDefault)
tFile.Write FileText
tFile.Close
FileText = ""
strCount = 0
strCount2 = 0
End If
End Sub
Sub ShowSubFolders(Folder)
For Each Subfolder in Folder.SubFolders
'WScript.Echo Subfolder.Path
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
For Each objFile in colFiles
'WScript.Echo objFile.Name
ReplaceText(objFile)
Next
ShowSubFolders Subfolder
Next
End Sub
WriteLog "############### EndLog ##################"
WScript.Echo "Script Complete"
objShell.Run "C:\" & strLogName
'Clear environment and exit
On Error Resume Next
Set tFile = Nothing
Set objFile = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objLogFile = Nothing
Set objFilesystem = Nothing
Set objShell = Nothing
WScript.Quit
'Subs and functions ********** DO NOT EDIT ***************
Sub WriteLog(sEntry)
If bolWriteLog Then objLogFile.WriteLine(Now() & ": Log: " & sEntry)
End Sub
I can give you a one line Ruby solution, should be not too difficult to translate that in Python but somewhat more extensive in VbScript I am afraid. First a generic search and replace version.
ARGV[0..-3].each{|f| File.write(f, File.read(f).gsub(ARGV[-2],ARGV[-1]))}
Save it in a script, eg replace.rb
You start in on the command line (here cmd.exe) with
replace.rb *.txt <string_to_replace> <replacement>
broken down so that I can explain what's happening but still executable
# ARGV is an array of the arguments passed to the script.
ARGV[0..-3].each do |f| # enumerate the arguments of this script from the first to the last (-1) minus 2
File.write(f, # open the argument (= filename) for writing
File.read(f) # open the argument (= filename) for reading
.gsub(ARGV[-2],ARGV[-1])) # and replace all occurances of the beforelast with the last argument (string)
end
And finally your request to replace ABC123 with the filename.
Of course tested and working
ARGV[0..-1].each{|f| File.write(f, File.read(f).gsub('ABC123', f))}
Contents of one of my testfiles (1.txt) after executing
test phrase
1.txt
EDIT
I see you want subfolder recursion on a fixed folder, no problem
Dir['**/*'].each{|f| File.write(f, File.read(f).gsub('ABC123', f)) unless File.directory?(f) }

Open/Save File Dialog That Works with Windows 64-bit

My open/save dialog box that used to work on windows XP no longer works on my Windows 7 64-bit. I have heard that 'MSComDlg.CommonDialog' is not compatible with 64-bit. Here is my old code:
' Sub to show open/save dialog
SUB OpenSave (varOpenSaveInputBox, varOpenSaveType, varOpenSaveFilter)
' Create object
SET objComDlg32 = CreateObject("MSComDlg.CommonDialog")
' Set memory buffer
objComDlg32.MaxFileSize = 260
' Set filter
objComDlg32.Filter = varOpenSaveFilter
' Show dialog
IF varOpenSaveType = 0 Then
objComDlg32.ShowOpen
ELSE
objComDlg32.ShowSave
End IF
' Get filename from dialog
strOpenSave = objComDlg32.FileName
' Check IF dialog is cancelled
IF strOpenSave <> vbNullString Then
' Set to variable
objOpenSave.SetContent strOpenSave, TRUE
End If
END SUB
I would really appreciate if you be more specific with your answer rather than "Use this!". DLL and OCX is not really my strong suit. Thanks.
I'm using this code, which I found somewhere on the internet (possibly even on StackOverflow. I don't remember exactly)
Function ChooseFile (ByVal initialDir, filter)
dim shel, fso, tempdir, tempfile, powershellfile, powershellOutputFile,psScript, textFile
Set shell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
tempDir = shell.ExpandEnvironmentStrings("%TEMP%")
tempFile = tempDir & "\" & fso.GetTempName
' temporary powershell script file to be invoked
powershellFile = tempFile & ".ps1"
' temporary file to store standard output from command
powershellOutputFile = tempFile & ".txt"
'if the filter is empty we use all files
if len(filter) = 0 then
filter = "All Files (*.*)|*.*"
end if
'input script
psScript = psScript & "[System.Reflection.Assembly]::LoadWithPartialName(""System.windows.forms"") | Out-Null" & vbCRLF
psScript = psScript & "$dlg = New-Object System.Windows.Forms.OpenFileDialog" & vbCRLF
psScript = psScript & "$dlg.initialDirectory = """ &initialDir & """" & vbCRLF
'psScript = psScript & "$dlg.filter = ""ZIP files|*.zip|Text Documents|*.txt|Shell Scripts|*.*sh|All Files|*.*""" & vbCRLF
psScript = psScript & "$dlg.filter = """ & filter & """" & vbCRLF
' filter index 4 would show all files by default
' filter index 1 would should zip files by default
psScript = psScript & "$dlg.FilterIndex = 1" & vbCRLF
psScript = psScript & "$dlg.Title = ""Select a file""" & vbCRLF
psScript = psScript & "$dlg.ShowHelp = $True" & vbCRLF
psScript = psScript & "$dlg.ShowDialog() | Out-Null" & vbCRLF
psScript = psScript & "Set-Content """ &powershellOutputFile & """ $dlg.FileName" & vbCRLF
'MsgBox psScript
Set textFile = fso.CreateTextFile(powershellFile, True)
textFile.WriteLine(psScript)
textFile.Close
Set textFile = Nothing
' objShell.Run (strCommand, [intWindowStyle], [bWaitOnReturn])
' 0 Hide the window and activate another window.
' bWaitOnReturn set to TRUE - indicating script should wait for the program
' to finish executing before continuing to the next statement
Dim appCmd
appCmd = "powershell -ExecutionPolicy unrestricted &'" & powershellFile & "'"
'MsgBox appCmd
shell.Run appCmd, 0, TRUE
' open file for reading, do not create if missing, using system default format
Set textFile = fso.OpenTextFile(powershellOutputFile, 1, 0, -2)
ChooseFile = textFile.ReadLine
textFile.Close
Set textFile = Nothing
fso.DeleteFile(powershellFile)
fso.DeleteFile(powershellOutputFile)
End Function
This is VBA but it may be enough to point you in the right direction. The 3 declares the type of dialog you wish to open. You can find that and more information here: http://msdn.microsoft.com/en-us/library/office/ff865284.aspx.
Sub FileSelect (Multi as Boolean)
' Set Dlg = Application.FileDialog(msoFileDialogFilePicker)
Set Dlg = Access.Application.FileDialog(3)
With Dlg
.Title = "Select the file you want to open"
.AllowMultiSelect = Multi
If .Show = -1 Then
txtFilePath = .InitialFileName
Else
Exit Function
End If
End With
FileSelect = Dlg.SelectedItems(1)
End Function

Resources