Vba newbie. Need a function to output the last modification date of an open workbook. Here is what I have so far but I am getting a message that my formula contains an error when I invoke the function:
Function LastWBModDate(wbname)
ActivateWB (wbname)
LastWBModDate = Format(FileDateTime(ActiveWorkbook.FullName), "m/d/yy h:n ampm")
End Function
Public Function ActivateWB(wbname As String)
If IsWBOpen(wbname) Then
Workbooks(wbname).Activate
Else
MsgBox "Workbook : " & wbname & " is not open " & vbNewLine
End If
End Function
Public Function IsWBOpen(wbname As String) As Boolean
On Error Resume Next
If Workbooks(wbname) Is Nothing Then
IsWBOpen = False
Else
IsWBOpen = True
End If
End Function
Thanks!
Function LastWBModDate(wbname As String)
Dim rv, wb As Workbook
rv = "workbook?" 'default return value
On Error Resume Next
Set wb = Workbooks(wbname)
On Error GoTo 0
If Not wb Is Nothing Then
rv = Format(FileDateTime(wb.FullName), "m/d/yy h:n ampm")
End If
LastWBModDate = rv
End Function
Try below code :
You may also refer this link
Put below code on ThisWorkbook code section
Private Sub Workbook_Open()
LastWBModDate
End Sub
Put this code in any Standard Module
Function LastWBModDate() As String
Dim FSO As Object
Dim File As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set File = FSO.GetFile(ThisWorkbook.FullName)
LastWBModDate = Format(File.DateLastModified, "m/d/yy h:n ampm")
Msgbox LastWBModDate
Set FSO = Nothing
End Function
Related
I'm trying to create a save function that will check if there is already a folder by the name specified in Range G3 and if there is, it will just save the file. If there isn't it will create a new folder by that name and save the file.
Sub ExportAsCSV()
Dim MyFileName As String
Dim CurrentWB As Workbook, TempWB As Workbook
Dim sFilename As String
Const csPath As String = "C:\Users\gald\Desktop\Vintage - Gal\Hourly"
sFilename = Range("G2")
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Rows("1:6").Select
Selection.Delete Shift:=xlUp
With Range("J2:W200")
.NumberFormat = "General"
.Value = .Value
End With
MyFileName = csPath & "\" & Left(sFilename, Len(sFilename)) & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Thanks for the help = )
Use API MakeSureDirectoryPathExists
Example Module:
Option Explicit
Public Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub TestIt()
Dim testPath As String
' E:\ if you dont have a Drive E use one You Got
testPath = "E:\MyNewFolder\Somewhere\"
If CreateFolderIfNotExists(testPath) Then
MsgBox ("Yes there is one at least now")
Else
MsgBox ("No there is a Problem")
End If
End Sub
' Creates the folder if not exists and returns true or returns true if folder already exists
Public Function CreateFolderIfNotExists(FolderPath As String) As Boolean
CreateFolderIfNotExists = MakeSureDirectoryPathExists(FolderPath) = 1
End Function
I created a helpful function for ensuring the folder exists.
First, set the library reference Microsoft Scripting Runtime
This function works by passing in the folderPath (make sure you have it formatted with your systems PathSeparator) and it will split that path into an array.
Then the code iterates each path, building on top of each one create each sub folder as needed.
Lastly, if all goes well the return value will be True
' Creates a full path, iterating at each
' step. FSO.CreateFolder only does a single level.
' #LibraryReference {Microsoft Scripting Runtime}
Public Function EnusureFolderExists(ByVal folderPath As String) As Boolean
On Error GoTo catch
' Separate the paths
Dim paths() As String
paths = Split(folderPath, Application.PathSeparator)
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
With New Scripting.FileSystemObject
Dim pathIndex As Integer
For pathIndex = LBound(paths, 1) To UBound(paths, 1)
' Each iteration will build the next
' level of the full path
Dim currentPath As String
currentPath = currentPath & paths(pathIndex) & Application.PathSeparator
' If current iteration doesn't exist then
' create it
If Not .FolderExists(currentPath) Then
.createFolder currentPath
End If
Next
' No failures, returns if it exists
EnusureFolderExists = .FolderExists(folderPath)
End With
Exit Function
catch:
' On any error it will return false
End Function
To use it in your code:
Sub ExportAsCSV()
Const csPath As String = "C:\Users\gald\Desktop\Vintage - Gal\Hourly"
If EnusureFolderExists(csPath) = False Then
' An issue occurred in created the folder,
' you need to handle that what happens in that senerio.
MsgBox "Unable to create folder: " & csPath, vbCritical
Exit Sub
End If
' ... Rest of your code
End Sub
I'm investigating how to automatically update a visio file created with one mastershape (v1.0.vssx) to the next version of the mastershape (v1.1.vssx). When updating each master shape, use Master.Name as the key.
With the code below, I was able to open the vsdx file and vssx and open their respective Masters.
vssx_Master = vssxMaster
vsdx_shape.master = vssx_Master
I wondered if I could update the master shape with the code, but unfortunately vssxMaster is the same as vssxMaster.Name and its type is String.
Is there a way to replace the Master of one shape with another?
not work...
Sub Visio_Update(ByRef VISIOpath As String, ByRef except_sheets() As String, ByRef VSSXpath As String)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim vsoApp As Visio.Application
Dim vsoDoc As Visio.Document
Dim vsoPage As Visio.Page
Dim vsoItemsCnt As Long
Dim vsoShape As Visio.Shape
Dim FileName As String
Dim FileText As String
FileName = Dir(VISIOpath)
FileName = Replace(FileName, ".vsdx", "")
ChDir ThisWorkbook.path
Set vsoApp = CreateObject("Visio.Application")
Call vsoApp.Documents.OpenEx(VISIOpath, visOpenRW)
Set vsoDoc = vsoApp.Documents.Item(1)
vsoItemsCnt = vsoApp.Documents.Count
Call vsoApp.Documents.OpenEx(VSSXpath, visOpenRW)
Set vssxDoc = vsoApp.Documents.Item(vsoItemsCnt + 1)
Set vssxMasters = vssxDoc.Masters
For Each vsoPage In vsoDoc.Pages
For Each vsoShape In vsoPage.Shapes
If Not (vsoShape.Master Is Nothing) Then
On Error Resume Next
mastername = vsoShape.Master.Name
vsoShape.ReplaceShape vssxMasters.Item(vsoShape.Master.Name)
If Err.Number = 0 Then
Debug.Print ("Masters.Item")
Debug.Print "updated succeeded : ", mastername
Err.Clear
Else
Debug.Print ("Masters.Item")
Debug.Print Err.Description
Err.Clear
End If
End If
Next
Next
vsoDoc.SaveAs ThisWorkbook.path & "\data\" & FileName & "_updated_.vsdx"
Application.ScreenUpdating = True
End Sub
Sub test()
choosed_path = "C:\Users\11665307\Desktop\data\vs1.vsdx"
Update_Template = "C:\Users\11665307\Documents\test.vssx"
Call Visio_Update(choosed_path, except_sheets, (Update_Template))
End Sub
I wondered if I could update the master shape with the code
You dont need iterate all masters into stencil :)
For Each vsoPage In doc.Pages
For Each vsoShape In vsoPage.Shapes
If Not (vsoShape.Master Is Nothing) Then
vsoShape.ReplaceShape vssxMasters.Item(vsoShape.Master.Name)
End If
Next
Next
You must iterate through all the shapes on the page. If the shape was created based on the master from stencil v.1.0, then replace it with the corresponding master v.1.1. using the ReplaceShape method
Sub ttt()
Dim sh As Shape
For Each sh In ActivePage.Shapes
If sh.Master.NameU = "Circle" Then sh.ReplaceShape Application.Documents.Item("BLOCK_M.vssx").Masters.ItemU("Diamond")
Next
End Sub
I am using a VBA script where the first worksheets of all workbooks saved in a specific folder are consolidated in one workbook. What I want is, if any source workbook is open while running this script, then I should get a prompt that 'source workbook is open' and the script should not run.
VBA script of destination worksheet is as follows:
Private Sub CommandButton1_Click()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim WrdArray() As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "C:\test\"
fileName = Dir(directory & "*.xl??")
Application.EnableEvents = False
Do While fileName <> ""
Workbooks.Open (directory & fileName)
WrdArray() = Split(fileName, ".")
For Each sheet In Workbooks(fileName).Worksheets
Workbooks(fileName).ActiveSheet.Name = WrdArray(0)
total = Workbooks("import-sheets.xlsm").Worksheets.Count
Workbooks(fileName).Worksheets(sheet.Name).Copy After:=Workbooks("import-sheets.xlsm").Worksheets(total)
GoTo exitFor:
Next sheet
exitFor:
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I appreciate your help in advance
Untested but it should work, source:
https://support.microsoft.com/en-us/kb/291295
Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer
On Error Resume Next ' Turn error checking off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.
' Check to see which error occurred.
Select Case errnum
' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False
' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True
' Another error occurred.
Case Else
Error errnum
End Select
End Function
if you want to check if a workbook (an Excel file) is opened, try this function.
Public Function isWbOpened(ByVal wb As String) As Boolean
Dim workB As Workbook
isWbOpened = False
For Each workB In Workbooks
If workB.FullName = wb Or workB.Name = wb Then ''FullName : path + filename Name : filename only
isWbOpened = True
End If
Next workB
End Function
if the function return TRUE, then the Excel file is open, so skeep your script.
example:
if isWbOpened("theExcelFile.xlsx") then
msgbox "theExcelFile.xlsx is open"
end if
You can enumerate the files in a folder then test them to see if any is open before proceeding. Please note - the following code is assuming you are the one with them open, so if a shared file is open this may have to be adapted
Sub TestFolder()
Debug.Print XLFileIsOpen("C:\Test")
End Sub
Function XLFileIsOpen(sFolder As String) As Boolean
For Each Item In EnumerateFiles(sFolder)
If IsWorkBookOpen(CStr(Item)) = True Then XLFileIsOpen = True
Next Item
End Function
Function EnumerateFiles(sFolder As String) As Variant
Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objFolder As Object: Set objFolder = objFSO.GetFolder(sFolder)
Dim objFile As Object, V() As String
For Each objFile In objFolder.Files
If IsArrayAllocated(V) = False Then
ReDim V(0)
Else
ReDim Preserve V(UBound(V) + 1)
End If
V(UBound(V)) = objFile.Name
Next objFile
EnumerateFiles = V
End Function
Function IsArrayAllocated(Arr As Variant) As Boolean
On Error Resume Next
IsArrayAllocated = IsArray(Arr) And Not IsError(LBound(Arr, 1)) And LBound(Arr, 1) <= UBound(Arr, 1)
End Function
Function IsWorkBookOpen(sFile As String) As Boolean
On Error Resume Next
IsWorkBookOpen = Len(Application.Workbooks(sFile).Name) > 0
End Function
I am trying to create a MS Word macro to check and see if a specific powerpoint file is open. If it is then I want it to go to next, but if not then open the file.
Public Sub CommandButton1_Click()
Dim pptApp As Object
Dim pptPres As String
'Dim nSlide As PowerPoint.Presentation
Dim folderPath, file As String
folderPath = ActiveDocument.Path & Application.PathSeparator
file = "Huntington_Template.pptx"
Set pptApp = CreateObject("PowerPoint.Application")
If pptApp.presentations(file).Enabled = True Then
GoTo cont
Else
pptApp.Visible = True
pptApp.presentations.Open (folderPath & file)
End If
cont:
End Sub
A minor variation of Steve's code, in case you want to not just test if the presentation is open, but also use it directly:
Function GetPowerpointFileIfOpen(pptApp As Object, sFullname As String) As Object
For Each p In pptApp.Presentations
If p.FullName = sFullname Then
Set GetPowerpointFileIfOpen = p
Exit Function
End If
Next p
End Function
And then you can test if the presentation is open - or open it otherwise:
Set ppt = GetPowerpointFileIfOpen(pptApp, sFullName)
If ppt Is Nothing Then
Set ppt = pptApp.Presentations.Open(sFullName, False)
End If
Add this to your module (aircode, may need debug help):
Function PPTFileIsOpen(pptApp as object, sFullname as string) as boolean
Dim x as long
For x = 1 to pptApp.Presentations.Count
if pptApp.Presentations(x).fullname = sFullname ) Then
PPTFileIsOpen = True
Exit Function
end if
Next
End Function
Then instead of your:
If pptApp.presentations(file).Enabled = True Then
use:
If Not PPTFileIsOpen(pptApp, folderPath & file) Then
' open the file as you're already doing
End If
I have used this function to determine if a workbook is already open it might work for powerpoint.
Public Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
You can then call it by doing something like
Ret = IsWorkBookOpen("C:\Book1.xlsm")
If Ret = True Then
Set wb = Application.Workbooks("C:\Book1.xlsm")
wb.Activate
Else
Set wb = Application.Workbooks.Open("C:\Book1.xlsm")
End If
This code creates an Excel file with one sheet. This sheet contains the code of an item like (ASR/Floor/Dept./Item_Name/Item_details/1) which I created and works fine, but I want to add a sheet into this Excel file to create another item code, and then save this file.
Dim xlApp As Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
Dim var As Variant
Dim code As String
Dim i, nocode As Integer
Dim fname, heading As String
code = "ASR/" & Text1.Text & "/" & Text2.Text & "/" & Text3.Text & "/" & Text4.Text
Set xlApp = New Excel.Application
Set wb = xlApp.Workbooks.Add ' Create a new WorkBook
Set ws = wb.Worksheets("Sheet1") 'Specify your worksheet name
nocode = txtnocode.Text
heading = Text6.Text
For i = 2 To nocode + 1
ws.Cells(i, 1).Value = code & "/" & i - 1 '"ORG"
Next i
fname = "c:\" & Text5.Text & ".xls"
wb.SaveAs (fname)
wb.Close
xlApp.Quit
Set ws = Nothing
Set wb = Nothing
Set xlApp = Nothing
The Worksheets.Add method is what you are looking for:
wb.WorkSheets.Add().Name = "SecondSheet"
See MSDN(scroll down and expand Sheets and Worksheets) for the different parameters you can give to .Add including being able to add the sheet before or after a specific one.
Set ws = wb.Sheets("Sheet1")
Set ws = wb.Sheets.Add
ws.Activate
This is some standard code I use for this type of problem
Note: This code is VBA, to run from within the Excel document itself
Option Explicit
Private m_sNameOfOutPutWorkSheet_1 As String
Sub Delete_Recreate_TheWorkSheet()
On Error GoTo ErrorHandler
'=========================
Dim strInFrontOfSheetName As String
m_sNameOfOutPutWorkSheet_1 = "Dashboard_1"
strInFrontOfSheetName = "CONTROL" 'create the new worksheet in front of this sheet
'1] Clean up old data if it is still there
GetRidOf_WorkSheet_IfItExists (m_sNameOfOutPutWorkSheet_1)
CreateNewOutputWorkSheet m_sNameOfOutPutWorkSheet_1, strInFrontOfSheetName
'Color the tab of the new worksheet
ActiveWorkbook.Sheets(m_sNameOfOutPutWorkSheet_1).Tab.ColorIndex = 5
'Select the worksheet that I started with
Worksheets(strInFrontOfSheetName).Select
'=========================
Exit Sub
ErrorHandler:
Select Case Err.Number
Case Else
MsgBox "One_Main - Error: " & Err.Number & " " & Err.Description
End Select
End Sub
Sub GetRidOf_WorkSheet_IfItExists(sWorkSheetName_ForInitalData As String)
On Error GoTo ErrorHandler
'=========================
If fn_WorkSheetExists(sWorkSheetName_ForInitalData) Then
'Sheet Exists
Application.DisplayAlerts = False
Worksheets(sWorkSheetName_ForInitalData).Delete
Application.DisplayAlerts = True
End If
'=========================
Exit Sub
ErrorHandler:
Select Case Err.Number
Case Else
MsgBox "GetRidOf_WorkSheet_IfItExists - Error: " & Err.Number & " " & Err.Description
End Select
End Sub
Function fn_WorkSheetExists(wsName As String) As Boolean
On Error Resume Next
fn_WorkSheetExists = Worksheets(wsName).Name = wsName
End Function
Sub CreateNewOutputWorkSheet(sWorkSheetName_ForOutputData As String, strInFrontOfSheetName As String)
On Error GoTo ErrorHandler
'=========================
If fn_WorkSheetExists(sWorkSheetName_ForOutputData) Then
'Sheet Exists
Application.DisplayAlerts = False
Worksheets(sWorkSheetName_ForOutputData).Delete
Application.DisplayAlerts = True
End If
Dim wsX As Worksheet
Set wsX = Sheets.Add(Before:=Worksheets(strInFrontOfSheetName))
wsX.Name = sWorkSheetName_ForOutputData
'=========================
Exit Sub
ErrorHandler:
Select Case Err.Number
Case Else
MsgBox "CreateNewOutputWorkSheet - Error: " & Err.Number & " " & Err.Description
End Select
End Sub