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
Related
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
Below is an OPC Client written in VBA. It is using the OPC Foundation DA libraries. I am able to get the current value of the item (I can read it in locals window), but it is not assigning the value to myValue = theItem.Value Hovering over theItem.Value during a break shows the value as well.
Any thoughts?
Public Sub ReadValue()
Dim serverNames As Variant
Dim listServers As Variant
Dim i As Integer
Dim theStates As Variant
Set theServer = New OPCServer
serverNames = theServer.GetOPCServers
theStates = Array("Disconnected", "Running", "Failed", "No Configuration", "Suspended", "In Test")
For i = LBound(serverNames) To UBound(serverNames)
Debug.Print (serverNames(i))
Next i
theServer.Connect ("MyOPCServer")
Debug.Print theServer.VendorInfo
Debug.Print theServer.MajorVersion & "." & theServer.MinorVersion
Debug.Print theStates(theServer.ServerState)
Debug.Print theServer.StartTime
Debug.Print theServer.CurrentTime
Debug.Print theServer.LastUpdateTime
'Groups
Dim theGroup As OPCGroup
Dim theGroups As OPCGroups
If theGroups Is Nothing Then
Set theGroups = theServer.OPCGroups
End If
If theGroup Is Nothing Then
Set theGroup = theGroups.Add("testing")
txtName = theGroup.name
End If
theGroup.UpdateRate = CLng(1000)
theGroup.DeadBand = CLng(1)
theGroup.TimeBias = CLng(0)
theGroup.IsActive = CBool(1)
theGroup.IsSubscribed = CBool(1)
'
Dim theItem As OPCItem
Dim theItem1 As OPCItem
Dim myItems As Variant
Dim myValue As Variant
Dim myWriteValues As Variant
Dim handles(1) As Long
Dim Errors() As Long
Dim CancelID As Long
Dim TransID As Long
myItems = Array("MyPathBlahBlahBlah.CV")
myWriteValues = Array(8, 0, 1)
For i = LBound(myItems) To UBound(myItems)
Set theItem = theGroup.OPCItems.AddItem(myItems(i), currentHandle)
myValue = theItem.Value
handles(1) = theGroup.OPCItems.Item(1).ServerHandle
theGroup.OPCItems.Remove 1, handles, Errors
Next i
theServer.Disconnect
End Sub
After review/trouble shooting.
The OPCItem object provides methods to read the current value of the item in the server and write a new value to the item. I have included these facilities into this dialog. The read method provided on an OPCItem object performs a synchronous read from the server and can be configured to read either from cache or from the device. To read from cache both the group and item should be active, but synchronous read operations directly from the device do not depend on the active state of either the group or item.
Adding the following code allowed me to assign to variable.
Dim source As OPCDataSource
Dim myValue As Variant
source = OPCDevice
theItem.Read source, myValue
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 have the following code:
Sub AddSources()
Dim pubPage As Page
Dim pubShape As Shape
Dim hprlink As Hyperlink
Dim origAddress() As String
Dim exportFileName As String
exportFileName = "TestResume"
Dim linkSource As String
linkSource = "TestSource2"
Dim hyperLinkText As TextRange
For Each pubPage In ActiveDocument.Pages
For Each pubShape In pubPage.Shapes
If pubShape.Type = pbTextFrame Then
For Each hprlink In pubShape.TextFrame.TextRange.Hyperlinks
If InStr(hprlink.Address, "http://bleaney.ca") > 0 Then
hyperLinkText = hprlink.Range
origAddress = Split(hprlink.Address, "?source=")
hprlink.Address = origAddress(0) + "?source=" + linkSource
hprlink.Range = hyperLinkText
End If
Next hprlink
End If
Next pubShape
Next pubPage
ThisDocument.ExportAsFixedFormat pbFixedFormatTypePDF, "C:\" + exportFileName + ".pdf"
End Sub
I am getting the "Object variable or With block variable not set (Error 91)" error on the line with hyperLinkText = hprlink.Range. When I debug I can see that hprlink.Range does have a value. Any thoughts what I'm doing wrong?
As I wrote in my comment, the solution to your problem is to write the following:
Set hyperLinkText = hprlink.Range
Set is needed because TextRange is a class, so hyperLinkText is an object; as such, if you want to assign it, you need to make it point to the actual object that you need.
Is there a way to detect when a user
renames, or
deletes a worksheet?
I want to run some code if one of these events happens.
what I have tried
My tool uses a lot of event handlers so one thing I thought of was looping through all the sheetnames during each Worksheet_Change, but I don't think that is the best approach.
This approach goes under the ThisWorkbook module.
Public shArray1 As Variant
Public shArray2 As Variant
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Dim lngCnt As Long
Dim strMsg As String
Dim strSht
Dim vErr
Dim strOut As String
'get all sheet names efficiently in a 1D array
ActiveWorkbook.Names.Add "shtNames", "=RIGHT(GET.WORKBOOK(1),LEN(GET.WORKBOOK(1))-FIND(""]"",GET.WORKBOOK(1)))"
shArray2 = Application.Transpose([INDEX(shtNames,)])
strSht = Application.Transpose(Application.Index(shArray2, , 1))
'exit here if first time code is run
If IsEmpty(shArray1) Then
shArray1 = shArray2
Exit Sub
End If
`check each sheet name still exists as is
For lngCnt = 1 To UBound(shArray1)
vErr = Application.Match(shArray1(lngCnt, 1), strSht, 0)
If IsError(vErr) Then
strOut = strOut & shArray1(lngCnt, 1) & vbNewLine
vErr = Empty
End If
Next
shArray1 = Application.Transpose([INDEX(shtNames,)])
If Len(strOut) > 0 Then MsgBox strOut, vbCritical, "These sheets are gone or renamed"
End Sub