[ul9]

Самое странное, что 32 строка вообще пустая

Код:

...
29  SetTable strTable, objConnection
30
31  strIP = GetIP()
32  
33  With objRecordset
...

[ul9]

А можно сделать, чтобы вся строка с ip и датой помимо записи в файл ещё и в буфер обмена копировалась?
Сейчас я делаю так:
1. Запускаю скрипт
2. Открываю PreviousIPList.txt
3. И копирую последнюю запись, она имеет вот такой вид
"171.122.140.127";29.12.2012 20:42:22

Так вот, хотелось бы, чтобы эта строка копировалась в буфер или на выскакивающем msgBox была кнопка скопировать, так как не всегда полезно перезаписывать буфер, мало ли что там может быть

Вот код

читать дальше »

Код:

Option Explicit

Const adOpenStatic     = 3
Const adLockOptimistic = 3
Const adCmdText        = 1

Dim objConnection
Dim objRecordset

Dim strPath2DB
Dim strTable

Dim strIP
Dim strLastIP
Dim strPreviousIPs


strPath2DB         = WScript.CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName) & "\"
strTable           = Replace("PreviousIPList.txt", ".", "#")

Set objConnection  = WScript.CreateObject("ADODB.Connection")
Set objRecordSet   = WScript.CreateObject("ADODB.Recordset")

objConnection.Open _
	"Provider=Microsoft.Jet.OLEDB.4.0;" & _
	"Data Source=" & strPath2DB & ";" & _
	"Extended Properties=""text;HDR=YES;FMT=CSVDelimited"""

SetTable strTable, objConnection

strIP = GetIP()

With objRecordset
	.Open "SELECT TOP 1 * FROM " & strTable & " ORDER BY DateTime DESC", _
		objConnection, adOpenStatic, adLockOptimistic, adCmdText
		
	If .RecordCount > 0 Then
		strLastIP = .Fields.Item("IP").Value & vbTab & .Fields.Item("DateTime").Value
	Else
		strLastIP = "[Отсутствует]"
	End If
	
	.Close
	
	.Open "SELECT * FROM " & strTable & " WHERE IP = '" & strIP & "'", _
		objConnection, adOpenStatic, adLockOptimistic, adCmdText
	
	If .RecordCount > 0 Then
		strPreviousIPs = ""
		
		Do Until .EOF
			strPreviousIPs = strPreviousIPs & .Fields.Item("IP").Value & vbTab & .Fields.Item("DateTime").Value & vbCrLf
			
			.MoveNext
		Loop
		
		MsgBox "Данный IP адрес уже был ранее добавлен в список:" & vbCrLf & strPreviousIPs & vbCrLf & _
			"Последний добавленный IP адрес:" & vbCrLf & strLastIP, vbOKOnly + vbExclamation, "IP адрес [" & strIP & "] уже существует"
	Else
		objRecordset.AddNew Array("DateTime", "IP"), Array(Now(), strIP)
		
		MsgBox "IP адрес [" & strIP & "] добавлен в список." & vbCrLf & vbCrLf & _
			"Последний добавленный IP адрес:" & vbCrLf & strLastIP, vbOKOnly + VbInformation, "IP адрес [" & strIP & "] добавлен"
	End If
	
	.Close
End With

objConnection.Close

Set objRecordset  = Nothing
Set objConnection = Nothing

WScript.Quit 0
'=============================================================================

'=============================================================================
Function GetIP()
	With WScript.CreateObject("Microsoft.XMLHTTP")
		.open "GET", "http://ifconfig.me/ip", False
		.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
		.send
		
		GetIP = Replace(.responseText, vbLf, "")
	End With
End Function
'=============================================================================

'=============================================================================
Sub SetTable(strTable, objConnection)
	Const adDate  = 7
	Const adWChar = 130
	
	Dim boolTableExists
	
	Dim objCatalog
	Dim objTable
	
	
	boolTableExists = False
	
	Set objCatalog = WScript.CreateObject("ADOX.Catalog")
	Set objCatalog.ActiveConnection = objConnection
	
	For Each objTable In objCatalog.Tables
		If objTable.Name = strTable Then
			boolTableExists = True
			
			Exit For
		End If
	Next
	
	If Not boolTableExists Then
		Set objTable = WScript.CreateObject("ADOX.Table")
		
		objTable.Name = strTable
		
		objTable.Columns.Append "IP", adWChar
		objTable.Columns.Append "DateTime", adDate
				
		objCatalog.Tables.Append objTable
	End If
	
	Set objTable   = Nothing
	Set objCatalog = Nothing
