Code:
'In support of these forum posts
'https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776
'https://excelfox.com/forum/showthrea...5356#post15356
'https://eileenslounge.com/viewtopic.php?f=18&t=37740
'https://eileenslounge.com/viewtopic.php?f=18&t=37712
'https://eileenslounge.com/viewtopic.php?f=18&t=37707
Sub Services2() ' https://excelfox.com/forum/showthrea...ge51#post12776 https://excelfox.com/forum/showthrea...5356#post15356
' kill the text file before I make it, because the code might otherwise use a previous one, as it takes a second or so to overwrite the old or make a new one
Do While Dir("" & ThisWorkbook.Path & Application.PathSeparator & "test.txt", vbNormal) <> ""
If Dir("" & ThisWorkbook.Path & Application.PathSeparator & "test.txt", vbNormal) <> "" Then Kill PathName:="" & ThisWorkbook.Path & Application.PathSeparator & "test.txt"
Application.Wait (Now + TimeValue("0:00:01"))
Loop
DoEvents: DoEvents
' Application.Wait (Now + TimeValue("0:00:01")) ' I am not sure why I had to do this. It should not be necerssary, without it the text file is empty - maybe Dir says something is there before it is available to have???
' PowerShell
Dim PScmdLet As String, cmdLet As String
'Let cmdLet = "Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\acer\Desktop\test.txt' -Width 1000"
Let cmdLet = "Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath '" & ThisWorkbook.Path & Application.PathSeparator & "test.txt' -Width 2000"
Let PScmdLet = "powershell -command " & cmdLet ' https://www.devhut.net/vba-run-powershell-command/
CreateObject("WScript.Shell").Exec (PScmdLet)
' we need to wait a bit until the text file is made
Do While Dir("" & ThisWorkbook.Path & Application.PathSeparator & "test.txt", vbNormal) = ""
Application.Wait (Now + TimeValue("0:00:01"))
Loop
DoEvents: DoEvents ' I chucked this in, but did not really have any reason
Application.Wait (Now + TimeValue("0:00:02")) ' I am not sure why I had to do this. It should not be necerssary, without it the text file is empty - maybe Dir says something is there before it is available to have??? 01 seemed OK - I made it 2
' Get the text file as a long single string
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba...efile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "test.txt" ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundamental type data input...
Let TotalFile = Space(LOF(FileNum)) '....and wot receives it has to be a string of exactly the right length
Get #FileNum, , TotalFile 'Debug.Print TotalFile
Let TotalFile = Replace(TotalFile, Chr(0), "", 1, -1, vbBinaryCompare) ' There seems to be a lot of Chr(0)s in the string https://i.postimg.cc/t43HCQr9/Rather...of-Chr-0-s.jpg
'Let TotalFile = Replace(TotalFile, Chr(255) & Chr(254) & vbCr & vbLf, "", 1, 1, vbBinaryCompare) ' this would tsake the first bit of crap out, (alternatively we can just take out the first line when split later by
Close #FileNum
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)
' make a 1 D array of the text file lines
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
' make array for output
Dim arrOut() As String: ReDim arrOut(1 To UBound(arrRws()) - 2, 1 To 3) ' we are ignoring the first 3 lines. The UBound of the 1 dimensional array is already 1 less then the lines we need because a 1 dimensional array starts at 0
Dim Cnt As Long
For Cnt = 1 To UBound(arrRws()) - 2
If arrRws(Cnt + 2) = "" Then
' This should occur at the last empty rows, so we could consider jumping out of the loop here
Else
' This is a bit of a temporary bodge as the Display name sometimes pushes up to the startuptype which screws up the string manipulation below
Let arrRws(Cnt + 2) = Replace(arrRws(Cnt + 2), "Manual", " Manual", 1, 1, vbBinaryCompare): Let arrRws(Cnt + 2) = Replace(arrRws(Cnt + 2), "Automatic", " Auotomatic", 1, 1, vbBinaryCompare): Let arrRws(Cnt + 2) = Replace(arrRws(Cnt + 2), "Disabled", " Disabled", 1, 1, vbBinaryCompare)
' time to split the line string
Dim Pos1 As Long: Let Pos1 = InStr(1, arrRws(Cnt + 2), " ", vbBinaryCompare)
Dim Nme As String: Let Nme = Left(arrRws(Cnt + 2), Pos1 - 1)
Dim Pos3 As Long: Let Pos3 = Len(arrRws(Cnt + 2)) - InStrRev(arrRws(Cnt + 2), " ", -1, vbBinaryCompare)
Dim StrtTyp As String: Let StrtTyp = Right(arrRws(Cnt + 2), Pos3)
Dim DispNme As String: Let DispNme = Replace(arrRws(Cnt + 2), Nme, "", 1, 1, vbBinaryCompare)
Let DispNme = Replace(DispNme, StrtTyp, "", 1, 1, vbBinaryCompare)
Let DispNme = Trim(DispNme)
' fill the array for output
Let arrOut(Cnt, 1) = Nme: arrOut(Cnt, 2) = DispNme: arrOut(Cnt, 3) = StrtTyp
End If
Next Cnt
' Chuck array into a spreadsheet
Let ThisWorkbook.Worksheets("PowerShell").Range("A2").Resize(UBound(arrOut(), 1), 3).Value = arrOut()
ThisWorkbook.Worksheets("PowerShell").Cells.Columns("A:C").EntireColumn.AutoFit
End Sub
Reply With Quote
Bookmarks