Посмотрим на свое network оборудование изнутри

On Error Resume Next

Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
arrComputers = Array("localhost")

For Each strComputer In arrComputers
str = str & "SystemName: " & objItem.SystemName & chr(13)
str = str & "==========================================" & chr(13)
str = str & "Computer: " & strComputer & chr(13)

Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_NetworkAdapter", "WQL",wbemFlagReturnImmediately +wbemFlagForwardOnly)

For Each objItem In colItems
str = str & "AdapterType: " & objItem.AdapterType & chr(13)
str = str & "AdapterTypeId: " & objItem.AdapterTypeId & chr(13)
str = str & "AutoSense: " & objItem.AutoSense & chr(13)
str = str & "Availability: " & objItem.Availability & chr(13)
str = str & "Caption: " & objItem.Caption & chr(13)
str = str & "ConfigManagerErrorCode: " & objItem.ConfigManagerErrorCode & chr(13)
str = str & "ConfigManagerUserConfig: " & objItem.ConfigManagerUserConfig & chr(13)
str = str & "CreationClassName: " & objItem.CreationClassName & chr(13)
str = str & "Description: " & objItem.Description & chr(13)
str = str & "DeviceID: " & objItem.DeviceID & chr(13)
str = str & "ErrorCleared: " & objItem.ErrorCleared & chr(13)
str = str & "ErrorDescription: " & objItem.ErrorDescription & chr(13)
str = str & "Index: " & objItem.Index & chr(13)
str = str & "InstallDate: " & WMIDateStringToDate(objItem.InstallDate) & chr(13)
str = str & "Installed: " & objItem.Installed & chr(13)
str = str & "LastErrorCode: " & objItem.LastErrorCode & chr(13)
str = str & "MACAddress: " & objItem.MACAddress & chr(13)
str = str & "Manufacturer: " & objItem.Manufacturer & chr(13)
str = str & "MaxNumberControlled: " & objItem.MaxNumberControlled & chr(13)
str = str & "MaxSpeed: " & objItem.MaxSpeed & chr(13)
str = str & "Name: " & objItem.Name & chr(13)
str = str & "NetConnectionID: " & objItem.NetConnectionID & chr(13)
str = str & "NetConnectionStatus: " & objItem.NetConnectionStatus & chr(13)
strNetworkAddresses = Join(objItem.NetworkAddresses, ",")
str = str & "NetworkAddresses: " & strNetworkAddresses & chr(13)
str = str & "PermanentAddress: " & objItem.PermanentAddress & chr(13)
str = str & "PNPDeviceID: " & objItem.PNPDeviceID & chr(13)
strPowerManagementCapabilities = Join(objItem.PowerManagementCapabilities, ",")
str = str & "PowerManagementCapabilities: " & strPowerManagementCapabilities & chr(13)
str = str & "PowerManagementSupported: " & objItem.PowerManagementSupported & chr(13)
str = str & "ProductName: " & objItem.ProductName & chr(13)
str = str & "ServiceName: " & objItem.ServiceName & chr(13)
str = str & "Speed: " & objItem.Speed & chr(13)
str = str & "Status: " & objItem.Status & chr(13)
str = str & "StatusInfo: " & objItem.StatusInfo & chr(13)
str = str & "SystemCreationClassName: " & objItem.SystemCreationClassName & chr(13)
str = str & "TimeOfLastReset: " & WMIDateStringToDate(objItem.TimeOfLastReset) & chr(13)
str = str & chr(13)
str = str & "=========================================="& chr(13)
'WScript.Echo str
'str = ""
Next
s = s & str
Next


Set obj=createobject ("scripting.filesystemobject")
Set notepad=obj.createtextfile("c:\res_net.txt")
notepad.writeline(s)


Function WMIDateStringToDate(dtmDate)
str = str & dtm:
WMIDateStringToDate = CDate(Mid(dtmDate, 5, 2) & "/" & _
Mid(dtmDate, 7, 2) & "/" & Left(dtmDate, 4) _
& " " & Mid (dtmDate, 9, 2) & ":" & Mid(dtmDate, 11, 2) & ":" & Mid(dtmDate,13, 2))
End Function

Снова о документе подключения

Снова возникла задача массово подрихтовать документы подключения у пользователей, убрать лишнее, посидев вечерочком....подумав ...попечатав ... вот что получилось

Sub create_connect
On Error Goto errmes
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim strErrMessage,connect,dserver
Dim s As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim coll As NotesDocumentCollection
Dim doc As NotesDocument
Dim coldoc As NotesDocument
Set db = s.GetDatabase("","names.nsf")


