久久久久久久999_99精品久久精品一区二区爱城_成人欧美一区二区三区在线播放_国产精品日本一区二区不卡视频_国产午夜视频_欧美精品在线观看免费

標題: VBA腳本獲取計算機IP [打印本頁]

作者: solszl2 時間: 2020-4-1 15:09
標題: VBA腳本獲取計算機IP
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

歡迎光臨 (http://www.zg4o1577.cn/bbs/)