Archive for VBA
VBA: Unzip files
Posted by: | CommentsThis code will extracts files from a ZIP archive.
Function UnZip(PathToUnzipFileTo As Variant, FileNameToUnzip As Variant)
' Unzips a file
' Note that the default OverWriteExisting is true unless otherwise specified as False.
Dim objOApp As Object
Dim varFileNameFolder As Variant
varFileNameFolder = PathToUnzipFileTo
Set objOApp = CreateObject("Shell.Application")
' the "24" argument below will supress any dialogs if the file already exist. The file will
' be replaced. See http://msdn.microsoft.com/en-us/library/windows/desktop/bb787866(v=vs.85).aspx
objOApp.Namespace(varFileNameFolder).CopyHere objOApp.Namespace(FileNameToUnzip).items, 24
End Function
Note the 24 in the last line. This suppresses any dialog boxes in the event of the extracted file(s) already existing. See http://msdn.microsoft.com/en-us/library/windows/desktop/bb787866(v=vs.85).aspx for more details.
Improvements to this could could consist of checking to see if the extracted files exist and handling that by renaming, deleting, etc.
VBA: Copy, Move and Delete files and folders
Posted by: | CommentsThis post is from Ron de Bruin’s blog (http://www.rondebruin.nl/folder.htm).
On this page you can find example code to copy, move and delete files and folders.
There are three sections on this page :
1) Copy and Move files and folders
4) VBS script to clear the Temp folder
Copy and Move files and folders
Below are a few examples to copy and move files and folders.
For one file you can use the VBA Name and FileCopy function
and for entire folders or a lot of files use the other macro example’s
Sub Copy_One_File()
FileCopy "C:\Users\Ron\SourceFolder\Test.xls", "C:\Users\Ron\DestFolder\Test.xls"
End Sub
Sub Move_Rename_One_File()
'You can change the path and file name
Name "C:\Users\Ron\SourceFolder\Test.xls" As "C:\Users\Ron\DestFolder\TestNew.xls"
End Sub
Filesystemobject example code’s
Sub Copy_Folder()
'This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
FromPath = "C:\Users\Ron\Data" '<< Change
ToPath = "C:\Users\Ron\Test" '<< Change
'If you want to create a backup of your folder every time you run this macro
'you can create a unique folder with a Date/Time stamp.
'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss")
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
FSO.CopyFolder Source:=FromPath, Destination:=ToPath
MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
End Sub
Sub Move_Rename_Folder()
'This example move the folder from FromPath to ToPath.
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
FromPath = "C:\Users\Ron\Data" '<< Change
ToPath = "C:\Users\Ron\Test" '<< Change
'Note: It is not possible to use a folder that exist in ToPath
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
If FSO.FolderExists(ToPath) = True Then
MsgBox ToPath & " exist, not possible to move to a existing folder"
Exit Sub
End If
FSO.MoveFolder Source:=FromPath, Destination:=ToPath
MsgBox "The folder is moved from " & FromPath & " to " & ToPath
End Sub
Sub Copy_Files_Dates()
'This example copy all files between certain dates from FromPath to ToPath.
'You can also use this to copy the files from the last ? days
'If Fdate >= Date - 30 Then
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim Fdate As Date
Dim FileInFromFolder As Object
FromPath = "C:\Users\Ron\Data" '<< Change
ToPath = "C:\Users\Ron\Test" '<< Change
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
If Right(ToPath, 1) <> "\" Then
ToPath = ToPath & "\"
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
If FSO.FolderExists(ToPath) = False Then
MsgBox ToPath & " doesn't exist"
Exit Sub
End If
For Each FileInFromFolder In FSO.getfolder(FromPath).Files
Fdate = Int(FileInFromFolder.DateLastModified)
'Copy files from 1-Oct-2006 to 1-Nov-2006
If Fdate >= DateSerial(2006, 10, 1) And Fdate <= DateSerial(2006, 11, 1) Then
FileInFromFolder.Copy ToPath
End If
Next FileInFromFolder
MsgBox "You can find the files from " & FromPath & " in " & ToPath
End Sub
Sub Copy_Certain_Files_In_Folder()
'This example copy all Excel files from FromPath to ToPath.
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
FromPath = "C:\Users\Ron\Data" '<< Change
ToPath = "C:\Users\Ron\Test" '<< Change
FileExt = "*.xl*" '<< Change
'You can use *.* for all files or *.doc for word files
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
If FSO.FolderExists(ToPath) = False Then
MsgBox ToPath & " doesn't exist"
Exit Sub
End If
FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
MsgBox "You can find the files from " & FromPath & " in " & ToPath
End Sub
Sub Move_Certain_Files_To_New_Folder()
'This example move all Excel files from FromPath to ToPath.
'Note: It will create the folder ToPath for you with a date-time stamp
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
FromPath = "C:\Users\Ron\Data" '<< Change
ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss") _
& " Excel Files" & "\" '<< Change only the destination folder
FileExt = "*.xl*" '<< Change
'You can use *.* for all files or *.doc for word files
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then
MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
FSO.CreateFolder (ToPath)
FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
MsgBox "You can find the files from " & FromPath & " in " & ToPath
End Sub
Important !
Read this page from Chip Pearson first
http://www.cpearson.com/excel/Recycle.htm
From Chip’s site :
You need to remember, though, that Kill permanently deletes the file.
There is no way to “undo” the delete. The file is not sent to the Windows Recycle Bin
( Same for the macro’s that use the filesystemobject )
Sub DeleteExample1()
'You can use this to delete all the files in the folder Test
On Error Resume Next
Kill "C:\Users\Ron\Test\*.*"
On Error GoTo 0
End Sub
Sub DeleteExample2()
'You can use this to delete all xl? files in the folder Test
On Error Resume Next
Kill "C:\Users\Ron\Test\*.xl*"
On Error GoTo 0
End Sub
Sub DeleteExample3()
'You can use this to delete one xls file in the folder Test
On Error Resume Next
Kill "C:\Users\Ron\Test\ron.xls"
On Error GoTo 0
End Sub
Sub DeleteExample4()
'You can use this to delete the whole folder
'Note: RmDir delete only a empty folder
On Error Resume Next
Kill "C:\Users\Ron\Test\*.*" ' delete all files in the folder
RmDir "C:\Users\Ron\Test\" ' delete folder
On Error GoTo 0
End Sub
Sub Delete_Whole_Folder()
'Delete whole folder without removing the files first like in DeleteExample4
Dim FSO As Object
Dim MyPath As String
Set FSO = CreateObject("scripting.filesystemobject")
MyPath = "C:\Users\Ron\Test" '<< Change
If Right(MyPath, 1) = "\" Then
MyPath = Left(MyPath, Len(MyPath) - 1)
End If
If FSO.FolderExists(MyPath) = False Then
MsgBox MyPath & " doesn't exist"
Exit Sub
End If
FSO.deletefolder MyPath
End Sub
Sub Clear_All_Files_And_SubFolders_In_Folder()
'Delete all files and subfolders
'Be sure that no file is open in the folder
Dim FSO As Object
Dim MyPath As String
Set FSO = CreateObject("scripting.filesystemobject")
MyPath = "C:\Users\Ron\Test" '<< Change
If Right(MyPath, 1) = "\" Then
MyPath = Left(MyPath, Len(MyPath) - 1)
End If
If FSO.FolderExists(MyPath) = False Then
MsgBox MyPath & " doesn't exist"
Exit Sub
End If
On Error Resume Next
'Delete files
FSO.deletefile MyPath & "\*.*", True
'Delete subfolders
FSO.deletefolder MyPath & "\*.*", True
On Error GoTo 0
End Sub
How do I get the path of a special folder and open the folder ?
Sub GetSpecialFolder()
'Special folders are : AllUsersDesktop, AllUsersStartMenu
'AllUsersPrograms, AllUsersStartup, Desktop, Favorites
'Fonts, MyDocuments, NetHood, PrintHood, Programs, Recent
'SendTo, StartMenu, Startup, Templates
'Get Favorites folder and open it
Dim WshShell As Object
Dim SpecialPath As String
Set WshShell = CreateObject("WScript.Shell")
SpecialPath = WshShell.SpecialFolders("Favorites")
MsgBox SpecialPath
'Open folder in Explorer
Shell "explorer.exe " & SpecialPath, vbNormalFocus
End Sub
Sub VBA_GetSpecialFolder_functions()
'Here are a few VBA path functions
MsgBox Application.Path
MsgBox Application.DefaultFilePath
MsgBox Application.TemplatesPath
MsgBox Application.StartupPath
MsgBox Application.UserLibraryPath
MsgBox Application.LibraryPath
End Sub
Temp folder
Without code you can do this to open the temp folder
Start>Run
Enter %temp%
OK
Or use one of the two code examples
Sub GetTempFolder_1()
MsgBox Environ("Temp")
'Open folder in Explorer
Shell "explorer.exe " & Environ("Temp"), vbNormalFocus
End Sub
Sub GetTempFolder_2()
Dim FSO As Object, TmpFolder As Object
Set FSO = CreateObject("scripting.filesystemobject")
Set TmpFolder = FSO.GetSpecialFolder(2)
MsgBox TmpFolder
'Open folder in Explorer
Shell "explorer.exe " & TmpFolder, vbNormalFocus
End Sub
0 = The Windows folder contains files installed by the Windows operating sys
1 = The System folder contains libraries, fonts, and device drivers
Function to get logged in user name
Posted by: | CommentsThis code is from Charles Maxson’s blog (http://blogs.officezealot.com/charles/archive/2004/12/10/3574.aspx) and is posted here for my reference.
Excel VBA: Function to get logged in user name (plus the Environ Function)
One commonly asked task is how can you get the name of the current user of an Excel spreadsheet into a cell in the spreadsheet. A lot of people quickly stumble across the UserName property in VBA and create a function similar to this:
Function UserNameOffice() As String
UserNameOffice = Application.UserName
End Function
But as you know, that only returns the name of the user according to the registration information of Office. A lot of companies set that at something generic like “User”or “Registered Owner”. That’s not what you really want though right? You really want the user’s name based on their Windows login. How do you get that ?…. well it’s a little complicated with an API call from VBA as shown here is below:
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA"(ByVal lpBuffer As String, nSize As Long) As Long
Function UserNameWindows() As String
Dim lngLen As Long
Dim strBuffer As String
Const dhcMaxUserName = 255
strBuffer = Space(dhcMaxUserName)
lngLen = dhcMaxUserName
If CBool(GetUserName(strBuffer, lngLen)) Then
UserNameWindows = Left$(strBuffer, lngLen - 1)
Else
UserNameWindows = ""
End If
End Function
Then all you have to do in the cell of choice is enter the formula:
=UserNameWindows()
But as *Mike* reminded me in a comment on my original post (this is the updated version)….
There is the Environ Function in VBA that makes this a walk in the park without the API hassles:
Function UserNameWindows() As String
UserName = Environ("USERNAME")
End Function
Thanks *Mike* for bringing that up….
I remember using Environ to get the current location of the “My Documents“ folder for the current user:
MsgBox Environ("USERPROFILE") + "\My Documents"
So having my memory jarred on the Environ function, I thought I would check VBA help to see what else this Little gem provided. And boy, how disappointing Help was… here is what it looks like: Environ Help. Not too useful I thought… So I decided to figure it out on my own and loop thru all the arguments possible with Environ. Copy and run this little routine to see all that Environ offers:
MsgBox Environ("USERPROFILE") + "\My Documents"Public Sub EnvironFunction()
Dim nCount As Integer
nCount = nCount + 1
Do Until Environ(nCount) = ""
Debug.Print Environ(nCount)
nCount = nCount + 1
Loop
End Sub
There are lots of useful things in there including APPDATA, COMPUTERNAME, HOMEDRIVE, HOMEPATH, OS, USERDOMAIN and more… Hopefully you will find it useful and I won’t forget about it again.
****Nice to see blogging helps you remember what you forgot and that readers often help writers more than the other way around 
Here’s a complete list (that I know of) of the named arguments for the Environ Function:
| Environ arguments |
| ALLUSERSPROFILE |
| APPDATA |
| AVENGINE |
| CLIENTNAME |
| CommonProgramFiles |
| COMPUTERNAME |
| ComSpec |
| FP_NO_HOST_CHECK |
| HOMEDRIVE |
| HOMEPATH |
| INCLUDE |
| INOCULAN |
| LIB |
| LOGONSERVER |
| NUMBER_OF_PROCESSORS |
| OS |
| Path |
| PATHEXT |
| PROCESSOR_ARCHITECTURE |
| PROCESSOR_IDENTIFIER |
| PROCESSOR_LEVEL |
| PROCESSOR_REVISION |
| ProgramFiles |
| SESSIONNAME |
| SystemDrive |
| SystemRoot |
| TEMP |
| TMP |
| USERDOMAIN |
| USERNAME |
| USERPROFILE |
| VS71COMNTOOLS |
| WecVersionForRosebud.FF0 |
| windir |
