1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
'WMI - Easy Shutdown
'If you have gotten tired of having to click several items just to
'shutdown your PC or laptop, save this script to a .vbs file and
'create an icon for it.   It will shutdown your machine with just
'one click.   No prompts, no waiting, just power down.  
'I've also included a few of the other constants just in case you need a slight variation.
Sub ForceReBoot()
   nLogOff                = 0     'Alternative actions to force reboot
   nReboot               = 2
   nForceLogOff         = 4
   nForceReboot        = 6
   nPowerDown         = 8
   nForcePowerDown = 12
   Set oOS = GetObject("winmgmts:{(Shutdown)}").ExecQuery("Select * from Win32_OperatingSystem")
   For Each oOperatingSystem in oOS
      oOperatingSystem.Win32Shutdown(nForceReboot)
   Next
End sub' ForceReBoot
 
Sub SleepDelay ()
For i = 1 to 5
'  Wait 10 seconds (1000ms = 1 second)
   Wscript.Sleep 10*(1000)
Next 'i
 
End Sub 'SleepDelay

Deklarace vlastniho typu
1
2
3
4
5
Private Type ty_s_PC_Properties
    g_numb As String
    ip_add As String
    status As String
End Type

Hlavni makro pro nacteni PC z MS Excel a doplneni vysledku do tabulky
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
'this sub calls the above function using a for each loop
Sub GetIPStatus()
    
    'declaring variables
    Dim Cell As Range
    Dim ipRng As Range
    Dim Result As String
    Dim objPC As ty_s_PC_Properties
    Dim Wks As Worksheet
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    
    'this clears the current Ping Status column (not necessary but visually helpful
    Worksheets("List2").Range("B2:B10000").Clear
    
    'this starts a time to see how long the status check takes
    StartTime = Timer
    
    'setting values of variables
    Set Wks = Worksheets("List2")
    Set ipRng = Wks.Range("A2")
    Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
    Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))
    
    
    'this is a loop that feeds each server from the list into the GetPingResult function
    For Each Cell In ipRng
        objPC = GetPingResult(Cell)
        Cell.Offset(0, 1) = objPC.ip_add
        Cell.Offset(0, 2) = objPC.status
    Next Cell
    
    'this calculates the time it took to run the script and converts it to minutes
    SecondsElapsed = Round(Round(Timer - StartTime, 2) / 60)
    
    'this displays the final time taken and lets the user know everything has completed
    MsgBox "This code ran successfully in " & SecondsElapsed & " minutes", vbInformation
 
End Sub

Funkce PING pres VBA
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
'This function does the pinging
Private Function GetPingResult(Host) As ty_s_PC_Properties
   
    'declaring variables
    Dim objPing As Object
    Dim objStatus As Object
    Dim objResult As ty_s_PC_Properties 'String
    
    'ping the host
    Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
                            ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'")
    
    'report the results
    For Each objStatus In objPing
        ' --
        With objResult
            .g_numb = Host
            .ip_add = objStatus.ProtocolAddress
            .status = getStatusCode(objStatus.StatusCode)
        End With
        ' --
        GetPingResult = objResult 'strResult
    
    Next
    
    'reset object ping variable
    Set objPing = Nothing
 
End Function

Funkce pro vraceni statusu (konstanty)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Private Function getStatusCode(StatusCode) As String
    Dim strResult As String
    
    '---
    Select Case StatusCode
        Case 0: strResult = "Connected"
        Case 11001: strResult = "Buffer too small"
        Case 11002: strResult = "Destination net unreachable"
        Case 11003: strResult = "Destination host unreachable"
        Case 11004: strResult = "Destination protocol unreachable"
        Case 11005: strResult = "Destination port unreachable"
        Case 11006: strResult = "No resources"
        Case 11007: strResult = "Bad option"
        Case 11008: strResult = "Hardware error"
        Case 11009: strResult = "Packet too big"
        Case 11010: strResult = "Request timed out"
        Case 11011: strResult = "Bad request"
        Case 11012: strResult = "Bad route"
        Case 11013: strResult = "Time-To-Live (TTL) expired transit"
        Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
        Case 11015: strResult = "Parameter problem"
        Case 11016: strResult = "Source quench"
        Case 11017: strResult = "Option too big"
        Case 11018: strResult = "Bad destination"
        Case 11032: strResult = "Negotiating IPSEC"
        Case 11050: strResult = "General failure"
        Case Else: strResult = "Unknown host"
    End Select
    
    '---
    getStatusCode = strResult
    
