ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1097|回复: 5

[求助] 一个检测IP的32位VBA,在64位的office下以及WPS下无法执行,怎么修改

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-12-10 16:15 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
一个检测IP的32位VBA,在64位的office下以及WPS下无法执行,怎么修改。WPS 的VBA是6.0版本的
要怎么修改成,让他在32位、64位、以及WPS VBA 6.0、7.0都可以执行的代码。
请大神们显灵,帮帮修改一下;


  1. Option Explicit

  2. Private Const IP_SUCCESS As Long = 0
  3. Private Const IP_STATUS_BASE As Long = 11000
  4. Private Const IP_BUF_TOO_SMALL As Long = (11000 + 1)
  5. Private Const IP_DEST_NET_UNREACHABLE As Long = (11000 + 2)
  6. Private Const IP_DEST_HOST_UNREACHABLE As Long = (11000 + 3)
  7. Private Const IP_DEST_PROT_UNREACHABLE As Long = (11000 + 4)
  8. Private Const IP_DEST_PORT_UNREACHABLE As Long = (11000 + 5)
  9. Private Const IP_NO_RESOURCES As Long = (11000 + 6)
  10. Private Const IP_BAD_OPTION As Long = (11000 + 7)
  11. Private Const IP_HW_ERROR As Long = (11000 + 8)
  12. Private Const IP_PACKET_TOO_BIG As Long = (11000 + 9)
  13. Private Const IP_REQ_TIMED_OUT As Long = (11000 + 10)
  14. Private Const IP_BAD_REQ As Long = (11000 + 11)
  15. Private Const IP_BAD_ROUTE As Long = (11000 + 12)
  16. Private Const IP_TTL_EXPIRED_TRANSIT As Long = (11000 + 13)
  17. Private Const IP_TTL_EXPIRED_REASSEM As Long = (11000 + 14)
  18. Private Const IP_PARAM_PROBLEM As Long = (11000 + 15)
  19. Private Const IP_SOURCE_QUENCH As Long = (11000 + 16)
  20. Private Const IP_OPTION_TOO_BIG As Long = (11000 + 17)
  21. Private Const IP_BAD_DESTINATION As Long = (11000 + 18)
  22. Private Const IP_ADDR_DELETED As Long = (11000 + 19)
  23. Private Const IP_SPEC_MTU_CHANGE As Long = (11000 + 20)
  24. Private Const IP_MTU_CHANGE As Long = (11000 + 21)
  25. Private Const IP_UNLOAD As Long = (11000 + 22)
  26. Private Const IP_ADDR_ADDED As Long = (11000 + 23)
  27. Private Const IP_GENERAL_FAILURE As Long = (11000 + 50)
  28. Private Const MAX_IP_STATUS As Long = (11000 + 50)
  29. Private Const IP_PENDING As Long = (11000 + 255)
  30. Private Const PING_TIMEOUT As Long = 500
  31. Private Const WS_VERSION_REQD As Long = &H101
  32. Private Const MIN_SOCKETS_REQD As Long = 1
  33. Private Const SOCKET_ERROR As Long = -1
  34. Private Const INADDR_NONE As Long = &HFFFFFFFF
  35. Private Const MAX_WSADescription As Long = 256
  36. Private Const MAX_WSASYSStatus As Long = 128

  37. Public PingTime As Long
  38. Private Type ICMP_OPTIONS
  39.     Ttl             As Byte
  40.     Tos             As Byte
  41.     Flags           As Byte
  42.     OptionsSize     As Byte
  43.     OptionsData     As Long
  44. End Type

  45. Private Type ICMP_ECHO_REPLY
  46.     Address         As Long
  47.     status          As Long
  48.     RoundTripTime   As Long
  49.     DataSize        As Long
  50.     DataPointer     As Long
  51.     Options         As ICMP_OPTIONS
  52.     Data            As String * 250
  53. End Type

  54. Private Type WSADATA
  55.    wVersion As Integer
  56.    wHighVersion As Integer
  57.    szDescription(0 To MAX_WSADescription) As Byte
  58.    szSystemStatus(0 To MAX_WSASYSStatus) As Byte
  59.    wMaxSockets As Long
  60.    wMaxUDPDG As Long
  61.    dwVendorInfo As Long
  62. End Type

  63. Public Declare Function timeGetTime Lib "winmm.dll" () As Long
  64. Private Declare Function WSAStartup Lib "wsock32" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
  65. Private Declare Function WSACleanup Lib "wsock32" () As Long
  66. Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
  67. Private Declare Function inet_addr Lib "wsock32" (ByVal s As String) As Long
  68. Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
  69. Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Long, ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal Timeout As Long) As Long
  70. 'Private Declare Function WSAGetLastError Lib "wsock32" () As Long
  71. 'Private Declare Function gethostname Lib "wsock32" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
  72. 'Private Declare Function gethostbyname Lib "wsock32" (ByVal szHost As String) As Long
  73. 'Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (xDest As Any, xSource As Any, ByVal nbytes As Long)
  74.    
  75. Private Function GetStatusCode(status As Long) As String
  76.    On Error GoTo ErrLine
  77.    Dim Msg As String
  78.    GetStatusCode = ""
  79.    Select Case status
  80.             Case IP_SUCCESS:               Msg = "ip success"
  81.             Case INADDR_NONE:              Msg = "inet_addr: bad IP format"
  82.             Case IP_BUF_TOO_SMALL:         Msg = "ip buf too_small"
  83.             Case IP_DEST_NET_UNREACHABLE:  Msg = "ip dest net unreachable"
  84.             Case IP_DEST_HOST_UNREACHABLE: Msg = "ip dest host unreachable"
  85.             Case IP_DEST_PROT_UNREACHABLE: Msg = "ip dest port unreachable"
  86.             Case IP_DEST_PORT_UNREACHABLE: Msg = "ip dest port unreachable"
  87.             Case IP_NO_RESOURCES:          Msg = "ip no resources"
  88.             Case IP_BAD_OPTION:            Msg = "ip bad option"
  89.             Case IP_HW_ERROR:              Msg = "ip hw_error"
  90.             Case IP_PACKET_TOO_BIG:        Msg = "ip packet too_big"
  91.             Case IP_REQ_TIMED_OUT:         Msg = "ip req timed out"
  92.             Case IP_BAD_REQ:               Msg = "ip bad req"
  93.             Case IP_BAD_ROUTE:             Msg = "ip bad route"
  94.             Case IP_TTL_EXPIRED_TRANSIT:   Msg = "ip ttl expired transit"
  95.             Case IP_TTL_EXPIRED_REASSEM:   Msg = "ip ttl expired reassem"
  96.             Case IP_PARAM_PROBLEM:         Msg = "ip param_problem"
  97.             Case IP_SOURCE_QUENCH:         Msg = "ip source quench"
  98.             Case IP_OPTION_TOO_BIG:        Msg = "ip option too_big"
  99.             Case IP_BAD_DESTINATION:       Msg = "ip bad destination"
  100.             Case IP_ADDR_DELETED:          Msg = "ip addr deleted"
  101.             Case IP_SPEC_MTU_CHANGE:       Msg = "ip spec mtu change"
  102.             Case IP_MTU_CHANGE:            Msg = "ip mtu_change"
  103.             Case IP_UNLOAD:                Msg = "ip unload"
  104.             Case IP_ADDR_ADDED:            Msg = "ip addr added"
  105.             Case IP_GENERAL_FAILURE:       Msg = "ip general failure"
  106.             Case IP_PENDING:               Msg = "ip pending"
  107.             Case PING_TIMEOUT:             Msg = "ping timeout"
  108.             Case Else:                     Msg = "unknown msg returned"
  109.    End Select
  110.    GetStatusCode = Msg
  111.    Exit Function
  112. ErrLine:
  113. End Function

  114. Private Function Ping(sAddress As String, sDataToSend As String, ECHO As ICMP_ECHO_REPLY) As Long
  115.    On Error GoTo ErrLine
  116.    Dim hPort As Long
  117.    Dim dwAddress As Long
  118.    dwAddress = inet_addr(sAddress)
  119.    If dwAddress <> INADDR_NONE Then
  120.       hPort = IcmpCreateFile()
  121.       If hPort Then
  122.          Call IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, ECHO, Len(ECHO), PING_TIMEOUT)
  123.          Ping = ECHO.status
  124.          Call IcmpCloseHandle(hPort)
  125.       End If
  126.    Else
  127.       Ping = INADDR_NONE
  128.    End If
  129.    Exit Function
  130. ErrLine:
  131.    Ping = INADDR_NONE
  132. End Function

  133. Public Function PingIP(ByVal szIp As String) As Boolean
  134. On Error GoTo ErrLine
  135. Dim WSAD As WSADATA
  136. Dim ECHO As ICMP_ECHO_REPLY
  137. Dim ret As Long
  138. 'Delay 150
  139. PingIP = False
  140. PingTime = Empty
  141. If WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS Then
  142.    ret = Ping(Trim(szIp), "tanaya", ECHO)
  143.    PingTime = ECHO.RoundTripTime
  144.    If InStr(1, GetStatusCode(ret), "success") <> 0 Then
  145.       WSACleanup
  146.       PingIP = True
  147.       PingTime = ECHO.RoundTripTime
  148.       Exit Function
  149.     End If
  150. End If
  151. Exit Function
  152. ErrLine:
  153. End Function

  154. '通过API检查IP是否通达,不支持域名解析。
  155. Public Sub NetCheck()
  156.     '根据工作表中的查询语句读取数据
  157.     Dim Ip, Stat, a As String
  158.     Dim i, k, kk, lineno, b As Long
  159.    
  160.     'On Error Resume Next
  161.     lineno = [F65536].End(xlUp).Row      '行数
  162.    
  163.     kk = 0
  164.     b = 0
  165.     For i = 2 To lineno
  166.         Stat = Cells(i, 7)
  167.         If UCase(Stat) = "Y" Then
  168.             kk = kk + 1
  169.             Ip = Cells(i, 6)
  170.             If Ip = "" Then Exit For
  171.             If PingIP(Ip) Then
  172.                 Cells(i, 7) = "OK"
  173.                 Cells(i, 7).Interior.Color = RGB(0, 255, 0)
  174.             Else
  175.                 b = b + 1
  176.                 Cells(i, 7) = "NO"
  177.                 Cells(i, 7).Interior.Color = RGB(255, 0, 0)
  178.             End If
  179.         End If
  180.     Next i
  181.     a = (b / kk * 100) & "%"
  182.     Stat = MsgBox("共查询" & kk & "个IP,有" & b & "个失败,失败率" & a & ".", vbOKOnly, "检测结果")
  183.    
  184.    
  185.    
  186.    
  187.    

  188. End Sub
复制代码
原文件(VBA 密码是odin)

VBA_IP批量检查.zip

33.51 KB, 下载次数: 10

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-10 17:47 | 显示全部楼层
求大神,快快显灵

TA的精华主题

TA的得分主题

发表于 2019-12-10 18:51 | 显示全部楼层
Public Declare Function  改成 Public Declare Ptrsafe Function 试试

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-10 21:08 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-12-11 08:26 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
Option Explicit

#If Win64 Then
    Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
#Else
    Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
        Alias "GetOpenFileNameA" _
        (pOpenfilename As OPENFILENAME) As Long
    Private Declare Function GetSaveFileName Lib "comdlg32.dll" _
        Alias "GetSaveFileNameA" ( _
        pOpenfilename As OPENFILENAME) As Long
#End If

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-11 14:45 | 显示全部楼层
wxhnr 发表于 2019-12-11 08:26
Option Explicit

#If Win64 Then

这个句子是加在哪时啊?另外VBA6和VBA7是不是不一样啊?
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 14:06 , Processed in 0.060844 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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