I have an Excel-Macro in VBA in which I want to copy the file from where the macro is executed into another location.
I tried it like this
Call FileCopy(currentDir & "\" & Filename, _
otherDir & "\" & Filename)
But I get an Access restricted Exception, although I have full access to all of the directories involved. Is it because I'm trying to "copy myself"? Is this possible? If not, could I build a workaround?
Try using
ThisWorkbook.SaveCopyAs otherDir & "Test1"
or
ThisWorkbook.SaveAs otherDir & "Test2"
ThisWorkbook refers to the workbook which contains the macro you are running...
Update : This should work for you to create a folder...
Make sure you add "Microsoft Scripting Runtime" under Tools -> references.
Dim fso As FileSystemObject
Set fso = New FileSystemObject
fso.CreateFolder ("C:\test\test2")
ThisWorkbook.SaveCopyAs "c:\test\test2\ttt.xlsm"
Using FileCopy didnt work for me either but using CopyFile from FileSystemObject seems to work.
First you will need to add a Reference (Menu: Tools->References) to the Microsoft Scripting Runtime and then use the FileSystemObject
Dim fso As FileSystemObject
Set fso = New FileSystemObject
fso.CopyFile currentDir & "\" & Filename, otherDir & "\" & Filename, True
''the last parameter decides weather or not you want to overwrite existing files
Set fso = Nothing
Alternative: Save the document at the new destination and then save it back.
ThisWorkbook.SaveAs otherDir & "\" & Filename
ThisWorkbook.SaveAs currentDir & "\" & Filename
Related
My macro for Word highlights specific words from a specified list for each document in a folder. At the end of the macro, I would like to append the names of each of these files to include "_Highlight" using the command line. I am not too familiar with using the Command Prompt in VBA, so my code ended up being messy.
I am trying to replicate the following command prompt in VBA.
for %a in (“C:\path\*.docx*”) do ren “%~a” “%~Na_Highlight%~Xa”
For the actual file path, I select a folder in FileDialog and store it in a variable to be used in the command prompt, strShellFldr. I am having some trouble concatenating all pieces of the code, especially with special characters, spaces, and quotation literals.
Here is what I tried:
The code below runs just fine, however it seems quite cumbersome. Is there a more efficient way to write this?
Shell.Run "cmd.exe /c" & "for %a in" & Chr(32) & "(" & Chr(34) & strShellFldr & Chr(34) & ")" & Chr(32) & "do ren" & Chr(32) & Chr(34) & "%~a" & Chr(34) & Chr(32) & Chr(34) & "%~Na_Hilight%~Xa" & Chr(34)
Is there a native VBA function that allows you to append a file name maybe?
Thank you for your help and my apologies for posting some wretched code on here.
This piece of VBA code can loop through a list of files in a given folder as input, and add "_Highlight" at the end of the name, just before the file extension:
example:
MyFile.txt --> MyFile_Hightlight.txt
Public Sub RenameFiles(Folder As String)
Dim oFSO As Scripting.FileSystemObject
Dim oFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim ext As String
Dim Name As String
On Error GoTo ERROR_TRAP
Set oFSO = New Scripting.FileSystemObject
Set oFolder = oFSO.GetFolder(Folder)
For Each oFile In oFolder.Files
ext = Split(oFile.Name, ".")(UBound(Split(oFile.Name, ".")))
Name = Left$(oFile.Path, Len(oFile.Path) - Len(ext) - 1)
oFSO.MoveFile Name & "." & ext, Name & "_Highlight" & "." & ext
Next oFile
Set oFSO = Nothing
Set oFolder = Nothing
Set oFile = Nothing
Exit Sub
ERROR_TRAP:
Debug.Print "ERROR : RenameFiles (" & oFolder.Name & ")"
End Sub
Do not forget to add Microsoft Scripting Runtime reference first in your VB Editor.
I am trying to open an Access 2003 .mde file using Excel VBA.
So far I have tried:
Shell ("cscript "C:\User\Folder\Access Database.mde""), vbHide
Now this works perfect to open a .vbs file and the code runs to open the .mde file but does not actually open the database.
I also tried the following:
strdb = "C:\User\Folder\Access Database.mde"
Set AccessApp = CreateObject("Access.Application")
AccessApp.Visible = True
AccessApp.OpenCurrentDatabase.strdb
AccessApp.DoCmd.OpenForm "frmsysteminformation"
Set AccessApp= Nothing
I found this online but it gives me a debug error highlight the line:
Set AccessApp = CreateObject("Access.Application")
Thanks
Edit My company seems to have disabled some of the features as
CreateObject("Outlook.Application")
also doesn't work. Is there a way to run this through cscript?
Just in case anyone stumbles across this same issue I managed to work it out:
Dim sAcc
Dim sFrontEnd
Dim sSec
Dim sUser
Dim objShellDb
Dim sComTxt
'Script Configuration Variable
'*******************************************************************************
'Specify the Fullpath and filename of the msaccess executable
sAcc = "C:\Program Files\Microsoft Office\Office11\MSACCESS.EXE"
'Specify the Fullpath and filename of the database to launch
sFrontEnd = "C:\users\file location\Database to open.mde"
Set objShellDb = CreateObject("WScript.Shell")
'Build the command to launch the database
sComTxt = Chr(34) & sAcc & Chr(34) & " " & Chr(34) & sFrontEnd & Chr(34)
objShellDb.Run sComTxt 'Launch the database
End Sub
I'm trying to create a script that will open the latest folder in a directory.
The name of the folder will be different each month (01-Jan, 02-Feb e.t.c). The below seems to find the latest folder, but I get error File not found when I add in Shell "explorer.exe" & "" & strFullFldrPath, vbNormalFocus to open the folder.
This is what I have so far.
Sub GetLatestFolder()
Dim fso As FileSystemObject
Dim fldrRoot As Folder
Dim SubFld As Folder
Dim strFolderName As String
Dim strFullFldrPath As String
Set fso = New FileSystemObject
Set fldrRoot = fso.GetFolder("\\Hbeu.adroot.hsbc\dfsroot\GB002\RRU\DTCC EU Reports\ETD\")
For Each SubFld In fldrRoot.SubFolders
strFolderName = SubFld.Name
strFullFldrPath = fldrRoot & "\" & SubFld.Name
Shell "explorer.exe" & "" & strFullFldrPath, vbNormalFocus
Exit For
Next SubFld
End Sub
You try to run "explorer.exeC:\WHATEVER" i.e. your missing a space between the executable and its argument.
Quotes are a good idea to accommodate paths with spaces.
Shell "explorer.exe" & " """ & strFullFldrPath & """, vbNormalFocus
What you have does not guarantee the latest folder is always first, you should apply some logic based on the name or load all directories and sort.
Does any have VBA code for outlook that will automatically unzip a file? I have found several post that save a file to a locationm, but nothing that unzips a file.
Maybe this is what you are looking for. An example from the website (visit the link to find out more):
With this example you can browse to the zip file. After you select the zip file the macro will create a new folder in your DefaultFilePath and unzip the Zip file in that folder. You can run the code without any changes.
Sub Unzip1()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Root folder for the new folder.
'You can also use DefPath = "C:\Users\Ron\test\"
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create the folder name
strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
MkDir FileNameFolder
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
'If you want to extract only one file you can use this:
'oApp.Namespace(FileNameFolder).CopyHere _
'oApp.Namespace(Fname).items.Item("test.txt")
MsgBox "You find the files here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub
I am reading a list of files and come accross updated versions along the way. In my loop I am checking if the file already exists and trying to remove it, so that I can create the newer version again:
objFs = CreateObject("Scripting.FileSystemObject")
If (objFs.FileExists(location & "\" & fileName & ".xml")) Then
System.IO.File.Delete(location & "\" & fileName & ".xml")
End If
objTextStream = objFs.CreateTextFile(location & "\" & fileName & ".xml", True)
objTextStream.Write(System.Text.Encoding.UTF8.GetString(recordXml))
Ideally I would rather just open the file if it already exists and overwrite the contents, but so far my attempts have been in vein.
location is a user defined path, e.g. c://
recordXML is a retrieved value from the database
The main error I keep getting is
Additional information: Argument 'Prompt' cannot be converted to type 'String'.
Which seems to mean that the file is either not there to delete, or it is already there when I am trying to create it. The delete may not be working as it should, it may be that the file is not deleted in time to recreate it?..
That's my thoughts anyway.
Found this code at http://www.mrexcel.com/forum/excel-questions/325574-visual-basic-applications-check-if-folder-file-exists-create-them-if-not.html for creating a new file (unless one already exists) and then opening it (existing or new). Once you open, you can just do a Sheets(
NAMEOFSHEET").Cells.Clearto clear the cells and then paste your data.
Sub btncontinue_Click()
Dim myFile As String, myFolder As String
myFolder = "C:\TimeCards"
myFile = myFolder & "\timecards.xls"
If Not IsFolderExixts(myFolder) Then
CreateObject("Scripting.FileSystemObject").CreateFolder myFolder
End If
If Not IsFileExists(myFile) Then
MsgBox "No such file in the folder"
Exit Sub
End If
Set wb = Workbooks.Open(myFile)
' Your code here
End Sub
Function IsFolderExists(txt As String) As Boolean
IsFolderExists = _
Createobject("Scripting.FileSystemObject").FolderExists(txt)
End Function
Function IsFileExists(txt As String) As Boolean
IsFileExists = _
CreateObject("Scripting.FilesystemObject").FileExists(txt)
End Function
You could try this, it should work in VB, VBA and VBScript.
objFs = CreateObject("Scripting.FileSystemObject")
If objFs.FileExists(location & "\" & fileName & ".xml") Then Kill(location & "\" & fileName & ".xml")
Open location & "\" & fileName & ".xml" For Output As #1
Print #1, recordXml
Close #1
Try to use FSO to delete the file. Also the objTextStream needs to be set because it is object.
Sub AnySub()
Dim objFs As FileSystemObject
Set objFs = CreateObject("Scripting.FileSystemObject")
If (objFs.FileExists(Location & "\" & Filename & ".xml")) Then
objFs.DeleteFile Location & "\" & Filename & ".xml"
End If
Set objTextStream = objFs.CreateTextFile(Location & "\" & Filename & ".xml", True)
objTextStream.Write recordXml
End Sub
I m not sure the .write method work with UTF8.
I m using this function:
Sub File_WriteToUTF8(File_Path As String, s_Content As String)
On Error GoTo ende
Dim LineStream As Object
Set LineStream = CreateObject("ADODB.Stream")
With LineStream
.Type = 2
.Mode = 3
.Charset = "utf-8"
.Open
.WriteTEXT s_Content
.SaveToFile File_Path, 2
ende:
.Close
End With
End Sub
So instead of
objTextStream.Write recordXml
it would be
File_WriteToUTF8 Location & "\" & Filename & ".xml", recordXml