Excel2000 VBA IPアドレス、コンピューター名、ユーザー名をMsgBoxに表示 その２

Excel2000 VBA  IPアドレス、DefaultGateway,コンピューター名、ユーザー名をMsgBoxに表示とクリップボードにコピー

 

Sub ip_username()
'
'IPアドレス、コンピューター名、ユーザー名をMsgBoxに表示
'参考　http://www.atmarkit.co.jp/fwin2k/operation/wsh05/wsh05_03.html

Dim wsh, exe As Object
Dim ipaddress, computername, username, gateway, buf, crlf As String
Dim strLine, iColon As Integer

'crlf = Chr(13) + Chr(10) + Chr(13) + Chr(10) '２回改行
crlf = Chr(13) + Chr(10)

Set wsh = CreateObject("WScript.Shell")

computername = wsh.ExpandEnvironmentStrings("%COMPUTERNAME%")
username = wsh.ExpandEnvironmentStrings("%USERNAME%")

Set exe = wsh.Exec("ipconfig.exe")

Do Until exe.StdOut.AtEndOfStream
  strLine = exe.StdOut.ReadLine
  If InStr(strLine, "IP Address") <> 0 Then
    iColon = InStr(strLine, ":")
    'Debug.Print iColon
    ipaddress = Mid(strLine, iColon + 2)
    ipaddress = Replace(ipaddress, vbCr, "")
  End If
  If InStr(strLine, "Default Gateway") <> 0 Then
    iColon = InStr(strLine, ":")
    'Debug.Print iColon
    gateway = Mid(strLine, iColon + 2)
    gateway = Replace(gateway, vbCr, "")
  End If
Loop
buf = "IP Address : " & ipaddress & crlf & "Default Gateway : " & gateway & crlf & "コンピューター名 : " & computername & crlf & "ユーザー名 : " & username

'クリップボードに保存
    Dim TempObject As MSForms.DataObject
   
    Set TempObject = New MSForms.DataObject
   
    With TempObject
        .SetText buf
        .PutInClipboard
    End With
              
    Set TempObject = Nothing

Set wsh = Nothing
Set exe = Nothing
MsgBox buf & crlf + crlf & "クリップボードにコピーしました。"
End Sub

タグ：Excel2000 VBA