找回密码
 注册

QQ登录

只需一步,快速开始

搜索

VBA脚本获取计算机IP

[复制链接]
coolice 发表于 2020-4-27 11:44:27 | 显示全部楼层 |阅读模式

Public Sub SaveActionLog(ByVal sActNo As String, ByVal sActtype As String, ByVal sActDesc As String)
Dim Database_Cnn As ADODB.Connection
Dim RS As ADODB.Recordset
Dim Cmd As ADODB.Command
Dim Param As ADODB.Parameter
Dim nValue As Long
On Error GoTo e

Set Cmd = New ADODB.Command
Set Param = New ADODB.Parameter
Set Database_Cnn = New ADODB.Connection
Database_Cnn.ConnectionString = "File Name=" & "C:\TY_Integration\UserControl\DB.udl"
Database_Cnn.Open
Cmd.CommandText = "Proc_SaveActionLog"
Cmd.CommandType = adCmdStoredProc
Cmd.ActiveConnection = Database_Cnn

Param.Name = "RetVal"
Param.Type = adInteger
Param.Direction = adParamReturnValue
Cmd.Parameters.Append Param

Set Param = New ADODB.Parameter
Param.Name = "@vchActNo"
Param.Type = adVarChar
Param.Size = 32
Param.Direction = adParamInput
Param.Value = sActNo
Cmd.Parameters.Append Param

Set Param = New ADODB.Parameter
Param.Name = "@vchActType"
Param.Type = adVarChar
Param.Size = 32
Param.Direction = adParamInput
Param.Value = sActtype
Cmd.Parameters.Append Param

Set Param = New ADODB.Parameter
Param.Name = "@vchActDesc"
Param.Type = adVarChar
Param.Size = 128
Param.Direction = adParamInput
Param.Value = sActDesc
Cmd.Parameters.Append Param
Cmd.Execute
nValue = Cmd.Parameters("RetVal").Value

Exit Sub
e:
'MsgBox Err.Description
End Sub

Public Function GetIPAddress() As String

   Dim sHostName    As String * 256
   Dim lpHost    As Long
   Dim HOST      As HOSTENT
   Dim dwIPAddr  As Long
   Dim tmpIPAddr() As Byte
   Dim i         As Integer
   Dim sIPAddr  As String

   If Not SocketsInitialize() Then
      GetIPAddress = ""
      Exit Function
   End If
   MAX_WSADescription = 256
   MAX_WSASYSStatus = 128
   ERROR_SUCCESS = 0
   WS_VERSION_REQD = &H101
   WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
   WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
   MIN_SOCKETS_REQD = 1
   SOCKET_ERROR = -1

   If gethostname(sHostName, 256) = SOCKET_ERROR Then
      GetIPAddress = ""
      MsgBox "Windows Sockets error " & str$(WSAGetLastError()) & _
              " has occurred. Unable to successfully get Host Name."
      SocketsCleanup
      Exit Function
   End If


   sHostName = Trim$(sHostName)
   lpHost = gethostbyname(sHostName)

   If lpHost = 0 Then
      GetIPAddress = ""
      MsgBox "Windows Sockets are not responding. " & _
              "Unable to successfully get Host Name."
      SocketsCleanup
      Exit Function
   End If

   CopyMemory HOST, lpHost, Len(HOST)
   CopyMemory dwIPAddr, HOST.hAddrList, 4

   ReDim tmpIPAddr(1 To HOST.hLen)
   CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen

   For i = 1 To HOST.hLen
      sIPAddr = sIPAddr & tmpIPAddr(i) & "."
   Next


   GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)

   SocketsCleanup

End Function

Public Function GetIPHostName() As String

Dim sHostName As String * 256
   MAX_WSADescription = 256
   MAX_WSASYSStatus = 128
   ERROR_SUCCESS = 0
   WS_VERSION_REQD = &H101
   WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
   WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
   MIN_SOCKETS_REQD = 1
   SOCKET_ERROR = -1
    If Not SocketsInitialize() Then
        GetIPHostName = ""
        Exit Function
    End If

    If gethostname(sHostName, 256) = SOCKET_ERROR Then
        GetIPHostName = ""
        MsgBox "Windows Sockets error " & str$(WSAGetLastError()) & _
                " has occurred.  Unable to successfully get Host Name."
        SocketsCleanup
        Exit Function
    End If

    GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
    SocketsCleanup

End Function

Public Function HiByte(ByVal wParam As Integer) As Byte

  'note: VB4-32 users should declare this function As Integer
   HiByte = (wParam And &HFF00&) \ (&H100)

End Function

Public Function LoByte(ByVal wParam As Integer) As Byte

  'note: VB4-32 users should declare this function As Integer
   LoByte = wParam And &HFF&

End Function

Public Sub SocketsCleanup()

    If WSACleanup() <> ERROR_SUCCESS Then
        MsgBox "Socket error occurred in Cleanup."
    End If

End Sub

Public Function SocketsInitialize() As Boolean

   Dim WSAD As WSADATA
   Dim sLoByte As String
   Dim sHiByte As String
   MAX_WSADescription = 256
   MAX_WSASYSStatus = 128
   ERROR_SUCCESS = 0
   WS_VERSION_REQD = &H101
   WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
   WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
   MIN_SOCKETS_REQD = 1
   SOCKET_ERROR = -1
   If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
      MsgBox "The 32-bit Windows Socket is not responding."
      SocketsInitialize = False
      Exit Function
   End If


   If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
        MsgBox "This application requires a minimum of " & _
                CStr(MIN_SOCKETS_REQD) & " supported sockets."

        SocketsInitialize = False
        Exit Function
    End If


   If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
     (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
      HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then

      sHiByte = CStr(HiByte(WSAD.wVersion))
      sLoByte = CStr(LoByte(WSAD.wVersion))

      MsgBox "Sockets version " & sLoByte & "." & sHiByte & _
             " is not supported by 32-bit Windows Sockets."

      SocketsInitialize = False
      Exit Function

   End If

   SocketsInitialize = True

End Function

您需要登录后才可以回帖 登录 | 注册

本版积分规则

QQ|手机版|小黑屋|ELEOK |网站地图

GMT+8, 2024-12-27 11:24

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表