Drama con Visual
caudillo_famoso
28 de Enero del 2005
Estimados(as):
Tengo un terrible problema con Visual, cree un pequeño programa para que me de la IP local y la IP publica, luego inserte un codigo para que con esa informacion me mandara un archivo asp(texto plano), pero no resulta.
esto es lo que tengo:
Private Const ERROR_SUCCESS As Long = 0
Private Const MAX_ADAPTER_NAME_LENGTH As Long = 256
Private Const MAX_ADAPTER_DESCRIPTION_LENGTH As Long = 128
Private Const MAX_ADAPTER_ADDRESS_LENGTH As Long = 8
Private Type IP_ADDRESS_STRING
IpAddr(0 To 15) As Byte
End Type
Private Type IP_MASK_STRING
IpMask(0 To 15) As Byte
End Type
Private Type IP_ADDR_STRING
dwNext As Long
IpAddress As IP_ADDRESS_STRING
IpMask As IP_MASK_STRING
dwContext As Long
End Type
Private Type IP_ADAPTER_INFO
dwNext As Long
ComboIndex As Long 'reserved
sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3)) As Byte
sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte
dwAddressLength As Long
sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1)) As Byte
dwIndex As Long
uType As Long
uDhcpEnabled As Long
CurrentIpAddress As Long
IpAddressList As IP_ADDR_STRING
GatewayList As IP_ADDR_STRING
DhcpServer As IP_ADDR_STRING
bHaveWins As Long
PrimaryWinsServer As IP_ADDR_STRING
SecondaryWinsServer As IP_ADDR_STRING
LeaseObtained As Long
LeaseExpires As Long
End Type
Private Declare Function GetAdaptersInfo Lib "iphlpapi.dll" _
(pTcpTable As Any, _
pdwSize As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(dst As Any, _
src As Any, _
ByVal bcount As Long)
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" _
(ByVal lpszUrlName As String) As Long
Private Declare Function lstrlenW Lib "kernel32" _
(ByVal lpString As Long) As Long
Private Sub Form_Load()
Command1.Caption = "Obten tu IP publica"
Text1.Text = LocalIPAddress()
Text2.Text = ""
End Sub
Private Sub Command1_Click()
Text2.Text = Obten_tu_ip_publica()
End Sub
Private Function Obten_tu_ip_publica()
Dim sSourceUrl As String
Dim sLocalFile As String
Dim hfile As Long
Dim buff As String
Dim pos1 As Long
Dim pos2 As Long
'site returning IP address
sSourceUrl = "http://vbnet.mvps.org/resources/tools/getpublicip.shtml"
sLocalFile = "c:ip.txt"
'ensure this file does not exist in the cache
Call DeleteUrlCacheEntry(sSourceUrl)
'download the public IP file,
'read into a buffer and delete
If DownloadFile(sSourceUrl, sLocalFile) Then
hfile = FreeFile
Open sLocalFile For Input As #hfile
buff = Input$(LOF(hfile), hfile)
Close #hfile
'look for the IP line
pos1 = InStr(buff, "var ip =")
'if found,
If pos1 Then
'get position of first and last single
'quotes around address (e.g. '11.22.33.44')
pos1 = InStr(pos1 + 1, buff, "'", vbTextCompare) + 1
pos2 = InStr(pos1 + 1, buff, "'", vbTextCompare) '- 1
'return the IP address
Obten_tu_ip_publica = Mid$(buff, pos1, pos2 - pos1)
Else
Obten_tu_ip_publica = "(unable to parse IP)"
End If 'pos1
Kill sLocalFile
Else
Obten_tu_ip_publica = "(unable to access shtml page)"
End If 'DownloadFile
End Function
Private Function DownloadFile(ByVal sURL As String, _
ByVal sLocalFile As String) As Boolean
DownloadFile = URLDownloadToFile(0, sURL, sLocalFile, 0, 0) = ERROR_SUCCESS
End Function
Private Function LocalIPAddress() As String
Dim cbRequired As Long
Dim buff() As Byte
Dim ptr1 As Long
Dim sIPAddr As String
Dim Adapter As IP_ADAPTER_INFO
Call GetAdaptersInfo(ByVal 0&, cbRequired)
If cbRequired > 0 Then
ReDim buff(0 To cbRequired - 1) As Byte
If GetAdaptersInfo(buff(0), cbRequired) = ERROR_SUCCESS Then
'get a pointer to the data stored in buff()
ptr1 = VarPtr(buff(0))
Do While (ptr1 <> 0)
'copy the data from the pointer to the
'first adapter into the IP_ADAPTER_INFO type
CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
With Adapter
'the DHCP IP address is in the
'IpAddress.IpAddr member
sIPAddr = TrimNull(StrConv(.IpAddressList.IpAddress.IpAddr, vbUnicode))
If Len(sIPAddr) > 0 Then Exit Do
ptr1 = .dwNext
End With 'With Adapter
'ptr1 is 0 when (no more adapters)
Loop 'Do While (ptr1 <> 0)
End If 'If GetAdaptersInfo
End If 'If cbRequired > 0
'return any string found
LocalIPAddress = sIPAddr
End Function
Private Function TrimNull(startstr As String) As String
TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr)))
End Function
Private Sub Image1_Click()
End Sub
Function Proc_Gen_Log()
Dim string_log_recorded
string_log_recorded = "<$php {header(& Chr$(34)& http://www.raton.es/prueba/index.html)}$> &Chr$(34) ) & Chr(13)"
Proc_Gen_Log = string_log_recorded
url_file = "c:/IP/text_file/miArchivo.asp"
If displayFileInfo(url_file) = "true" Then
Dim fso_w As New FileSystemObject
Dim f_w As File
Dim fsoStream_w As TextStream
Set f_w = fso_w.GetFile(url_file)
Set fsoStream_w = f_w.OpenAsTextStream(ForAppending)
' Agrega lineas al archivo
fsoStream_w.WriteLine string_log_recorded
fsoStream_w.Close
Set fsoStream_w = Nothing
Set fso_w = Nothing
Else
'---------------------no existe y se procede a crear----------------
Dim fso As New FileSystemObject
Dim fsoStream As TextStream
' Create a text file, and return a reference to a TextStream
Set fsoStream = fso.CreateTextFile(url_file, True)
' Write to the file
fsoStream.WriteLine string_log_recorded
fsoStream.Close
Set fsoStream = Nothing
Set fso = Nothing
'-------------------------------------------------------------------
End If
End Function
Function displayFileInfo(ByVal fileName As String)
'------------- comprobacion de existencia de archivo log--------
Dim fso As New FileSystemObject
Dim f As File
If fso.FileExists(fileName) Then
displayFileInfo = "true"
Else
displayFileInfo = "false"
End If
End Function
Al hacerlo andar esta cosa no hace lo anelado, que tire el archivo con el codigo ASP...
...Snif...
Gracias de antemano.
Tengo un terrible problema con Visual, cree un pequeño programa para que me de la IP local y la IP publica, luego inserte un codigo para que con esa informacion me mandara un archivo asp(texto plano), pero no resulta.
esto es lo que tengo:
Private Const ERROR_SUCCESS As Long = 0
Private Const MAX_ADAPTER_NAME_LENGTH As Long = 256
Private Const MAX_ADAPTER_DESCRIPTION_LENGTH As Long = 128
Private Const MAX_ADAPTER_ADDRESS_LENGTH As Long = 8
Private Type IP_ADDRESS_STRING
IpAddr(0 To 15) As Byte
End Type
Private Type IP_MASK_STRING
IpMask(0 To 15) As Byte
End Type
Private Type IP_ADDR_STRING
dwNext As Long
IpAddress As IP_ADDRESS_STRING
IpMask As IP_MASK_STRING
dwContext As Long
End Type
Private Type IP_ADAPTER_INFO
dwNext As Long
ComboIndex As Long 'reserved
sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3)) As Byte
sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte
dwAddressLength As Long
sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1)) As Byte
dwIndex As Long
uType As Long
uDhcpEnabled As Long
CurrentIpAddress As Long
IpAddressList As IP_ADDR_STRING
GatewayList As IP_ADDR_STRING
DhcpServer As IP_ADDR_STRING
bHaveWins As Long
PrimaryWinsServer As IP_ADDR_STRING
SecondaryWinsServer As IP_ADDR_STRING
LeaseObtained As Long
LeaseExpires As Long
End Type
Private Declare Function GetAdaptersInfo Lib "iphlpapi.dll" _
(pTcpTable As Any, _
pdwSize As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(dst As Any, _
src As Any, _
ByVal bcount As Long)
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" _
(ByVal lpszUrlName As String) As Long
Private Declare Function lstrlenW Lib "kernel32" _
(ByVal lpString As Long) As Long
Private Sub Form_Load()
Command1.Caption = "Obten tu IP publica"
Text1.Text = LocalIPAddress()
Text2.Text = ""
End Sub
Private Sub Command1_Click()
Text2.Text = Obten_tu_ip_publica()
End Sub
Private Function Obten_tu_ip_publica()
Dim sSourceUrl As String
Dim sLocalFile As String
Dim hfile As Long
Dim buff As String
Dim pos1 As Long
Dim pos2 As Long
'site returning IP address
sSourceUrl = "http://vbnet.mvps.org/resources/tools/getpublicip.shtml"
sLocalFile = "c:ip.txt"
'ensure this file does not exist in the cache
Call DeleteUrlCacheEntry(sSourceUrl)
'download the public IP file,
'read into a buffer and delete
If DownloadFile(sSourceUrl, sLocalFile) Then
hfile = FreeFile
Open sLocalFile For Input As #hfile
buff = Input$(LOF(hfile), hfile)
Close #hfile
'look for the IP line
pos1 = InStr(buff, "var ip =")
'if found,
If pos1 Then
'get position of first and last single
'quotes around address (e.g. '11.22.33.44')
pos1 = InStr(pos1 + 1, buff, "'", vbTextCompare) + 1
pos2 = InStr(pos1 + 1, buff, "'", vbTextCompare) '- 1
'return the IP address
Obten_tu_ip_publica = Mid$(buff, pos1, pos2 - pos1)
Else
Obten_tu_ip_publica = "(unable to parse IP)"
End If 'pos1
Kill sLocalFile
Else
Obten_tu_ip_publica = "(unable to access shtml page)"
End If 'DownloadFile
End Function
Private Function DownloadFile(ByVal sURL As String, _
ByVal sLocalFile As String) As Boolean
DownloadFile = URLDownloadToFile(0, sURL, sLocalFile, 0, 0) = ERROR_SUCCESS
End Function
Private Function LocalIPAddress() As String
Dim cbRequired As Long
Dim buff() As Byte
Dim ptr1 As Long
Dim sIPAddr As String
Dim Adapter As IP_ADAPTER_INFO
Call GetAdaptersInfo(ByVal 0&, cbRequired)
If cbRequired > 0 Then
ReDim buff(0 To cbRequired - 1) As Byte
If GetAdaptersInfo(buff(0), cbRequired) = ERROR_SUCCESS Then
'get a pointer to the data stored in buff()
ptr1 = VarPtr(buff(0))
Do While (ptr1 <> 0)
'copy the data from the pointer to the
'first adapter into the IP_ADAPTER_INFO type
CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
With Adapter
'the DHCP IP address is in the
'IpAddress.IpAddr member
sIPAddr = TrimNull(StrConv(.IpAddressList.IpAddress.IpAddr, vbUnicode))
If Len(sIPAddr) > 0 Then Exit Do
ptr1 = .dwNext
End With 'With Adapter
'ptr1 is 0 when (no more adapters)
Loop 'Do While (ptr1 <> 0)
End If 'If GetAdaptersInfo
End If 'If cbRequired > 0
'return any string found
LocalIPAddress = sIPAddr
End Function
Private Function TrimNull(startstr As String) As String
TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr)))
End Function
Private Sub Image1_Click()
End Sub
Function Proc_Gen_Log()
Dim string_log_recorded
string_log_recorded = "<$php {header(& Chr$(34)& http://www.raton.es/prueba/index.html)}$> &Chr$(34) ) & Chr(13)"
Proc_Gen_Log = string_log_recorded
url_file = "c:/IP/text_file/miArchivo.asp"
If displayFileInfo(url_file) = "true" Then
Dim fso_w As New FileSystemObject
Dim f_w As File
Dim fsoStream_w As TextStream
Set f_w = fso_w.GetFile(url_file)
Set fsoStream_w = f_w.OpenAsTextStream(ForAppending)
' Agrega lineas al archivo
fsoStream_w.WriteLine string_log_recorded
fsoStream_w.Close
Set fsoStream_w = Nothing
Set fso_w = Nothing
Else
'---------------------no existe y se procede a crear----------------
Dim fso As New FileSystemObject
Dim fsoStream As TextStream
' Create a text file, and return a reference to a TextStream
Set fsoStream = fso.CreateTextFile(url_file, True)
' Write to the file
fsoStream.WriteLine string_log_recorded
fsoStream.Close
Set fsoStream = Nothing
Set fso = Nothing
'-------------------------------------------------------------------
End If
End Function
Function displayFileInfo(ByVal fileName As String)
'------------- comprobacion de existencia de archivo log--------
Dim fso As New FileSystemObject
Dim f As File
If fso.FileExists(fileName) Then
displayFileInfo = "true"
Else
displayFileInfo = "false"
End If
End Function
Al hacerlo andar esta cosa no hace lo anelado, que tire el archivo con el codigo ASP...
...Snif...
Gracias de antemano.