I already try a search engine script like below:
<HTML><BODY>
<B>Search Results for <%=Request("SearchText")%></B><BR>
<%
Const fsoForReading = 1
Dim strSearchText
strSearchText = Request("SearchText")
''# Now, we want to search all of the files
Dim objFSO
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Dim objFolder
Set objFolder = objFSO.GetFolder(Server.MapPath("/"))
Dim objFile, objTextStream, strFileContents, bolFileFound
bolFileFound = False
For Each objFile in objFolder.Files
If Response.IsClientConnected then
Set objTextStream = objFSO.OpenTextFile(objFile.Path,fsoForReading)
strFileContents = objTextStream.ReadAll
If InStr(1,strFileContents,strSearchText,1) then
Response.Write "<LI><A HREF=""/" & objFile.Name & _
""">" & objFile.Name & "</A><BR>"
bolFileFound = True
End If
objTextStream.Close
End If
Next
if Not bolFileFound then Response.Write "No matches found..."
Set objTextStream = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
%>
</BODY></HTML>
the output will show only the name of file, what i want is the title of the file.
my question is, how to get the string between in order to show up for the result? or is there any other script related to search engine in asp classic?
I'm not sure I get what you mean, but if you intend on grabbing the file name without the path nor extension, here's a snippet I use:
Public Function GetFileName(flname As String) As String
'From: http://www.freevbcode.com/ShowCode.asp?ID=1638
'By: Maria Rapini
'Get the filename without the path or extension.
'Input Values:
' flname - path and filename of file.
'Return Value:
' GetFileName - name of file without the extension.
Dim posn As Integer, i As Integer
Dim fName As String
posn = 0
'find the position of the last "\" character in filename
For i = 1 To Len(flname)
If (Mid(flname, i, 1) = "\") Then posn = i
Next i
'get filename without path
fName = Right(flname, Len(flname) - posn)
'get filename without extension
posn = InStr(fName, ".")
If posn <> 0 Then
fName = Left(fName, posn - 1)
End If
GetFileName = fName
End Function
Related
This topic is related to Loop through links and download PDF's
I am trying to convert my current VBA code into VBScript. I have already understood that I have to remove the variable types (As ... part of Dim statements) and use CreatObject to get those objects but otherwise everything should port as-is. DoEvents will also have to be replaced with something like Wscript.sleep.
I came up with some problems. Currently while running VBS file I am getting an error saying "Object required: 'MSHTML'". Pointing to line 65, where I have Set hDoc = MSHTML.HTMLDocument. I have tried to search on Google but got nothing helpful for this one.
How I should proceed with this one?
DownloadFiles("https://www.nordicwater.com/products/waste-water/")
Sub DownloadFiles(p_sURL)
Set xHttp = CreateObject("Microsoft.XMLHTTP")
Dim xHttp
Dim hDoc
Dim Anchors
Dim Anchor
Dim sPath
Dim wholeURL
Dim internet
Dim internetdata
Dim internetlink
Dim internetinnerlink
Dim arrLinks
Dim sLink
Dim iLinkCount
Dim iCounter
Dim sLinks
Set internet = CreateObject("InternetExplorer.Application")
internet.Visible = False
internet.navigate (p_sURL)
Do Until internet.ReadyState = 4
Wscript.Sleep 100
Loop
Set internetdata = internet.document
Set internetlink = internetdata.getElementsByTagName("a")
i = 1
For Each internetinnerlink In internetlink
If Left(internetinnerlink, 36) = "https://www.nordicwater.com/product/" Then
If sLinks <> "" Then sLinks = sLinks & vbCrLf
sLinks = sLinks & internetinnerlink.href
i = i + 1
Else
End If
Next
wholeURL = "https://www.nordicwater.com/"
sPath = "C:\temp\"
arrLinks = Split(sLinks, vbCrLf)
iLinkCount = UBound(arrLinks) + 1
For iCounter = 1 To iLinkCount
sLink = arrLinks(iCounter - 1)
'Get the directory listing
xHttp.Open "GET", sLink
xHttp.send
'Wait for the page to load
Do Until xHttp.ReadyState = 4
Wscript.Sleep 100
Loop
'Put the page in an HTML document
Set hDoc = MSHTML.HTMLDocument
hDoc.body.innerHTML = xHttp.responseText
'Loop through the hyperlinks on the directory listing
Set Anchors = hDoc.getElementsByTagName("a")
For Each Anchor In Anchors
'test the pathname to see if it matches your pattern
If Anchor.pathname Like "*.pdf" Then
xHttp.Open "GET", wholeURL & Anchor.pathname, False
xHttp.send
With CreateObject("Adodb.Stream")
.Type = 1
.Open
.write xHttp.responseBody
.SaveToFile sPath & getName(wholeURL & Anchor.pathname), 2 '//overwrite
End With
End If
Next
Next
End Sub
Function:
Function getName(pf)
getName = Split(pf, "/")(UBound(Split(pf, "/")))
End Function
Instead of Set hDoc = MSHTML.HTMLDocument, use:
Set hDoc = CreateObject("htmlfile")
In VBA/VB6 you can specify variable and object types but not with VBScript. You have to use CreateObject (or GetObject: GetObject function) to instantiate objects like MSHTML.HTMLDocument, Microsoft.XMLHTTP, InternetExplorer.Application, etc instead of declaring those using Dim objIE As InternetExplorer.Application for example.
Another change:
If Anchor.pathname Like "*.pdf" Then
can be written using StrComp function:
If StrComp(Right(Anchor.pathname, 4), ".pdf", vbTextCompare) = 0 Then
or using InStr function:
If InStr(Anchor.pathname, ".pdf") > 0 Then
Also, at the beginning of your sub, you do the following:
Set xHttp = CreateObject("Microsoft.XMLHTTP")
Dim xHttp
You should declare your variables before assigning them values or objects. In VBScript this is very relaxed, your code will work because VBScript will create undefined variables for you but it's good practice to Dim your variables before using them.
Except for Wscript.sleep commands, your VBScript code will work in VB6/VBA so you can debug your script in VB6 or VBA apps (like Excel).
Have an assignment to do - it's to extract data from Lotus Notes DB including documents and their attachments. The purpose of this is to put it and store on the Sharepoint as a library.
So far I have managed to create a view and export the data for it to structure in Excel.
Also, I have looked up some Agents examples for extracting the attachments. With implementation of the below script, I managed to export the attachments:
Dim sDir As String
Dim s As NotesSession
Dim w As NotesUIWorkspace
Dim db As NotesDatabase
Dim dc As NotesDocumentCollection
Dim doc As NotesDocument
Sub Initialize
Set s = New NotesSession
Set w = New NotesUIWorkspace
Set db = s.CurrentDatabase
Set dc = db.UnprocessedDocuments
Set doc = dc.GetFirstDocument
Dim rtItem As NotesRichTextItem
Dim RTNames List As String
Dim DOCNames List As String
Dim itemCount As Integer
Dim sDefaultFolder As String
Dim x As Integer
Dim vtDir As Variant
Dim iCount As Integer
Dim j As Integer
Dim lngExportedCount As Long
Dim attachmentObject As Variant
x = MsgBox("This action will extract all attachments From the " & CStr(dc.Count) & _
" document(s) you have selected, And place them into the folder of your choice." & _
Chr(10) & Chr(10) & "Would you like To continue?", 32 + 4, "Export Attachments")
If x <> 6 Then Exit Sub
sDefaultFolder = s.GetEnvironmentString("LPP_ExportAttachments_DefaultFolder")
If sDefaultFolder = "" Then sDefaultFolder = "F:"
vtDir = w.SaveFileDialog( False, "Export attachments To which folder?", "All files|*.*", sDefaultFolder, "Choose Folder and Click Save")
If IsEmpty(vtDir) Then Exit Sub
sDir = StrLeftBack(vtDir(0), "\")
Call s.SetEnvironmentVar("LPP_ExportAttachments_DefaultFolder", sDir)
While Not (doc Is Nothing)
iCount = 0
itemCount = 0
lngExportedCount = 0
Erase RTNames
Erase DocNames
'Scan all items in document
ForAll i In doc.Items
If i.Type = RICHTEXT Then
Set rtItem = doc.GetfirstItem(i.Name)
If Not IsEmpty(rtItem.EmbeddedObjects) Then
RTNames(itemCount) = CStr(i.Name)
itemCount = itemCount +1
End If
End If
End ForAll
For j = 0 To itemCount-1
Set rtItem = Nothing
Set rtItem = doc.GetfirstItem(RTNames(j))
ForAll Obj In rtItem.EmbeddedObjects
If ( Obj.Type = EMBED_ATTACHMENT ) Then
Call ExportAttachment(Obj)
Call doc.Save( False, True )
'creates conflict doc if conflict exists
End If
End ForAll
Next
'Scan all items in document
ForAll i In doc.Items
If i.Type = ATTACHMENT Then
DOCNames(lngExportedCount) = i.Values(0)
lngExportedCount = lngExportedCount + 1
End If
End ForAll
For j% = 0 To lngExportedCount-1
Set attachmentObject = Nothing
Set attachmentObject = doc.GetAttachment(DOCNames(j%))
Call ExportAttachment(attachmentObject)
Call doc.Save( False, True )
'creates conflict doc if conflict exists
Next
Set doc = dc.GetNextDocument(doc)
Wend
MsgBox "Export Complete.", 16, "Finished"
End Sub
Sub ExportAttachment(o As Variant)
Dim sAttachmentName As String
Dim sNum As String
Dim sTemp As String
sAttachmentName = sDir & "\" & o.Source
While Not (Dir$(sAttachmentName, 0) = "")
sNum = Right(StrLeftBack(sAttachmentName, "."), 2)
If IsNumeric(sNum) Then
sTemp = StrLeftBack(sAttachmentName, ".")
sTemp = Left(sTemp, Len(sTemp) - 2)
sAttachmentName = sTemp & Format$(CInt(sNum) + 1, "##00") & _
"." & StrRightBack(sAttachmentName, ".")
Else
sAttachmentName = StrLeftBack(sAttachmentName, ".") & _
"01." & StrRightBack(sAttachmentName, ".")
End If
Wend
Print "Exporting " & sAttachmentName
'Save the file
Call o.ExtractFile( sAttachmentName )
End Sub
So the issue I do have right now is that these attachments are being saved to the same folder, which means that I would manually have to put them into right folders of library (several thousands). Could anyone help on how should I change the above code to have the attachments saved to separate folder for each document from DB?
Also for some reason that I cant find out below line is causing error pop up with "Object Variable not set":
sAttachmentName = sDir & "\" & o.Source
Would anyone know why it causes failure and stops the whole process?
You need to use the MkDir statement to create directory and extract attachments in the folder. Probably write something like:
MkDir sDir
You need to write code that create a new directory for each document (make sure you check if the directory exists, and preferably you make sure each directory has a unique name).
I wrote a tool like that, that exports all the fields of a document into XML, as well as attachments and embedded images. It can be set to separate each document into it's own directory.
You can read more about it ate the link below, perhaps you can get some ideas from the description. I use the UniversalID of teh document to get a unique folder name.
http://www.texasswede.com/websites/texasswede.nsf/Page/Notes%20XML%20Exporter
I have a old VBScript function that save a file copy on the server from the URL. If the file already exists the function deletes the previous version and rewrites a new file version. The problem is that I need to insert case sensitive file names. For instance, the file names "Test.html" and "test.html" should be saved as different copys and my function just replaces them. Any suggestion?
The function:
Public Function SaveToChache(Url, SaveToFolder, FileName)
Dim ChacheFolder: ChacheFolder = SaveToFolder 'Folder where will the cache files be stored (include trailing slash)
Dim FilePath: FilePath = Server.MapPath(ChacheFolder & FileName)
Dim objXMLHTTP: Set objXMLHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
objXMLHTTP.open "GET", Url, false
objXMLHTTP.send()
If objXMLHTTP.Status = 200 Then
Dim objADOStream: Set objADOStream = CreateObject("ADODB.Stream")
objADOStream.Open
objADOStream.Type = 1 'adTypeBinary
objADOStream.Write objXMLHTTP.ResponseBody
objADOStream.Position = 0 'Set the stream position to the start
Dim objFSO: Set objFSO = Createobject("Scripting.FileSystemObject")
If objFSO.FileExists(FilePath) Then objFSO.DeleteFile FilePath
Set objFSO = Nothing
objADOStream.SaveToFile FilePath
objADOStream.Close
Set objADOStream = Nothing
SaveToChache = objXMLHTTP.getResponseHeader("Content-Type")
Else
SaveToChache = ""
End if
Set objXMLHTTP = Nothing
End Function
Calling the function:
savefile = SaveToChache("http://www.example.com", "/cache/", "Test.html")
Thanks!
I would use a direct compare instead of objFSO.FileExists.
for example:
Dim objFSO: Set objFSO = Createobject("Scripting.FileSystemObject")
FilePath = "C:\Test\test.txt"
'Get path to file
strParentPath = objFSO.GetFile(FilePath).ParentFolder
'Get each file in the folder
Set objCheck = objFSO.GetFolder(strParentPath).Files
For Each x In objCheck
If x = FilePath Then objFSO.DeleteFile(FilePath)
Next
Basically, x will only equal FilePath if the case is also the same.
I am working on Classic Asp with VBScript. I am trying to display list of files from a directory with download option. like,
When i click on the download link the corresponding file need to be download for that i have used the following code like,
<html>
<head>
<title> My First ASP Page </title>
</head>
<body>
<%
Dim fso
Dim ObjFolder
Dim ObjOutFile
Dim ObjFiles
Dim ObjFile
'Creating File System Object
Set fso = CreateObject("Scripting.FileSystemObject")
'Getting the Folder Object
Set ObjFolder = fso.GetFolder("F:\karthik")
'Creating an Output File to write the File Names
Set ObjOutFile = fso.CreateTextFile("F:\WindowsFiles.txt")
'Getting the list of Files
Set ObjFiles = ObjFolder.Files
'Writing Name and Path of each File to Output File
Response.Write("<table cellpadding=""4"" cellspacing=""5"" >")
For Each ObjFile In ObjFiles
Response.Write("<tr><td>"&ObjFile.Name & String(50 - Len(ObjFile.Name), " ")&"</td><td>Download</td></tr>")
Next
Response.Write("</table>")
ObjOutFile.Close
%><br>
<script language="vbscript" type="text/vbscript">
Sub HTTPDownload( myURL, myPath )
' Standard housekeeping
Dim i, objFile, objFSO, objHTTP, strFile, strMsg
Const ForReading = 1, ForWriting = 2, ForAppending = 8
' Create a File System Object
Set objFSO = CreateObject( "Scripting.FileSystemObject" )
' Check if the specified target file or folder exists,
' and build the fully qualified path of the target file
If objFSO.FolderExists( myPath ) Then
strFile = objFSO.BuildPath( myPath, Mid( myURL, InStrRev( myURL, "/" ) + 1 ) )
ElseIf objFSO.FolderExists( Left( myPath, InStrRev( myPath, "\" ) - 1 ) ) Then
strFile = myPath
Else
WScript.Echo "ERROR: Target folder not found."
Exit Sub
End If
' Create or open the target file
Set objFile = objFSO.OpenTextFile( strFile, ForWriting, True )
' Create an HTTP object
Set objHTTP = CreateObject( "WinHttp.WinHttpRequest.5.1" )
' Download the specified URL
objHTTP.Open "GET", myURL, False
objHTTP.Send
' Write the downloaded byte stream to the target file
For i = 1 To LenB( objHTTP.ResponseBody )
objFile.Write Chr( AscB( MidB( objHTTP.ResponseBody, i, 1 ) ) )
Next
' Close the target file
objFile.Close( )
End Sub
</script>
</body>
</html>
It seems you are trying to do this on the server-side using client-side scripting. Here is a better solution that uses server-side ASP to send the file. You will need to split your code over two pages.
Your current script should be replaced with this:
<html>
<head>
<title> My First ASP Page </title>
</head>
<body>
<% Dim fso
Dim ObjFolder
Dim ObjOutFile
Dim ObjFiles
Dim ObjFile
'Creating File System Object
Set fso = CreateObject("Scripting.FileSystemObject")
'Getting the Folder Object
Set ObjFolder = fso.GetFolder("F:\karthik")
'Getting the list of Files
Set ObjFiles = ObjFolder.Files
'Writing Name and Path of each File to Output File
Response.Write("<table cellpadding=""4"" cellspacing=""5"" >")
For Each ObjFile In ObjFiles
Response.Write("<tr><td>"&ObjFile.Name & String(50 - Len(ObjFile.Name), " ")&"</td><td>Download</td></tr>")
Next
Response.Write("</table>")
%><br>
</body>
</html>
Then you need to create another script which I have called download.asp which handles the download:
<%
Dim objConn, strFile
Dim intCampaignRecipientID
strFile = Request.QueryString("file")
If strFile <> "" Then
Response.Buffer = False
Dim objStream
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = 1 'adTypeBinary
objStream.Open
objStream.LoadFromFile("F:\karthik\" & strFile)
Response.ContentType = "application/x-unknown"
Response.Addheader "Content-Disposition", "attachment; filename=" & strFile
Response.BinaryWrite objStream.Read
objStream.Close
Set objStream = Nothing
End If
%>
I like this solution, but users can see the downloads in the history, or modify the querystring. This solution can be modified for POST usage this way:
in the page code modify the link:
FileName`
and further down
<form id="frm2dl" action="download.asp" method="post"><input type="hidden" id="file2dl" name="file2dl" value="" /></form>
then in your javascript file get the filename:
function getfile(obj) {
var f=obj.innerText;
$("#frm2dl #file2dl").val(f);
$("#frm2dl").submit();
}
alternately you could use a file ID then in the download.asp have a lookup function from ID to filename.
Then in the download.asp use request.form("file2dl") instead of request.querystring.
UPDATE:
Also, depending on server version you might get the 4MB limit (I have to work with Microsoft-IIS/7.5 on intranet). Therefore for large files the code will not work. Here is my improved version:
Dim strFileName, strFilePath, objFSO, objStream, objFile, intFileSize
Const lChkSize = 524288 ' 500KB - server typical limit is 4MB
'If session("loggedIn") = True Then ' insert your logon validation code here. bypassed for testing
strFileName = request.form("file2dl")
strFilename = Replace(strFilename,"..","") ' prevent parent path navigation - also ensure uploaded files do not contain this sequence
strFilename = Replace(strFilename,"/","") ' prevent path navigation
strFilename = Replace(strFilename,"\","") ' filenames should already be cleaned by a previous process
strFilePath = server.MapPath("/insert your URL absolute sources filepath here/" & strFilename)
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strFilePath) Then
Set objFile = objFSO.GetFile(strFilePath)
intFileSize = objFile.Size
Set objFile = Nothing
Response.AddHeader "Content-Disposition","attachment; filename=" & strFileName
Response.ContentType = "application/x-msdownload"
Response.AddHeader "Content-Length", intFileSize
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = 1 'adTypeBinary
objStream.Open
objStream.LoadFromFile strFilePath
Do While Not objStream.EOS And Response.IsClientConnected
Response.BinaryWrite objStream.Read(lChkSize)
Response.Flush()
Loop
objStream.Close
Set objStream = Nothing
Else
Response.write "Error finding file: " & request.form("file2dl")
End if
Set objFSO = Nothing
'End If
Is there an equivalent to PHP's get_included_files in classic ASP?
No, there is not.
A very ugly function for that:
<!--#include file="include/common.asp"-->
<%
Function GetIncludedFiles()
Dim Url
Dim Fso
Dim Fs
Dim Src
Dim Arr
Dim Ret
Dim i
Set Fso = Server.CreateObject("Scripting.FileSystemObject")
ReDim Ret(-1)
Url = Request.ServerVariables("URL")
Set Fs = Fso.OpenTextFile(Server.MapPath(Url))
Src = Fs.Readall()
Fs.Close
Set Fs = Nothing
Set Fso = Nothing
Arr = Split(Src, "<" & "!--#include file=")
For i = 0 To UBound(Arr)
Arr(i) = Left(Arr(i), InStr(Arr(i), "-->"))
Arr(i) = Replace(Arr(i), "-", "")
Arr(i) = Replace(Arr(i), "'", "")
Arr(i) = Trim(Replace(Arr(i), """", ""))
If Arr(i) <> "" Then
ReDim Preserve Ret(UBound(Ret) + 1)
Ret(UBound(Ret)) = Arr(i)
End If
Next
GetIncludedFiles = Ret
End Function
Dim File
For Each File In GetIncludedFiles()
Response.Write File & "<br />"
Next
%>
The simple way is to create a main file in a specific directory (for example /include/mainfile.asp) and then include all the other files to this file. Something like:
<!#include File="[your directory here/file1.asp]"-->
<!#include File="[your directory here/file2.asp]"-->
<!#include File="[your directory here/file3.asp]"-->
Then, You can include your main file using "virtual" to the rest of your pages that you want to access those other included files.
<!#include Virtual="/include/mainfile.asp"-->
Not as such, but I vaguely remember seen a tool or two floating around that will give you the equivalent report. It might have been on Code Project or somewhere similar... its been a long time since I last ran across it.