PING automatic and result change the color of object

Started by Adrien.vdb, December 20, 2013, 09:43:59 AM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

Adrien.vdb

Hello !

I'm sorry for my bad English, I'm French. I don't find help in French forum :/

I explain my problem, my boss want i create an automatically ping in visio 2010, i have the macro in VBA but it's for visio  2007. I'm a loser in VBA...

Thank you in advance for your help!

The source code:

Const SOCKET_ERROR = 0

Private Type WSAdata
wVersion As Integer
wHighVersion As Integer
szDescription(0 To 255) As Byte
szSystemStatus(0 To 128) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type

Private Type Hostent
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type

Private Type IP_OPTION_INFORMATION
TTL As Byte
Tos As Byte
Flags As Byte
OptionsSize As Long
OptionsData As String * 128
End Type

Private Type IP_ECHO_REPLY
Address(0 To 3) As Byte
Status As Long
RoundTripTime As Long
DataSize As Integer
Reserved As Integer
data As Long
Options As IP_OPTION_INFORMATION
End Type

Private Declare Function GetHostByName Lib _
"wsock32.dll" Alias "gethostbyname" _
(ByVal HostName As String) As Long

Private Declare Function WSAStartup Lib _
"wsock32.dll" (ByVal wVersionRequired&, _
lpWSAdata As WSAdata) As Long

Private Declare Function WSACleanup Lib "wsock32.dll" _
() As Long

Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, _
ByVal cbCopy As Long)

Private Declare Function IcmpCreateFile Lib "icmp.dll" _
() As Long

Private Declare Function IcmpCloseHandle Lib "icmp.dll" _
(ByVal HANDLE As Long) As Boolean

Private Declare Function IcmpSendEcho Lib "ICMP" _
(ByVal IcmpHandle As Long, ByVal DestAddress As Long, _
ByVal RequestData As String, _
ByVal RequestSize As Integer, RequestOptns As _
IP_OPTION_INFORMATION, ReplyBuffer As IP_ECHO_REPLY, _
ByVal ReplySize As Long, ByVal TimeOut As Long) As Boolean


Function IP_connect(HostName)

'Dim HostName

'HostName = ActiveCell.Value

Dim hFile As Long, lpWSAdata As WSAdata
Dim hHostent As Hostent, AddrList As Long
Dim Address As Long, rIP As String
Dim OptInfo As IP_OPTION_INFORMATION
Dim EchoReply As IP_ECHO_REPLY

Call WSAStartup(&H101, lpWSAdata)

If GetHostByName(HostName + _
String(64 - Len(HostName), 0)) _
<> SOCKET_ERROR Then

CopyMemory hHostent.h_name, _
ByVal GetHostByName(HostName + _
String(64 - Len(HostName) _
, 0)), Len(hHostent)

CopyMemory AddrList, ByVal hHostent.h_addr_list, 4

CopyMemory Address, ByVal AddrList, 4

End If

hFile = IcmpCreateFile()

If hFile = 0 Then

'MsgBox "Unable to Create File Handle"
IP_connect = "Unable to Create File Handle"
Exit Function

End If

OptInfo.TTL = 255

If IcmpSendEcho(hFile, Address, _
String(32, "A"), 32, OptInfo, EchoReply, _
Len(EchoReply) + 8, 2000) Then

rIP = CStr(EchoReply.Address(0)) + _
"." + CStr(EchoReply.Address(1)) + "." + _
CStr(EchoReply.Address(2)) + "." + _
CStr(EchoReply.Address(3))

Else

'MsgBox "Timeout"
IP_connect = "Timeout"
End If

If EchoReply.Status = 0 Then

'MsgBox "Reply from " + HostName + " (" + rIP _
+ ") recieved after " + _
Trim$(CStr(EchoReply.RoundTripTime)) + "ms"


IP_connect = "Reply from " + HostName + " (" + rIP _
+ ") recieved after " + _
Trim$(CStr(EchoReply.RoundTripTime)) + "ms"



Else

'MsgBox "Failure ..."
IP_connect = "Failure"
End If

Call IcmpCloseHandle(hFile)

Call WSACleanup

End Function

Sub ping()


    Dim co As Integer

    introw = 4
    co = 4

    Do While co < 9
        Do Until Cells(introw, co).Value = ""

            Message = IP_connect(Cells(introw, co).Value)
            Cells(introw, co).Select

                     If Message = "Failure" Then


                             With ActiveCell.Font
                             .Color = RGB(255, 0, 0)
                             End With
                                With ActiveWorkbook
                                If co < 8 Then
                                aff = co + 1
                                Else
                                aff = co
                                End If
                                .SendMail Recipients:=Array("pascal.vilain@efs.sante.fr"), Subject:="pb sur " & Cells(introw, aff).Value
                                '.Close SaveChanges:=False
                                End With


                        Else
                            With ActiveCell.Font
                            .Color = RGB(0, 0, 0)
                            End With

                    End If
         introw = introw + 2
          Loop
     co = co + 2
     introw = 4
    Loop



End Sub

Surrogate

#1
i think no difference between code for visio2007 and visio2010.

but in subroutine Ping, i find this
Do Until Cells(introw, co).Value = ""
' ... some code
With ActiveWorkbook

i think this is code for excel, not for visio !

Adrien.vdb

Hum thanks you, but what is the code for visio please ?

Adrien.vdb

ok i understand, visio have'nt colum and line.. but i integre excel in visio and create relation objet / excel

Surrogate

excel table contains list of ip-addresses, which iterated in loop.
if some IP get IP_connect is failure, this font in this cell make red and send message to Pascal

i haven't real ip-table for checking :(

Adrien.vdb

the code is ok in excel no problem, but the problem is How to bind an object on visio with a excel table ?

aledlund

add an ipaddress field to the shape and the datalink the table to the drawing. you can use shapedata (color by value) to handle the status change (assumes your table has a discrete column for status).
al