Im trying to find my Available Physical Memory through VBA. my goal is to run the systeminfo |find “Available Physical Memory” command in VBA and see the results. for some reason this is not working but is working with other commands ive tried. My initial thought is that the way i have the code written, it is not waiting on the command prompt to finish. any thoughts or help? thank you
Sub MemoryCheck()
Dim availableMem As String
availableMem = ExecShellCmd("systeminfo |find ""Available Physical Memory""")
Debug.Print "availableMem: "; availableMem
End Sub
Public Function ExecShellCmd(FuncExec As String) As String
Dim wsh As Object, wshOut As Object, sShellOut As String, sShellOutline As String
Set wsh = CreateObject("WScript.Shell")
Set wshOut = wsh.exec(FuncExec).stdout
While Not wshOut.AtEndOfStream
sShellOutline = wshOut.ReadLine
If sShellOutline <> "" Then
sShellOut = sShellOut & sShellOutline & vbCrLf
End If
Wend
ExecShellCmd = sShellOut
End Function
This worked for me:
Sub MemoryCheck()
Dim availableMem As String
availableMem = ExecShellCmd("systeminfo |find ""Available Physical Memory""")
Debug.Print "availableMem: "; availableMem
End Sub
Public Function ExecShellCmd(FuncExec As String) As String
ExecShellCmd = VBA.CreateObject("WScript.Shell") _
.exec("cmd.exe /c " & FuncExec).stdout.readall
End Function
Related
I want to get hard disk serial number on Windows Server with VBA.
My code works just perfect on regular Windows but I get a Run-Time error 1004 with the message - Invalid number of arguments - when i'm trying to run it on a Windows Server OS.
This is the code:
Dim oWMI As Object
Dim oItems As Object
Dim oItem As Object
Dim IndexNumber As Integer
IndexNumber = 0
Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set oItems = oWMI.ExecQuery("Select * from Win32_DiskDrive")
For Each oItem In oItems
If oItem.Index = IndexNumber Then
Msgbox Application.Trim(oItem.SerialNumber)
Exit For
End If
Next
Any ideas how to make it work ?
One alternative to try:
Sub Tester()
Dim s As String, arr, e
s = ExecShellCmd("wmic diskdrive get serialnumber")
Debug.Print "----------------------------"
Debug.Print s
arr = Split(s, vbLf)
Debug.Print "----------------------------"
Debug.Print arr(1)
End Sub
Public Function ExecShellCmd(FuncExec As String) As String
ExecShellCmd = VBA.CreateObject("WScript.Shell") _
.exec("cmd.exe /c " & FuncExec).stdout.readall
End Function
I'm trying to use this answer, but set it up where the Function is in another xlam workbook.
Example:
This works from remote workbook:
Sub Test()
FuncName = "#MyFunctionkClick()"
MyVal = "TestVal"
Range("A1").Value = MyVal
Range("A1").Formula = "=HYPERLINK(""" & FuncName & """, """ & Range("A1").Value & """)"
End Sub
Sub TestTwo()
Application.Run ("'remotewb.xlam'!MyFunctionkClick")
End Sub
Function MyFunctionkClick()
Set MyFunctionkClick = Selection 'This is required for the link to work properly
MsgBox "The clicked cell addres is " & Selection.Row
End Function
But I tried this without luck:
Sub Test()
'Application.Run ("'Master Calc with Macro.xlsm'!SummarizeMaster")
'Application.Run ("'remotewb.xlam'!testremote")
'Application.Run ("'remotewb.xlam'!#MyFunctionkClick()")
'Application.Run ("'remotewb.xlam'!MyFunctionkClick") ' When calling from Remote WB it errored if I used ()
'Range("A1:A5").Formula = "=HYPERLINK(""#MyFunctionkClick()"", ""Run a function..."")"
' Range("A1:A5").Formula = "=HYPERLINK(""#MyFunctionkClick()"", ""Run a function..."")"
Range("A1:A5").Formula = "=HYPERLINK(""[remotewb.xlam]!MyFunctionkClick"", ""Run a function..."")"
'Range("A1").Formula = "=HYPERLINK(""Application.Run (" 'remotewb.xlam'!MyFunctionkClick")"", ""Run a function..."")"
End Sub
Please, try the next scenario:
Create a function in that the other workbook. For testing reasons, it should be good to place it in "Personal.xlsb", as I am trying it:
Function GiveMeFive(x As Long, y As Long) As Long
Debug.Print "In Personal.xlsb code: " & x + y 'not important, ONLY TO SEE IT WORKING with parameters in Immediate Window
GiveMeFive = 5 'it can be calculated, but look to the function name :)
End Function
Create the (necessary) hyperlink in the active sheet (it can be created in any sheet):
Sub TestCalFunctionHyp()
Dim FuncName As String, myVal As String
FuncName = "#MyFunctionHyp()"
myVal = "Call external Function (parameters):4|3" 'just to see how to call it with parameters
Range("A1").Value = myVal
Range("A1").Formula = "=HYPERLINK(""" & FuncName & """, """ & Range("A1").Value & """)"
End Sub
How the (directly) called (by hyperlink) function should look:
Function MyFunctionHyp()
Dim arr
Set MyFunctionHyp = Selection
arr = Split(Split(Selection.Value, ":")(1), "|")
TestTwo CLng(arr(0)), CLng(arr(1)) 'calling the sub calling the one in the other wb
End Function
The sub calling the function in the other workbook should look like:
Sub TestTwo(arg1 As Long, arg2 As Long)
Dim x As Long
x = Run("'C:\Users\YourUser\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLSB'!GiveMeFive", arg1, arg2)
Debug.Print "Received from called function: " & x
End Sub
The function calls the function using its full path, only due to the fact that, in case the workbook keeping the function is not open, it will open it...
Please, take care to adapt the path in order to use your real YourUser...
I would like to receive some feedback after testing it. If something not clear enough, do not hesitate to ask for clarifications.
I am using the following VBA function from Ryan Wells to find which user has an Excel open.
Function Excel_File_in_use_by(FilePath As String) As String
Dim strTempFile As String
Dim iPos As Integer, iRetVal As Integer
Dim objFSO As Object, objWMIService As Object, objFileSecuritySettings As Object, objSD As Object
iPos = InStrRev(FilePath, "\")
strTempFile = Left(FilePath, iPos - 1) & "\~$" & Mid(FilePath, iPos + 1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strTempFile) Then
Set objWMIService = GetObject("winmgmts:")
Set objFileSecuritySettings = objWMIService.Get("Win32_LogicalFileSecuritySetting='" & strTempFile & "'")
iRetVal = objFileSecuritySettings.GetSecurityDescriptor(objSD)
If iRetVal = 0 Then
Excel_File_in_use_by = objSD.Owner.Name
Else
Excel_File_in_use_by = "unknown"
End If
Set objWMIService = Nothing
Set objFileSecuritySettings = Nothing
Set objSD = Nothing
Else
Excel_File_in_use_by = vbNullString
End If
Set objFSO = Nothing
End Function
The codes works great when I supply the file path and it begins with a mapped network drive, for example j:\Workbook.xlsx. But when the file path is passed in as a network address, for example \\server1\Workbook.xlsx I get runtime error '-2147217406 (80041002)'.
This was my test sub and the 2nd statement is giving me the runtime error
Sub test()
Debug.Print Excel_File_in_use_by("J:\Workbook.xlsx")
Debug.Print Excel_File_in_use_by("\\server1\Workbook.xlsx")
End Sub
Is it possible to use this code or amended it to be able to pass in file path in the network address as sometimes this is required as not all drives will be mapped.
I recently got help here with the first function but I am stumped about why my code is not working..
I'm trying to use the ReportTimeByOP function to find the newest file located in "sFolder" that begins with "sName" and that has a "sOPID" that matches the "value38" result of the ReadTextFile function.
For whatever reason I have no trouble getting both functions to work independently but my attempts to combine them into one seamless operation have failed. What I currently have is:
Function ReadTextFile(fpath)
Dim fline As String
Dim fnumb As Long
Dim i As Long
Dim Wanted As String
fnumb = FreeFile
Open fpath For Input As #fnumb
i = 1
Do While Not EOF(fnumb)
Line Input #fnumb, fline
If i = 2 Then
Wanted = Split(fline, vbTab)(38)
Exit Do
End If
i = i + 1
Loop
Close #fnumb
MsgBox fpath
ReadTextFile = Wanted
End Function
Function ReportTimeByOP(ByVal sName As String, ByVal sFolder As String, ByVal sOPID As String)
Dim FileName As String
Dim MostRecentFile As String
Dim MostRecentDate As Date
Dim value38 As String
Dim oFSO As FileSystemObject
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FolderExists(sFolder) Then
FileName = Dir(sFolder & sName & "*hdr.txt", 0)
If FileName <> "" Then
MostRecentFile = FileName
MostRecentDate = FileDateTime(sFolder & FileName)
Do While FileName <> ""
value38 = ReadTextFile(sFolder & FileName)
If FileDateTime(sFolder & FileName) > MostRecentDate And Trim(value38) = Trim(sOPID) Then
MostRecentFile = FileName
MostRecentDate = FileDateTime(sFolder & FileName)
value38 = ReadTextFile(sFolder & FileName)
End If
FileName = Dir
DoEvents
Loop
End If
Else
MostRecentFile = "Err: folder not found."
End If
Set oFSO = Nothing
ReportTimeByOP = MostRecentDate
End Function
Given the huge number of files, I'd skip the Dir function entirely. I'd also skip the manual sorting of the results by creation date (I'm assuming this is the criteria - if not, it should be fairly easy to modify). Let the Windows Shell do the heavy lift for you. Unlike the VBA Dir() function or the Scripting.FileSystemObject, the shell dir command has a ton of parameters that allow you to retrieve sorted output. For this purpose, going through a list of files sorted in reverse order is much, much more efficient. You can see all of the dir options here.
So, I'd approach this by shelling to a dir command that retrieves the list of files in reverse date order, pipe it to a temp file, and then pick up the temp file to go through the list. That way you can just exit when you find your first match. Then you can simplify both your loop and ReadTextFile function by using the FileSystemObject:
ReadTextFile:
Public Function ReadTextFile(target As File) As String
With target.OpenAsTextStream
If Not .AtEndOfStream Then .SkipLine
Dim values() As String
If Not .AtEndOfStream Then
values = Split(.ReadLine, vbTab)
If UBound(values) >= 38 Then
ReadTextFile = values(38)
End If
End If
.Close
End With
End Function
ReportTimeByOP:
Function ReportTimeByOP(ByVal sName As String, ByVal sFolder As String, _
ByVal sOPID As String) As Date
With New Scripting.FileSystemObject
Dim temp As String
temp = .BuildPath(.GetSpecialFolder(TemporaryFolder), .GetTempName)
Dim seeking As String
seeking = .BuildPath(sFolder, sName & "*hdr.txt")
Shell "cmd /c dir """ & seeking & """ /b /a:-d /o:-d > " & temp
'Shell is asychronous - wait .2 seconds for it to complete.
Sleep 200
With .GetFile(temp).OpenAsTextStream
Dim directory() As String
directory = Split(.ReadAll, vbNewLine)
.Close
End With
.DeleteFile temp
Dim i As Long
Dim value38 As String
Dim candidate As File
'Temp file will end with a newline, so the last element is empty.
For i = LBound(directory) To UBound(directory) - 1
Set candidate = .GetFile(.BuildPath(sFolder, directory(i)))
value38 = ReadTextFile(candidate)
If Trim$(value38) = Trim$(sOPID) Then
ReportTimeByOP = candidate.DateCreated
Exit Function
End If
Next i
End With
End Function
And this declaration somewhere:
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub GetFolderPath()
Dim InputFolder As String
Dim OutputFolder As String
InputFolder = Application.GetOpenFilename("Folder, *")
Range("C1").Select
ActiveCell.Value = InputFolder & "\"
End Sub
I am using the code above to attempt to store, and then paste, a folder location for another macro I am running.
Any idea how to make it stop at the folder level or remove the filename from the end?
Thanks!
You could use
FileName = Dir(InputFolder)
InputFolder = Left(InputFolder, Len(InputFolder)-Len(FileName))
Dir() gets just the file name and Left() helps trim down the string to just the folder path.
There is even shorter option to get your path. Just with one single line:
'...your code
Dim InputFolder As String
InputFolder = Application.GetOpenFilename("Folder, *")
'new, single line solution
InputFolder = Mid(InputFolder, 1, InStrRev(InputFolder, Application.PathSeparator))
And I think there could be some more options available :)
If I understand right, you want to get the path to a file but you do not want to file name in the InputFolder string. If I understood correctly then this will do the trick:
Option Explicit
Sub GetFolderPath()
Dim InputFolder As String
Dim OutputFolder As String
InputFolder = Application.GetOpenFilename("Folder, *")
Range("C1").Value = getFilePath(InputFolder)
End Sub
Function getFilePath(path As String)
Dim filePath() As String
Dim finalString As String
Dim x As Integer
filePath = Split(path, "\")
For x = 0 To UBound(filePath) - 1
finalString = finalString & filePath(x) & "\"
Next
getFilePath = finalString
End Function
Also, you do not have to write the file name to the spreadsheet in order for another macro to get it. You can just call the other macro from your first macro and pass the file name as a parameter or set the file name variable as a module level variable so it can be accessed by the other macro, assuming that second macro is in the same module.
Wow, this board is incredible! I would up using casey's code and it worked perfectly :). I also added in a function to create subfolders as needed.
Here is the final product I settled on.
Option Explicit
Sub GetFolderPath()
Dim InputFolder As String
Dim OutputFolder As String
MsgBox ("Please Select the Folder of Origin")
InputFolder = Application.GetOpenFilename("Folder, *")
Range("D5").Value = getFilePath(InputFolder)
MsgBox ("Please Select the Desired Destination Root Folder")
InputFolder = Application.GetOpenFilename("Folder, *")
Range("E5").Value = getFilePath(InputFolder)
Dim OutputSubFolder As String
Dim Cell As Range
Range("E5").Select
OutputSubFolder = ActiveCell.Value
'Loop through this range which includes the needed subfolders
Range("C5:C100000").Select
For Each Cell In Selection
On Error Resume Next
MkDir OutputSubFolder & Cell
On Error GoTo 0
Next Cell
End Sub
Function getFilePath(path As String)
Dim filePath() As String
Dim finalString As String
Dim x As Integer
filePath = Split(path, "\")
For x = 0 To UBound(filePath) - 1
finalString = finalString & filePath(x) & "\"
Next
getFilePath = finalString
End Function