Set view = db.GetView("Connections")
'*****************************
connect = "server/domain"
'*****************************
Set coll = view.Getalldocumentsbykey(connect)
Stop
If coll.Count > 1 Then
'если в коллекции найдены несколько документов, то проверить у них интернет-хост
'если он не удовлетворяет условию, удалить документы не удовлетворяющие условию
Set doc = coll.Getfirstdocument
While Not(doc Is nothing)
If doc.Destination(0) = "CN=server/O=domain" Then
If Not (doc.OptionalNetworkAddress(0) = "server_inet_host") Then
Call doc.Removepermanently(True)
Call ws.Viewrefresh()
End If
End If
Set doc = coll.Getnextdocument(doc)
Wend
'если в коллекции найден один документ, то проверить у него интернет-хост
'и если он не удовлетворяет условию, то переписать значение на нужное
ElseIf coll.Count = 1 Then
Set doc = coll.Getfirstdocument
If Not doc.OptionalNetworkAddress(0) = "server_inet_host" Then
Call doc.ReplaceItemValue("OptionalNetworkAddress", "server_inet_host")
Call doc.ReplaceItemValue("PhoneNumber", "server_inet_host")
Call doc.Save(True,False)
End If
'если нет документа, то создать заново
ElseIf coll.Count = 0 Then

Set uidoc = ws.ComposeDocument( "", db.filename, "local" )
Call uidoc.FieldsetText("Destination","CN=server/O=domain")
Call uidoc.FieldsetText("OptionalNetworkAddress","server_inet_host")
Call uidoc.FieldsetText("PhoneNumber","server_inet_host")
Call uidoc.FieldsetText("PortName","TCPIP")
Call uidoc.FieldsetText("LanPortName","TCPIP")

Call uidoc.Save
Call uidoc.Close
Print "Документ подключения " & connect &" cоздан"
End if
'сообщение об ошибке
Exit Sub
errmes:
strErrMessage = "Ошибка " & Error$ & " выполняемая процедура " & Getthreadinfo(10) &" текущая процедура " & Getthreadinfo(1) & ", в строке " & Cstr(Erl)
Print strErrMessage
End sub

Работа со "stubs" (окурками, удаленных документов)

На днях... решая очередную задачу по db.search, столкнулся ,по началу,с непонятной вещью, а именно, в отчет лезут удаленные документы. Непорядок... нужно избавляться, и занялся я борьбой с последствиями курения - окурками.


Option Public
Option Declare

Dim strErrMessage
Const wAPIModule = "NNOTES"
Declare Private Sub IDDestroyTable Lib wAPIModule Alias "IDDestroyTable" _
( ByVal hT As Long)
Declare Private Function IDScan Lib wAPIModule Alias "IDScan" _
( ByVal hT As Long, ByVal F As Integer, ID As Long) As Integer
Declare Private Function NSFDbOpen Lib wAPIModule Alias "NSFDbOpen" _
( ByVal P As String, hDB As Long) As Integer
Declare Private Function NSFDbClose Lib wAPIModule Alias "NSFDbClose" _
( ByVal hDB As Long) As Integer
Declare Private Function NSFDbGetModifiedNoteTable Lib wAPIModule Alias "NSFDbGetModifiedNoteTable" _
( ByVal hDB As Long, ByVal C As Integer, ByVal S As Currency, U As Currency, hT As Long) As Integer
Declare Private Function NSFNoteDelete Lib wAPIModule Alias "NSFNoteDelete" _
( ByVal hDB As Long, ByVal N As Long, ByVal F As Integer) As Integer
Declare Private Function OSPathNetConstruct Lib wAPIModule Alias "OSPathNetConstruct" _
( ByVal NullPort As Long, ByVal Server As String, ByVal FIle As String, ByVal PathNet As String) As Integer
Declare Private Sub TimeConstant Lib wAPIModule Alias "TimeConstant" _
( ByVal C As Integer, T As Currency)
Dim Db As NotesDatabase

Sub countAndDeleteStubs(db As NotesDatabase, choice As Integer)
On Error GoTo errmes
Dim ever As Currency, last As Currency
Dim hT As Long, RRV As Long, hDB As Long
Dim n&,done,np$
With db
np$ = Space(1024)
OSPathNetConstruct 0, db.Server, db.FilePath, np$
End With
NSFDbOpen np$, hDB
TimeConstant 2, ever
NSFDbGetModifiedNoteTable hDB, &H7FFF, ever, last, hT
n& = 0
done = (IDScan(hT, True, RRV) = 0)
While Not done
If RRV < 0 Then
If (choice = 1) Then
NSFNoteDelete hDB, RRV And &H7FFFFFFF, &H0201
End If
n& = n& + 1
End If
done = (IDScan(hT, False, RRV) = 0)
Wend
IDDestroyTable hT
NSFDbClose hDB

If (choice = 1) Then
print "Удалено " & CStr(n&) & " окурков в базе данных " & db.FilePath & " на сервере " & db.Server
Else
print "В базе данных " & db.FilePath & " на сервере " & db.Server & " найдено " & CStr(n&) & " окурков"
End If
Exit sub
errmes:
strErrMessage = "Ошибка " & Error$ & " выполняемая процедура " & GetThreadInfo(10) &" текущая процедура " & GetThreadInfo(1) & ", в строке " & CStr(Erl)
Print strErrMessage
End Sub