End Sub
'=============================================================================

[Iska]

ul9, стало быть, заработало?

Так вот, хотелось бы, чтобы эта строка копировалась в буфер »

Пробуйте:

читать дальше »

Код:

Option Explicit

Const adOpenStatic     = 3
Const adLockOptimistic = 3
Const adCmdText        = 1

Dim objConnection
Dim objRecordset

Dim strPath2DB
Dim strTable

Dim strIP
Dim strLastIP
Dim strPreviousIPs


strPath2DB         = WScript.CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName) & "\"
strTable           = Replace("PreviousIPList.txt", ".", "#")

Set objConnection  = WScript.CreateObject("ADODB.Connection")
Set objRecordSet   = WScript.CreateObject("ADODB.Recordset")

objConnection.Open _
	"Provider=Microsoft.Jet.OLEDB.4.0;" & _
	"Data Source=" & strPath2DB & ";" & _
	"Extended Properties=""text;HDR=YES;FMT=CSVDelimited"""

SetTable strTable, objConnection

strIP = GetIP()

With objRecordset
	.Open "SELECT TOP 1 * FROM " & strTable & " ORDER BY DateTime DESC", _
		objConnection, adOpenStatic, adLockOptimistic, adCmdText
		
	If .RecordCount > 0 Then
		strLastIP = .Fields.Item("IP").Value & vbTab & .Fields.Item("DateTime").Value
	Else
		strLastIP = "[Отсутствует]"
	End If
	
	.Close
	
	.Open "SELECT * FROM " & strTable & " WHERE IP = '" & strIP & "'", _
		objConnection, adOpenStatic, adLockOptimistic, adCmdText
	
	If .RecordCount > 0 Then
		strPreviousIPs = ""
		
		Do Until .EOF
			strPreviousIPs = strPreviousIPs & .Fields.Item("IP").Value & vbTab & .Fields.Item("DateTime").Value & vbCrLf
			
			.MoveNext
		Loop
		
		MsgBox "Данный IP адрес уже был ранее добавлен в список:" & vbCrLf & strPreviousIPs & vbCrLf & _
			"Последний добавленный IP адрес:" & vbCrLf & strLastIP, vbOKOnly + vbExclamation, "IP адрес [" & strIP & "] уже существует"
	Else
		objRecordset.AddNew Array("DateTime", "IP"), Array(Now(), strIP)
		
		MsgBox "IP адрес [" & strIP & "] добавлен в список." & vbCrLf & vbCrLf & _
			"Последний добавленный IP адрес:" & vbCrLf & strLastIP, vbOKOnly + VbInformation, "IP адрес [" & strIP & "] добавлен"
		
		WScript.CreateObject("HTMLFile").parentWindow.clipboardData.setData "text", """" & strIP & """;" & Now()
		
		'With WScript.CreateObject("InternetExplorer.Application")
		'	.Navigate "about:blank"
		'	.document.parentWindow.clipboardData.setData "text", """" & strIP & """;" & Now()
		'	
		'	.Quit
		'End With
	End If
	
	.Close
End With

objConnection.Close

Set objRecordset  = Nothing
Set objConnection = Nothing

WScript.Quit 0
'=============================================================================

'=============================================================================
Function GetIP()
	With WScript.CreateObject("Microsoft.XMLHTTP")
		.open "GET", "http://ifconfig.me/ip", False
		.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
		.send
		
		GetIP = Replace(.responseText, vbLf, "")
	End With
End Function
'=============================================================================

