SHARE
TWEET

VB Logged In Users

codog180 Jul 9th, 2018 25 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Option explicit
  2.  
  3. ' List Last logins on a client
  4. ' By Remco Simons [NL] 2011
  5. ' http://forums.petri.com/showthread.php?t=55222
  6.  
  7. ' (Note !,
  8. '  also a remote WMI session to the computer and other
  9. '  types of remote logon can be Registered User Logins too! )
  10.  
  11. Const HKEY_LOCAL_MACHINE = &H80000002
  12. Const ForAppending = 8
  13. Dim strComputer, oReg, oWMISvc, regEx, dt
  14. Dim fso, objTextFile, strFile, strPath
  15.  
  16. strComputer = "."  'for local computer enter "."
  17.  
  18. strFile = "List Logons over the last 24 hours.txt"
  19.  
  20. Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
  21.     strComputer & "\root\default:StdRegProv")
  22. Set oWMISvc = GetObject("winmgmts:\root\cimv2")
  23. Set regEx = New RegExp
  24. dt = now
  25. Set fso = CreateObject("Scripting.FileSystemObject")
  26. strPath = fso.GetParentFolderName( Wscript.ScriptFullName )
  27. Set objTextFile = fso.OpenTextFile _
  28.    (strPath & "\" & strFile, ForAppending, True)
  29.  
  30. objTextFile.WriteLine
  31. objTextFile.Write dt & " * "
  32. objTextFile.WriteLine "Target computer: " & strComputer
  33.  
  34.  
  35. call LastLogons(getLocalBIAS)
  36.  
  37. objTextFile.WriteLine
  38. objTextFile.WriteLine "-------"
  39. objTextFile.Close '!
  40.  
  41.  
  42. Sub LastLogons(lngBias)
  43.    Dim strKeyPath, arrSubKeys, subkey, strValueName
  44.    Dim sUsr, LastLogon, TimeHigh, TimeLow
  45.  
  46.    On Error Resume Next
  47.    regEx.Pattern = "^S-1-5-21-[0-9]*-[0-9]*-[0-9]*-[0-9]*$"
  48.    regEx.IgnoreCase = TRUE
  49.  
  50.    strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList"
  51.    oReg.EnumKey HKEY_LOCAL_MACHINE, strKeyPath, arrSubKeys
  52.  
  53.    For Each subkey In arrSubKeys
  54.      If regEx.Test(subkey)=TRUE Then
  55.        sUsr = resolveSID(subkey)
  56.  
  57.        strValueName = "ProfileLoadTimeHigh"
  58.        oReg.GetDWORDValue HKEY_LOCAL_MACHINE, strKeyPath _
  59.          & "\" & subkey, strValueName,TimeHigh
  60.  
  61.        strValueName = "ProfileLoadTimeLow"
  62.        oReg.GetDWORDValue HKEY_LOCAL_MACHINE, strKeyPath _
  63.          & "\" & subkey, strValueName,TimeLow
  64.  
  65.        LastLogon = getDT(TimeHigh, TimeLow, lngBias)
  66.  
  67.        If sUsr = Empty Then
  68.          strValueName = "ProfileImagePath"
  69.          oReg.GetExpandedStringValue HKEY_LOCAL_MACHINE, strKeyPath _
  70.            & "\" & subkey, strValueName,sUsr
  71.        End If
  72.  
  73.        ' last 24 hours only,
  74.   rem    If DateDiff("n",LastLogon, dt)/60 =< 24 Then
  75.  
  76.        ' one particular user only,
  77.   rem    If InStr(1,sUsr,"Igor",1) > 0 Then
  78.  
  79.    rem      MsgBox sUsr & vbNewline _
  80.    rem        & "LastLogon: " & LastLogon, _
  81.    rem        ,"Computer: " & strComputer
  82.  
  83.          objTextFile.WriteLine
  84.          objTextFile.WriteLine(sUsr & vbNewline _
  85.              & "LastLogon: " & LastLogon)
  86.  
  87.    rem    End If
  88.        End If
  89.  
  90.     rem End If
  91.    Next
  92. End Sub
  93.  
  94. Function getLocalBIAS
  95.    ' Obtain local Time Zone bias from machine registry.
  96.   ' (= the time-zone + daylight saving offset)
  97.   ' This bias changes with Daylight Savings Time.
  98.   Dim strKeyPath, strValueName, lngBiasKey
  99.  
  100.    strKeyPath = "System\CurrentControlSet\Control\TimeZoneInformation"
  101.    strValueName = "ActiveTimeBias"
  102.    oReg.GetDWORDValue HKEY_LOCAL_MACHINE, strKeyPath, strValueName,lngBiasKey
  103.    If (UCase(TypeName(lngBiasKey)) = "LONG") Then
  104.      getLocalBIAS = lngBiasKey
  105.    ElseIf (UCase(TypeName(lngBiasKey)) = "VARIANT()") Then
  106.      getLocalBIAS = -0
  107.      For k = 0 To UBound(lngBiasKey)
  108.        getLocalBIAS = getLocalBIAS + (lngBiasKey(k) * 256^k)
  109.      Next
  110.    End If
  111. End Function
  112.  
  113. Function getDT(H, L, Bias)
  114.    ' http://forums.petri.com/showpost.php?p=182526&postcount=2
  115.   On Error Resume Next
  116.  
  117.    Dim HexVal, Highpart, Lowpart, lngDate
  118.  
  119.    Highpart = H
  120.    'HexVal = H
  121.   'HexVal = Replace(HexVal, "0x", "")
  122.   'HexVal = Replace(HexVal, "&H", "")
  123.   'Highpart = CLng("&H" & HexVal)
  124.  
  125.    Lowpart = L
  126.    'HexVal = L
  127.   'HexVal = Replace(HexVal, "0x", "")
  128.   'HexVal = Replace(HexVal, "&H", "")
  129.   'Lowpart = CLng("&H" & HexVal)
  130.  
  131.    '# unite the HighPart and LowPart
  132.   lngDate = Highpart * 2^32 + L
  133.  
  134.    '# convert the number of 100-Nanosecond intervals to days
  135.   lngDate = ((lngDate*1E-7/60) -BIAS)/1440  'days
  136.  
  137.    '# Add the number of days to the "zero" date
  138.   getDT = CDate( #1/1/1601# + lngDate )
  139. End Function
  140.  
  141. Function resolveSID(sid)
  142.    Dim strUser, strDomain
  143.    On Error Resume Next
  144.    With oWMISvc
  145.      With .Get("Win32_SID.SID='" & sid & "'")
  146.        strUser = .AccountName
  147.        strDomain = .ReferencedDomainName
  148.      End With
  149.    End With
  150.    If len(strUser) = 0 Then
  151.      resolveSID = Empty
  152.    Else
  153.      resolveSID = strDomain & "\" & strUser
  154.    End If
  155. End function
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top