Sub findstubs
'поиск окурков
On Error GoTo errmes
Dim Session As New NotesSession
Dim ws As New NotesUIWorkspace
Dim dbInfo As Variant
Dim sDbServer As String
Dim sDbPath As String
Dim retVal As Integer

Set db = session.Currentdatabase
retVal = ws.Prompt (PROMPT_YESNOCANCEL,"Удалить ""Окурки""?","Удалить все [да] или показать их число [Нет]")
Select Case retVal
Case 1 : Call countAndDeleteStubs(db, 1)
Case 0 : Call countAndDeleteStubs(db, 0)
Case -1 : print "Отменено"
End Select
Print "Процедура сжатия базы данных..."
Call db.Compact
Exit Sub
errmes:
strErrMessage = "Ошибка " & Error$ & " выполняемая процедура " & Getthreadinfo(10) &" текущая процедура " & Getthreadinfo(1) & ", в строке " & Cstr(Erl)
Print strErrMessage
End Sub

ProgressBar

На днях, решил приукрасить подготовку отчетов "прогрессом"
Особенность от стандартного использования - это, конвертация ascii в читабельный вид

Вот что получилось

'функции преобразования строк
Const OS_TRANSLATE_NATIVE_TO_LMBCS = 0 'Translate platform-specific to LMBCS */
Const OS_TRANSLATE_LMBCS_TO_NATIVE = 1 'Translate LMBCS to platform-specific */
Const OS_TRANSLATE_LOWER_TO_UPPER = 3 'current int'l case table */
Const OS_TRANSLATE_UPPER_TO_LOWER = 4 'current int'l case table */
Const OS_TRANSLATE_UNACCENT = 5 'int'l unaccenting table */
Const OS_TRANSLATE_LMBCS_TO_ASCII_DOS = 11
Const OS_TRANSLATE_LMBCS_TO_ASCII = 13
Declare Sub OSTranslate Lib "nnotes.dll" Alias "OSTranslate"( ByVal mode As Integer, ByVal strIn As String, ByVal lenIn As Integer, ByVal strOut As String, ByVal lenOut As Integer )
Declare Function NEMProgressBegin Lib "nnotesws.dll" ( ByVal wFlags As Integer ) As Long
Declare Sub NEMProgressEnd Lib "nnotesws.dll" ( ByVal hwnd As Long )
Declare Sub NEMProgressSetBarPos Lib "nnotesws.dll" ( ByVal hwnd As Long, ByVal dwPos As Long)
Declare Sub NEMProgressSetBarRange Lib "nnotesws.dll" ( ByVal hwnd As Long, ByVal dwMax As Long )
Declare Sub NEMProgressSetText Lib "nnotesws.dll" ( ByVal hwnd As Long, ByVal pcszLine1 As String, _
ByVal pcszLine2 As String )
Const NPB_TWOLINE% = 1

Class ProgressBar
Private hwnd As Long

Sub New (BarRange As Long)
On Error GoTo ErrorHandler

Me.hwnd = NEMProgressBegin (NPB_TWOLINE)

Call NEMProgressSetBarRange (Me.hwnd, BarRange)

Exit Sub
ErrorHandler:
strErrMessage_rep = "Ошибка " & Error$ & " выполняемая процедура " & GetThreadInfo(10) &" текущая процедура " & GetThreadInfo(1) & ", в строке " & CStr(Erl)
Print strErrMessage_rep

End Sub

Код как использовать

Dim s As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim server
Dim view_adr As NotesView
Set db = s.Currentdatabase
If Not ( db.IsFTIndexed ) Then
Call db.UpdateFTIndex( True )
End If
If ( db.LastModified > db.LastFTIndexed ) Then
Call db.UpdateFTIndex( True )
End If
Set view_adr = db.GetView("view_object")
Dim i As Long
Set doc = view_adr.Getfirstdocument()
a = view_adr.Allentries.Count
Dim RefreshProgress As New ProgressBar (view_adr.Allentries.Count) 'отображение рогрес-бара
Dim BarMsg As String
Dim UpdMsg As String
Let BMsg = "Обработка окументов..."
Let tmp0=Len(BMsg)
Let tmp1=Len(BMsg)*2
Let BarMsg = Space(Len(BMsg)*2)
Call OSTranslate( OS_TRANSLATE_NATIVE_TO_LMBCS, BMsg, tmp0, BarMsg, tmp1 )
For i = 1 To a
Call plan_nachislenie(doc)
Call RefreshProgress.UpdatePosition (i)
Let ascii = doc.address(0)
Let tmp0=Len(ascii)
Let tmp1=Len(ascii)*2
Let UpdMsg = Space(Len(ascii)*2)
Call OSTranslate( OS_TRANSLATE_NATIVE_TO_LMBCS, ascii, tmp0, UpdMsg, tmp1 )
Call RefreshProgress.UpdateProgressText(BarMsg, UpdMsg)

Set doc = view_adr.GetNextdocument(doc)
Next
Print "Готово"