最近写了个小东西,就是利用API类似PING的把得到的数值放到ACCESS中,可是程序运行中,XP点关机居然没效果,下面是声明的API,里面有些热键之类的
Option ExplicitDeclare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long
Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long'Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Declare Function SetWindowPos& Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)

解决方案 »

  1.   

    Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
    Public Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
    Public Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Integer, ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal Timeout As Long) As Long
    Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
    Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
    Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
    Public Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
    Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
    Public Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)这是PING方面的
      

  2.   

    'PING的模块
    Option ExplicitPublic Const IP_STATUS_BASE = 11000
    Public Const IP_SUCCESS = 0
    Public Const IP_BUF_TOO_SMALL = (11000 + 1)
    Public Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
    Public Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
    Public Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
    Public Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
    Public Const IP_NO_RESOURCES = (11000 + 6)
    Public Const IP_BAD_OPTION = (11000 + 7)
    Public Const IP_HW_ERROR = (11000 + 8)
    Public Const IP_PACKET_TOO_BIG = (11000 + 9)
    Public Const IP_REQ_TIMED_OUT = (11000 + 10)
    Public Const IP_BAD_REQ = (11000 + 11)
    Public Const IP_BAD_ROUTE = (11000 + 12)
    Public Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
    Public Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
    Public Const IP_PARAM_PROBLEM = (11000 + 15)
    Public Const IP_SOURCE_QUENCH = (11000 + 16)
    Public Const IP_OPTION_TOO_BIG = (11000 + 17)
    Public Const IP_BAD_DESTINATION = (11000 + 18)
    Public Const IP_ADDR_DELETED = (11000 + 19)
    Public Const IP_SPEC_MTU_CHANGE = (11000 + 20)
    Public Const IP_MTU_CHANGE = (11000 + 21)
    Public Const IP_UNLOAD = (11000 + 22)
    Public Const IP_ADDR_ADDED = (11000 + 23)
    Public Const IP_GENERAL_FAILURE = (11000 + 50)
    Public Const MAX_IP_STATUS = 11000 + 50
    Public Const IP_PENDING = (11000 + 255)
    Public Const PING_TIMEOUT = 200
    Public Const WS_VERSION_REQD = &H101
    Public Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
    Public Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
    Public Const MIN_SOCKETS_REQD = 1
    Public Const SOCKET_ERROR = -1Public Const MAX_WSADescription = 256
    Public Const MAX_WSASYSStatus = 128Public Type ICMP_OPTIONS
        Ttl             As Byte
        Tos             As Byte
        Flags           As Byte
        OptionsSize     As Byte
        OptionsData     As Long
    End TypeDim ICMPOPT As ICMP_OPTIONSPublic Type ICMP_ECHO_REPLY
        Address         As Long
        status          As Long
        RoundTripTime   As Long
        DataSize        As Integer
        Reserved        As Integer
        DataPointer     As Long
        Options         As ICMP_OPTIONS
        Data            As String * 250
    End TypePublic Type HOSTENT
        hName As Long
        hAliases As Long
        hAddrType As Integer
        hLen As Integer
        hAddrList As Long
    End TypePublic Type WSADATA
        wVersion As Integer
        wHighVersion As Integer
        szDescription(0 To MAX_WSADescription) As Byte
        szSystemStatus(0 To MAX_WSASYSStatus) As Byte
        wMaxSockets As Integer
        wMaxUDPDG As Integer
        dwVendorInfo As Long
    End TypePublic Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
    Public Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
    Public Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Integer, ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal Timeout As Long) As Long
    Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
    Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
    Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
    Public Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
    Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
    Public Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)Public Function GetStatusCode(status As Long) As String
       Dim Msg As String   Select Case status
          Case IP_SUCCESS:               Msg = sysset.yesValuse                                                      '"ip success"
          Case IP_BUF_TOO_SMALL:         Msg = "ip buf too_small"
          Case IP_DEST_NET_UNREACHABLE:  Msg = "ip dest net unreachable"
          Case IP_DEST_HOST_UNREACHABLE: Msg = "ip dest host unreachable"
          Case IP_DEST_PROT_UNREACHABLE: Msg = "ip dest prot unreachable"
          Case IP_DEST_PORT_UNREACHABLE: Msg = "ip dest port unreachable"
          Case IP_NO_RESOURCES:          Msg = "ip no resources"
          Case IP_BAD_OPTION:            Msg = "ip bad option"
          Case IP_HW_ERROR:              Msg = "ip hw_error"
          Case IP_PACKET_TOO_BIG:        Msg = "ip packet too_big"
          Case IP_REQ_TIMED_OUT:         Msg = sysset.noValuse                                                       '"ip req timed out"
          Case IP_BAD_REQ:               Msg = "ip bad req"
          Case IP_BAD_ROUTE:             Msg = "ip bad route"
          Case IP_TTL_EXPIRED_TRANSIT:   Msg = "ip ttl expired transit"
          Case IP_TTL_EXPIRED_REASSEM:   Msg = "ip ttl expired reassem"
          Case IP_PARAM_PROBLEM:         Msg = "ip param_problem"
          Case IP_SOURCE_QUENCH:         Msg = "ip source quench"
          Case IP_OPTION_TOO_BIG:        Msg = "ip option too_big"
          Case IP_BAD_DESTINATION:       Msg = "错误的IP地址"                                                       '"ip bad destination"
          Case IP_ADDR_DELETED:          Msg = "ip addr deleted"
          Case IP_SPEC_MTU_CHANGE:       Msg = "ip spec mtu change"
          Case IP_MTU_CHANGE:            Msg = "ip mtu_change"
          Case IP_UNLOAD:                Msg = "ip unload"
          Case IP_ADDR_ADDED:            Msg = "ip addr added"
          Case IP_GENERAL_FAILURE:       Msg = "ip general failure"
          Case IP_PENDING:               Msg = "ip pending"
          Case PING_TIMEOUT:             Msg = "ping timeout"
          Case Else:                     Msg = "unknown  msg returned"
       End Select
       
    '   GetStatusCode = CStr(status) & "   [ " & msg & " ]"
        GetStatusCode = Msg
    End FunctionPublic Function HiByte(ByVal wParam As Integer)
        HiByte = wParam \ &H100 And &HFF&
    End FunctionPublic Function LoByte(ByVal wParam As Integer)
        LoByte = wParam And &HFF&
    End Function
      

  3.   


    Public Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY) As Long
       Dim hPort As Long
       Dim dwAddress As Long
       Dim sDataToSend As String
       Dim iOpt As Long
       
       sDataToSend = "My Request"
       dwAddress = AddressStringToLong(szAddress)
       
       Call SocketsInitialize
       hPort = IcmpCreateFile()
       
       If IcmpSendEcho(hPort, _
                       dwAddress, _
                       sDataToSend, _
                       Len(sDataToSend), _
                       0, _
                       ECHO, _
                       Len(ECHO), _
                       PING_TIMEOUT) Then
            'Ping如果成功
            '.Status返回0
            '.RoundTripTime是Ping完成的时间,单位为Ms
            '.Data是返回的数据
            '.Address是接受响应的Ip地址
            '.DataSize是接受数据.Data的大小
             Ping = ECHO.RoundTripTime
       Else: Ping = ECHO.status * -1
       End If
                           
       Call IcmpCloseHandle(hPort)
       Call SocketsCleanup
       
    End Function
       
    Function AddressStringToLong(ByVal tmp As String) As Long
       'IP地址16进制转换
       Dim i As Integer
       Dim parts(1 To 4) As String
       
       i = 0
       
       While InStr(tmp, ".") > 0
          i = i + 1
          parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1)
          tmp = Mid(tmp, InStr(tmp, ".") + 1)
       Wend
       
       i = i + 1
       parts(i) = tmp
       
       If i <> 4 Then
          AddressStringToLong = 0
          Exit Function
       End If
       
       AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _
                             Right("00" & Hex(parts(3)), 2) & _
                             Right("00" & Hex(parts(2)), 2) & _
                             Right("00" & Hex(parts(1)), 2))
       
    End FunctionPublic Function SocketsCleanup() As Boolean    Dim x As Long
        
        x = WSACleanup()
        If x <> 0 Then
            MsgBox "Windows Sockets error " & Trim$(str$(x)) & _
                   " occurred in Cleanup.", vbExclamation
            SocketsCleanup = False
        Else
            SocketsCleanup = True
        End If
    End FunctionPublic Function SocketsInitialize() As Boolean    Dim WSAD As WSADATA
        Dim x As Integer
        Dim szLoByte As String, szHiByte As String, szBuf As String
        
        x = WSAStartup(WS_VERSION_REQD, WSAD)
        
        If x <> 0 Then
            MsgBox "Windows Sockets for 32 bit Windows " & _
                   "environments is not successfully responding."
            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
            
            szHiByte = Trim$(str$(HiByte(WSAD.wVersion)))
            szLoByte = Trim$(str$(LoByte(WSAD.wVersion)))
            szBuf = "Windows Sockets Version " & szLoByte & "." & szHiByte
            szBuf = szBuf & " is not supported by Windows " & _
                              "Sockets for 32 bit Windows environments."
            MsgBox szBuf, vbExclamation
            SocketsInitialize = False
            Exit Function
            
        End If
        
        If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
            szBuf = "This application requires a minimum of " & _
                     Trim$(str$(MIN_SOCKETS_REQD)) & " supported sockets."
            MsgBox szBuf, vbExclamation
            SocketsInitialize = False
            Exit Function
        End If
        
        SocketsInitialize = True
    End Function
      

  4.   

    肯定是调用API函数出错了,也不太好跟踪
      

  5.   

    代码太长没耐心看完,不过我想加杀大法应该能解决你的问题啊
    你取消热键部分看看,如果不行再取消拦截窗口消息函数看看,总能发现问题
    如果是拦截窗口消息的,那可能是没有处理windows关机消息:这个网上有很多参考
      

  6.   

    给你关机消息的拦截:-------------------------------载录---------------------------
    关机消息的拦截   在关机或Logff前信息的拦截  如果我们关机或Logoff时,我们的程序有时会因而无法按正常程序结束,一般我们会在Form的Unload中一段程序结束时要做什么事,但是,如果使用者直接用开始功能菜单的关机,会使UnLoad的部份没有做到,我们现在就想办法来拦截关机(或Logoff)时的信息。  一般来说,关机或Logff后,Windows会传依序送出WM_QUERYENDSESSION的信息给每个Process,如果中间有一个Process不能顺利结束(例如:Word修改后未存档,而出现是否存档,但我们按取消),这时该信息执行的结果会传回False(0),这时Windows也就不再继续送WM_QUERYENDSESSION给下一个Proccess。反之,如果所有的Process都可以顺利结束(也就是每个送出的WM_QUERYENDSESSION都传回True),那才代表以以顺利结束。  不管WM_QUERYENDSESSION最后的结果是可以顺利结束或不能顺利结束,Windows会再送一个WM_ENDSESSION的信息给所有的Process,而wParam的内容便是指出是否可以顺利结束(True菜单可以,False菜单不行,在vb中则CheckwParam = 0 菜单False ,0菜单True),说到这里大概就知道该如何做啦,程序如下:
       
    ’以下在Form
    Private Sub Form_Load()
     Dim ret As Long ’记录原来的Window Procedure的位址
     preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
     ’设定form的window Procedure到wndproc
     ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf wndproc)
    End Sub
       
    Private Sub Form_Unload(Cancel As Integer)
     Dim ret As Long
     Dim fno As Long ’取消Message的截取,而使之又只送往原来的Window Procedure
     ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc) ’这里只是要看看用关机的方式结束程序时,会不会执行到这里
     fno = FreeFile
     Open "c:\tt2" For Append As fno
     Print #fno, "ccc" + vbCrLf
     Close #fno
    End Sub
       
    ’以下在.Bas
    Option Explicit
       
    Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
       
    Public Const GWL_WNDPROC = (-4)
    Public Const WM_ENDSESSION = &H16
    Public Const WM_QUERYENDSESSION = &H11
       
    Public preWinProc As Long
       
    Public Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
     If Msg = WM_QUERYENDSESSION Then
       Debug.Print "QryEnd", wParam, lParam
     Else
      If Msg = WM_ENDSESSION Then
       If wParam 0 Then ’代表将顺利关机或LogOff,这时便得做正常结束程序的操作
         Dim fno As Long
         Open "c:\ttt" For Output As #1
         Print #1, "hahcccc5"
         Close #1
       End If
      End If
     End If ’将之送往原来的Window Procedure
     wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
    End Function  
      

  7.   

    ping代码没看出什么问题,而且,以前我在网上也看过几乎类似的代码
    只是不知你是如何调用 的?是不是循环或用timer控件,连续调用引起的