End Function

Seznam konstant jazyka VBScript

Zápis konstant (jejich textový zápis) lze použít kdekoliv ve skriptu místo aktuálních hodnot, což umožňuje pohodlný zápis hodnoty bez znalosti její číselné hodnoty. Používání textového zápisu konstant také dělá skript přehlednějším a snadněji upravovatelným. Protože konstanty jsou definovány ve VBScriptu, nemusí být deklarovány ve skriptu.
 

VBScript konstanty hodnot datových typů (Viz také Datové typy VBScript) :

Konstanta Popis
true Klíčové slovo booleovské hodnoty "Pravda" (odpovídá hodnotě -1 !!)
false Klíčové slovo booleovské hodnoty "Nepravda" (odpovídající hodnotě 0)
Empty Klíčové slovo indikující, že proměnná nebyla inicializována
Null Klíčové slovo indikující, že proměnná obsahuje neplatná data
Nothing Klíčové slovo indikující, že proměnná typu Object neukazuje na žádný objekt
 

VBScript konstanty datových typů :

Konstanta Hodnota Popis
vbEmpty 0 datový typ neinicializován
vbNull 1 neobsahuje platná data
vbBoolean 11 datový typ Boolean
vbByte 17 datový typ Byte
vbInteger 2 datový typ Integer
vbLong 3 datový typ Long
vbSingle 4 datový typ Single
vbDouble 5 datový typ Double
vbDate 7 datový typ Date
vbString 8 datový typ String
vbObject 9 datový typ Object
vbVariant 12 datový typ Variant
vbArray 8192 datový typ Array (pole)
 

VBScript konstanty řetězců (hodnoty těchto konstant lze také vytvořit funkcí Chr) :

Konstanta Hodnota Popis
vbCr Chr(13) Začátek řádku (Carriage return)
vbCrLf Chr(13) & Chr(10) Začátek nového řádku
vbFormFeed Chr(12) Nová strana (Form feed); neužívané v OS Windows
vbLf Chr(10) Nový řádek (Line feed)
vbNewLine Chr(13) & Chr(10) nebo Chr(10) závisí na platformě. Někdy je nutná kombinace vbCrLf (pozice na začátku nového řádku), někdy stačí vbLf (pozice na novém řádku)
vbNullChar Chr(0) znak s hodnotou 0
vbNullString String mající hodnotu 0 Volání externích procedur. Není stejná jako řetězec s nulovou délkou ("").
vbTab Chr(9) horizontální tabulátor
 

VBScript konstanty datumu a času :

Konstanta Hodnota Popis
vbSunday 1 Neděle
vbMonday 2 Pondělí
vbTuesday 3 Úterý
vbWednesday 4 Středa
vbThursday 5 Čtvrtek
vbFriday 6 Pátek
vbSaturday 7 Sobota
vbFirstJan1 1 týden, ve kterém se vyskytuje 1. leden
vbFirstFourDays 2 1. týden, který obsahuje alespoň 4 dny daného roku
vbFirstFullWeek 3 první týden, který je celý tvořen dny daného roku
vbUseSystem 0 formát datumu definovaný v regionálním nastavení PC
vbUseSystemDayOfWeek 0 pro den v týdnu použije den podle nastavení PC

Priklady funkci

1
2
3
4
5
6
7
Function Area(Length As Double, Optional Width As Variant)
    If IsMissing(Width) Then
        Area = Length * Length
    Else
        Area = Length * Width
    End If
End Function