offline
- dr_Bora
- Anti Malware Fighter
Rank 2
- Pridružio: 24 Jul 2007
- Poruke: 12280
- Gde živiš: Höganäs, SE
|
IvanC ::btw: u koliko bi želio izvući samo keywords pretpostavljam da mogu samo zamijeniti ovu liniju kodanPos1 = InStr(1, sLine, "name=""description"" content=""", vbTextCompare)sa ovom linijom nPos1 = InStr(1, sLine, "name=""keywords"" content=""", vbTextCompare)
Nije dovoljno (nisam se baš toliko potrudio oko skripte  ). Dve linije niže imaš:
nPos2 = nPos1 + 28
Ovih 28 je dužina ovoga dole (tj. ofset od pozicije gde je string pronađen do pozicije gde ono što tebe zanima počinje):
name="Description" content="
pa bi za keywords trebalo da upišeš broj 25.
nPos1 = InStr(1, sLine, "name=""description"" content=""", vbTextCompare)
If nPos1 > 0 Then
nPos2 = nPos1 + 25
Ovo radi (testirano).
IvanC ::ali ako bi htio izvući TITLE kako onda ide linija koda jer nemam ovaj dio taga "name"?
pozdrav
Znači, string koji koristiš za prepoznavanje linije je <title> pa prva izmena mora da bude:
nPos1 = InStr(1, sLine, "<title>", vbTextCompare)
Ovime si dobio poziciju znaka < u <title>.
Sledeći korak je da se pomeriš u napred na poziciju gde počinje tekst koji ti želiš:
nPos2 = nPos1 + 7
Na kraju uklanjamo višak teksta sa kraja linije. Ranije je to bilo:
sLine = Replace(sLine, """/>", "") da bi uklonio "/> a sada će biti:
sLine = Replace(sLine, "</title>", "")
+ Kompletna proceduraSub GetAndWrite(sFilePath)
If FileIsUnicode(sFilePath) Then
Set oHtml = objfso.OpenTextFile(sFilePath, 1, False, -1)
Else
Set oHtml = objfso.OpenTextFile(sFilePath, 1, False, 0)
End If
sAll = sAll & sFilePath & " - "
bFound = False
If Not oHtml.AtEndOfStream Then
Do While (Not oHtml.AtEndOfStream) And (Not bFound)
sLine = oHtml.ReadLine
nPos1 = InStr(1, sLine, "<title>", vbTextCompare)
If nPos1 > 0 Then
nPos2 = nPos1 + 7
sLine = Mid(sLine, nPos2)
sLine = Replace(sLine, "</title>", "")
sAll = sAll & sLine
bFound = True
End If
Loop
End If
oHtml.Close
Set oHtml = Nothing
sAll = sAll & vbCrLf
End Sub
Naravno, alternativa je da se ovo odradi na ispravan način i da ne moraš da menjaš skriptu svaki put:
+ Kompletan kodSet objFSO = CreateObject("Scripting.FileSystemObject")
If WScript.Arguments.length = 0 Then
MsgBox "Drag and drop a folder with html files"
WScript.Quit
End If
objStartFolder = WScript.Arguments(0)
sLineID = InputBox("Uneti string za identifikaciju linije. Npr:" & vbCrLf & vbCrLf & "name=""description"" content=""" & vbCrLf & vbCrLf & "name=""author"" content=""" & vbCrLf & vbCrLf & "<title>",, "name=""description"" content=""")
nOffset = Len(sLineID)
sLineEnd = InputBox("Uneti string za ukloniti sa kraja linije. Npr:" & vbCrLf & vbCrLf & """/>" & vbCrLf & vbCrLf & "</title>",, """/>")
On Error Resume Next
Sub ShowSubFolders(Folder)
For Each Subfolder In Folder.SubFolders
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
For Each objFile In colFiles
If LCase(objfso.GetExtensionName(objFile.Path)) = "html" Then GetAndWrite objFile.Path
Next
ShowSubFolders Subfolder
Next
End Sub
Function FileIsUnicode(File_Name_To_Test)
On Error Resume Next
FileIsUnicode = False
Set TestFile = FSO.OpenTextFile(File_Name_To_Test)
If Err <> 0 Then
On Error Goto 0
Exit Function
End If
char1 = TestFile.Read(1)
char2 = TestFile.Read(1)
TestFile.Close
If Asc(char1) = 255 And Asc(char2) = 254 Then FileIsUnicode = True
On Error Goto 0
End Function
Sub GetAndWrite(sFilePath)
If FileIsUnicode(sFilePath) Then
Set oHtml = objfso.OpenTextFile(sFilePath, 1, False, -1)
Else
Set oHtml = objfso.OpenTextFile(sFilePath, 1, False, 0)
End If
sAll = sAll & sFilePath & " - "
bFound = False
If Not oHtml.AtEndOfStream Then
Do While (Not oHtml.AtEndOfStream) And (Not bFound)
sLine = oHtml.ReadLine
nPos1 = InStr(1, sLine, sLineID, vbTextCompare)
If nPos1 > 0 Then
nPos2 = nPos1 + nOffset
sLine = Mid(sLine, nPos2)
sLine = Replace(sLine, sLineEnd, "")
sAll = sAll & sLine
bFound = True
End If
Loop
End If
oHtml.Close
Set oHtml = Nothing
sAll = sAll & vbCrLf
End Sub
sAll = vbCrLf & vbCrLf & "Folder: " & WScript.Arguments(0) & vbCrLf & vbCrLf & vbCrLf
Set objFolder = objFSO.GetFolder(objStartFolder)
Set colFiles = objFolder.Files
For Each objFile In colFiles
If LCase(objfso.GetExtensionName(objFile.Path)) = "html" Then GetAndWrite objFile.Path
Next
ShowSubfolders objFSO.GetFolder(objStartFolder)
Set oDescFile = objfso.OpenTextFile(objfso.GetParentFolderName(WScript.ScriptFullName) & "\Descriptions from html.txt", 8, True, -1)
oDescFile.Write(sAll)
oDescFile.Close
MsgBox "Done!"
Ovime bi trebalo da možeš izvući bilo koju liniju... I da, jasno mi je da sam ovo mogao odmah da uradim umesto da mudrujem bez potrebe. 
|