'=============================================================================
Sub SetTable(strTable, objConnection)
	Const adDate  = 7
	Const adWChar = 130
	
	Dim boolTableExists
	
	Dim objCatalog
	Dim objTable
	
	
	boolTableExists = False
	
	Set objCatalog = WScript.CreateObject("ADOX.Catalog")
	Set objCatalog.ActiveConnection = objConnection
	
	For Each objTable In objCatalog.Tables
		If objTable.Name = strTable Then
			boolTableExists = True
			
			Exit For
		End If
	Next
	
	If Not boolTableExists Then
		Set objTable = WScript.CreateObject("ADOX.Table")
		
		objTable.Name = strTable
		
		objTable.Columns.Append "IP", adWChar
		objTable.Columns.Append "DateTime", adDate
				
		objCatalog.Tables.Append objTable
	End If
	
	Set objTable   = Nothing
	Set objCatalog = Nothing
End Sub
'=============================================================================

Если не сработает этот код — закомментируйте его и раскомментируйте этот код. Если не сработает и он — тогда только использовать обходные пути: с вызовом «clip.exe», сторонних библиотек и т.п.

или на выскакивающем msgBox была кнопка скопировать, »

Она есть на любом MessageBox'е. Называется — «Ctrl-C». Правда попадает туда всё содержимое.

так как не всегда полезно перезаписывать буфер, мало ли что там может быть »

Используйте сторонний менеджер буфера обмена. Я, например, использую CLCL. Для простого текста сгодится и кэш буфера обмена, предоставляемый PuntoSwitcher (если Вы его используете).

[ul9]

Сработал зелёный вариант, но постоянно выскакивает


Можно как-нибудь "подавить" это окошко?

ul9, стало быть, заработало? »

Я его в exe перегнала и он заработал. Но всё равно вернулась на xp, так как для работы использую много разных батников, а переписывать под windows7 слишком затратно.

[Iska]

Сработал зелёный вариант, но постоянно выскакивает »

Можно. Понижением безопасности IE. Потому крайне не рекомендую этого делать.

Можно ещё попробовать в *.hta сделать, там настройки безопасности изначально пониже.

[ul9]

Я включила вот этот пункт


Это ведь не критично? Учитывая, что IE я не использую как браузер вообще.

[Iska]

Я включила вот этот пункт »

Помогло?

IE я не использую как браузер вообще. »

Вы — нет. А какие-то приложения могут и использовать.

Впрочем, смотрите сами.

[ul9]

Помогло? »

Помогло. Спасибо.

[registeruser1]

Ребят, я в коде из 8-го поста хочу поменять адрес который определяет ip.
Тот работает долго уж. Ставлю в место него - http://checkip.dyndns.com.
С ним все шустро 1-2сек и все. Скрипт записывает еще кучу ненужной информации HTML-кода.
Помогите от этого мусора избавиться...

[Iska]

registeruser1, ну, насчёт кучи — это Вы загнули:

<html><head><title>Current IP Check</title></head><body>Current IP Address: XXX.XXX.XXX.XXX</body></html>

Пробуйте:

читать дальше »

Код:

Option Explicit

Const ForAppending = 8
Const strPreviousIPList = "PreviousIPList.txt"

Dim strIP
Dim boolIPExists

Dim objRegExp


Set objRegExp = WScript.CreateObject("VBScript.RegExp")

With objRegExp
	.IgnoreCase = True
	.Pattern    = "<html><head><title>Current IP Check</title></head><body>Current IP Address: (\d+\.\d+\.\d+\.\d+)</body></html>"
End With

With WScript.CreateObject("Microsoft.XMLHTTP")
	.open "GET", "http://checkip.dyndns.com/", False
	.send
	
	strIP = objRegExp.Execute(.responseText)(0).Submatches(0)
End With

Set objRegExp = Nothing

boolIPExists = False

With WScript.CreateObject("Scripting.FileSystemObject")
	If .FileExists(strPreviousIPList) Then
		With .OpenTextFile(strPreviousIPList)
			Do Until .AtEndOfStream
				If .ReadLine() = strIP Then
					boolIPExists = True
					
					Exit Do
				End If
			Loop
			
			.Close
		End With
	End If
	
	If boolIPExists Then
		MsgBox "IP exists", vbOKOnly + vbExclamation, "IP exists"
	Else
		With .OpenTextFile(strPreviousIPList, ForAppending, True)
			.WriteLine strIP
			
			.Close
		End With
		
		MsgBox "IP [" & strIP & "] append", vbOKOnly + vbInformation, "IP append"
	End If
End With

WScript.Quit 0