VERIFICAR SE ESTA CONECTADO NA NET
Preciso desenvolver uma aplicação que verfica se a pessoa esta conectado na internet e me enviar o ip dela, para saber o ip ja achei um exemplo, mas como verfificar se ela esta logado? E como me enviar um e-mail com o ip dela? Pois estou tentando trabalhar com acesso remoto e preciso do ip da pessoa, para que eu possa conectar
Quanto ao saber se está conectado, tente esse código
Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32
Public Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Public Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Public Function IsModemConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
If RetVal <> 0 Then
MsgBox "ERROR"
Exit Function
End If
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
If Tstatus.RasConnState = &H2000 Then
IsModemConnected = True
Else
IsModemConnected = False
End If
End Function
Quanto enviar um e-mail..
Option Explicit
Type MAPIMessage
Reserved As Long
Subject As String
NoteText As String
MessageType As String
DateReceived As String
ConversationID As String
Flags As Long
RecipCount As Long
FileCount As Long
End Type
Type MapiRecip
Reserved As Long
RecipClass As Long
Name As String
Address As String
EIDSize As Long
EntryID As String
End Type
Type MapiFile
Reserved As Long
Flags As Long
Position As Long
PathName As String
FileName As String
FileType As String
End Type
'*********************************************************************************
'Altere aqui o caminho da dll MSOE.DLL de acordo com o seu micro
'*********************************************************************************
Declare Function MAPISendMail Lib "C:\Arquivos de programas\Outlook Express\Msoe.dll" _
Alias "BMAPISendMail" _
(ByVal Session&, ByVal UIParam&, Message As MAPIMessage, _
Recipient() As MapiRecip, File() As MapiFile, ByVal Flags&, _
ByVal Reserved&) As Long
Global Const SUCCESS_SUCCESS = 0
Global Const MAPI_TO = 1
Global Const MAPI_CC = 2
Global Const MAPI_CCO = 3
Global Const MAPI_LOGON_UI = &H1
Function CountTokens(ByVal sSource As String, ByVal sDelim As String)
Dim iDelimPos As Integer
Dim iCount As Integer
If sSource = "" Then
CountTokens = 0
Else
iDelimPos = InStr(1, sSource, sDelim)
Do Until iDelimPos = 0
iCount = iCount + 1
iDelimPos = InStr(iDelimPos + 1, sSource, sDelim)
Loop
CountTokens = iCount + IIf(Right(sSource, 1) = sDelim, 0, 1)
End If
End Function
Function GetToken(sSource As String, ByVal sDelim As String) As String
Dim iDelimPos As Integer
' Busca el primer delimitador
iDelimPos = InStr(1, sSource, sDelim)
If (iDelimPos = 0) Then
GetToken = Trim$(sSource)
sSource = ""
Else
GetToken = Trim$(Left$(sSource, iDelimPos - 1))
sSource = Mid$(sSource, iDelimPos + 1)
End If
End Function
Sub ParseTokens(mArray() As String, ByVal sTokens As String, ByVal sDelim As String)
Dim i As Integer
For i = LBound(mArray) To UBound(mArray)
mArray(i) = GetToken(sTokens, sDelim)
Next
End Sub
' PARAMETROS:
' sSubject: Es texto que aparecerá como Asunto del mensaje
' sTo: Lista delimitada por ";" com os destinatários da mensagem.
' sCC: Lista dos destinatários CC (Copia)
' sCCO: Lista dos destinatários CCO (Copia oculta)
' sAttach: Lista dos anexos a enviar
Function SendMail(sSubject As String, sTo As String, sCC As String, sCCO As String, _
sAttach As String, sMessage As String)
On Error GoTo Err_CapturarError
Dim i, cTo, cCC, cCCO, cAttach ' contadores de items
Dim MAPI_Message As MAPIMessage
' Contar el número de items en cada lista
cTo = CountTokens(sTo, ";")
cCC = CountTokens(sCC, ";")
cCCO = CountTokens(sCCO, ";")
cAttach = CountTokens(sAttach, ";")
' Dimensionar las matrices para las listas
ReDim rTo(0 To cTo) As String
ReDim rCC(0 To cCC) As String
ReDim rCCO(0 To cCCO) As String
ReDim rAttach(0 To cAttach) As String
' Pasar el contenido de las listas a las matrices
ParseTokens rTo(), sTo, ";"
ParseTokens rCC(), sCC, ";"
ParseTokens rCCO(), sCCO, ";"
ParseTokens rAttach(), sAttach, ";"
' Crear la estructura MAPI Recip para almacenar todos los destinatarios
ReDim MAPI_Recip(0 To cTo + cCC + cCCO - 1) As MapiRecip
' Cargar los "TO:" en la estructura
For i = 0 To cTo - 1
MAPI_Recip(i).Name = rTo(i)
MAPI_Recip(i).RecipClass = MAPI_TO
Next i
' Cargar los "CC:"
For i = 0 To cCC - 1
MAPI_Recip(cTo + i).Name = rCC(i)
MAPI_Recip(cTo + i).RecipClass = MAPI_CC
Next i
' Cargar los "CCO:"
For i = 0 To cCCO - 1
MAPI_Recip(cTo + cCC + i).Name = rCCO(i)
MAPI_Recip(cTo + cCC + i).RecipClass = MAPI_CCO
Next i
' Crear la estructura MAPI_File para los adjuntos
ReDim MAPI_File(0 To cAttach) As MapiFile
' Cargar los adjuntos en la estructura
MAPI_Message.FileCount = cAttach
For i = 0 To cAttach - 1
MAPI_File(i).Position = -1
MAPI_File(i).PathName = rAttach(i)
Next i
' Llenar los campos del mensaje
MAPI_Message.Subject = sSubject
MAPI_Message.NoteText = sMessage
MAPI_Message.RecipCount = cTo + cCC + cCCO
' Enviar el mensaje
SendMail = MAPISendMail(0&, 0&, MAPI_Message, MAPI_Recip(), _
MAPI_File(), MAPI_LOGON_UI, 0&)
Salida:
Exit Function
Err_CapturarError:
Select Case Err.Number
Case 48
'Error: No se encontró el archivo: C:\Archivos de programa\ _
Outlook Express\Msoe.dll
SendMail = 48
Case 453
'Error: Imposible encontra el punto de entrada de DLL BMAPISendMail en _
MAPI32X.DLL
'Asignar el número de error. El filtro y el mensaje más adelante.
SendMail = 453
Case Else
'Cazar todos aquellos errores inesperados.
MsgBox Err.Number & " " & Err.Description
End Select
Resume Salida 'Salida a otro procedimiento.
End Function
No Controle Desejado
********************************************************************************************
Dim lngRet As Long
'Envia a mensagem
lngRet = SendMail(("ASSUNTO"), ("destinatario@para"), ("destinatario@comcopia"), ("destinatario@comcopiaoculta"), ("C:\pasta\arquivo.txt"), ("TEXTO DA MENSAGEM"))
'Se ocorrer erro
If lngRet <> SUCCESS_SUCCESS Then
Select Case lngRet
Case 2
MsgBox "Error nº.: " & lngRet & ", ao enviar email." & vbCr & vbCr _
& "Verifique a origem do arquivo anexado. ", vbCritical, "ERRO"
Case 48
MsgBox "Error nº.: " & lngRet & ", ao enviar email." & vbCr & vbCr _
& "Não foi possÃvel carregar MSOE.DLL", 16, "ERRO"
Case 453
MsgBox "Error nº.: " & lngRet & " (de MSAccess), ao enviar email." _
& vbCr & vbCr _
& "MAPI32X.DLL, não é a versão correta.", vbCritical, "ERRO"
Case -2147467259
MsgBox "Error nº.: " & lngRet & ", ao enviar email." & vbCr & vbCr _
& "MAPI32.DLL, não é a versão correta.", vbCritical, "ERRO"
Case Else
MsgBox "Erro ao enviar email: " & lngRet, vbCritical, "ERRO"
End Select
End If
Espero ter ajudado....
T+,
Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32
Public Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Public Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Public Function IsModemConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
If RetVal <> 0 Then
MsgBox "ERROR"
Exit Function
End If
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
If Tstatus.RasConnState = &H2000 Then
IsModemConnected = True
Else
IsModemConnected = False
End If
End Function
Quanto enviar um e-mail..
Option Explicit
Type MAPIMessage
Reserved As Long
Subject As String
NoteText As String
MessageType As String
DateReceived As String
ConversationID As String
Flags As Long
RecipCount As Long
FileCount As Long
End Type
Type MapiRecip
Reserved As Long
RecipClass As Long
Name As String
Address As String
EIDSize As Long
EntryID As String
End Type
Type MapiFile
Reserved As Long
Flags As Long
Position As Long
PathName As String
FileName As String
FileType As String
End Type
'*********************************************************************************
'Altere aqui o caminho da dll MSOE.DLL de acordo com o seu micro
'*********************************************************************************
Declare Function MAPISendMail Lib "C:\Arquivos de programas\Outlook Express\Msoe.dll" _
Alias "BMAPISendMail" _
(ByVal Session&, ByVal UIParam&, Message As MAPIMessage, _
Recipient() As MapiRecip, File() As MapiFile, ByVal Flags&, _
ByVal Reserved&) As Long
Global Const SUCCESS_SUCCESS = 0
Global Const MAPI_TO = 1
Global Const MAPI_CC = 2
Global Const MAPI_CCO = 3
Global Const MAPI_LOGON_UI = &H1
Function CountTokens(ByVal sSource As String, ByVal sDelim As String)
Dim iDelimPos As Integer
Dim iCount As Integer
If sSource = "" Then
CountTokens = 0
Else
iDelimPos = InStr(1, sSource, sDelim)
Do Until iDelimPos = 0
iCount = iCount + 1
iDelimPos = InStr(iDelimPos + 1, sSource, sDelim)
Loop
CountTokens = iCount + IIf(Right(sSource, 1) = sDelim, 0, 1)
End If
End Function
Function GetToken(sSource As String, ByVal sDelim As String) As String
Dim iDelimPos As Integer
' Busca el primer delimitador
iDelimPos = InStr(1, sSource, sDelim)
If (iDelimPos = 0) Then
GetToken = Trim$(sSource)
sSource = ""
Else
GetToken = Trim$(Left$(sSource, iDelimPos - 1))
sSource = Mid$(sSource, iDelimPos + 1)
End If
End Function
Sub ParseTokens(mArray() As String, ByVal sTokens As String, ByVal sDelim As String)
Dim i As Integer
For i = LBound(mArray) To UBound(mArray)
mArray(i) = GetToken(sTokens, sDelim)
Next
End Sub
' PARAMETROS:
' sSubject: Es texto que aparecerá como Asunto del mensaje
' sTo: Lista delimitada por ";" com os destinatários da mensagem.
' sCC: Lista dos destinatários CC (Copia)
' sCCO: Lista dos destinatários CCO (Copia oculta)
' sAttach: Lista dos anexos a enviar
Function SendMail(sSubject As String, sTo As String, sCC As String, sCCO As String, _
sAttach As String, sMessage As String)
On Error GoTo Err_CapturarError
Dim i, cTo, cCC, cCCO, cAttach ' contadores de items
Dim MAPI_Message As MAPIMessage
' Contar el número de items en cada lista
cTo = CountTokens(sTo, ";")
cCC = CountTokens(sCC, ";")
cCCO = CountTokens(sCCO, ";")
cAttach = CountTokens(sAttach, ";")
' Dimensionar las matrices para las listas
ReDim rTo(0 To cTo) As String
ReDim rCC(0 To cCC) As String
ReDim rCCO(0 To cCCO) As String
ReDim rAttach(0 To cAttach) As String
' Pasar el contenido de las listas a las matrices
ParseTokens rTo(), sTo, ";"
ParseTokens rCC(), sCC, ";"
ParseTokens rCCO(), sCCO, ";"
ParseTokens rAttach(), sAttach, ";"
' Crear la estructura MAPI Recip para almacenar todos los destinatarios
ReDim MAPI_Recip(0 To cTo + cCC + cCCO - 1) As MapiRecip
' Cargar los "TO:" en la estructura
For i = 0 To cTo - 1
MAPI_Recip(i).Name = rTo(i)
MAPI_Recip(i).RecipClass = MAPI_TO
Next i
' Cargar los "CC:"
For i = 0 To cCC - 1
MAPI_Recip(cTo + i).Name = rCC(i)
MAPI_Recip(cTo + i).RecipClass = MAPI_CC
Next i
' Cargar los "CCO:"
For i = 0 To cCCO - 1
MAPI_Recip(cTo + cCC + i).Name = rCCO(i)
MAPI_Recip(cTo + cCC + i).RecipClass = MAPI_CCO
Next i
' Crear la estructura MAPI_File para los adjuntos
ReDim MAPI_File(0 To cAttach) As MapiFile
' Cargar los adjuntos en la estructura
MAPI_Message.FileCount = cAttach
For i = 0 To cAttach - 1
MAPI_File(i).Position = -1
MAPI_File(i).PathName = rAttach(i)
Next i
' Llenar los campos del mensaje
MAPI_Message.Subject = sSubject
MAPI_Message.NoteText = sMessage
MAPI_Message.RecipCount = cTo + cCC + cCCO
' Enviar el mensaje
SendMail = MAPISendMail(0&, 0&, MAPI_Message, MAPI_Recip(), _
MAPI_File(), MAPI_LOGON_UI, 0&)
Salida:
Exit Function
Err_CapturarError:
Select Case Err.Number
Case 48
'Error: No se encontró el archivo: C:\Archivos de programa\ _
Outlook Express\Msoe.dll
SendMail = 48
Case 453
'Error: Imposible encontra el punto de entrada de DLL BMAPISendMail en _
MAPI32X.DLL
'Asignar el número de error. El filtro y el mensaje más adelante.
SendMail = 453
Case Else
'Cazar todos aquellos errores inesperados.
MsgBox Err.Number & " " & Err.Description
End Select
Resume Salida 'Salida a otro procedimiento.
End Function
No Controle Desejado
********************************************************************************************
Dim lngRet As Long
'Envia a mensagem
lngRet = SendMail(("ASSUNTO"), ("destinatario@para"), ("destinatario@comcopia"), ("destinatario@comcopiaoculta"), ("C:\pasta\arquivo.txt"), ("TEXTO DA MENSAGEM"))
'Se ocorrer erro
If lngRet <> SUCCESS_SUCCESS Then
Select Case lngRet
Case 2
MsgBox "Error nº.: " & lngRet & ", ao enviar email." & vbCr & vbCr _
& "Verifique a origem do arquivo anexado. ", vbCritical, "ERRO"
Case 48
MsgBox "Error nº.: " & lngRet & ", ao enviar email." & vbCr & vbCr _
& "Não foi possÃvel carregar MSOE.DLL", 16, "ERRO"
Case 453
MsgBox "Error nº.: " & lngRet & " (de MSAccess), ao enviar email." _
& vbCr & vbCr _
& "MAPI32X.DLL, não é a versão correta.", vbCritical, "ERRO"
Case -2147467259
MsgBox "Error nº.: " & lngRet & ", ao enviar email." & vbCr & vbCr _
& "MAPI32.DLL, não é a versão correta.", vbCritical, "ERRO"
Case Else
MsgBox "Erro ao enviar email: " & lngRet, vbCritical, "ERRO"
End Select
End If
Espero ter ajudado....
T+,
Tópico encerrado , respostas não são mais permitidas