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.
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).
Hi I am having some problems with saving img files using Visual Basic, the files are being named wrongly with the folder name being added to the start of the file name.
I parse a web address and then use the split address values to rename my files however the the path value seems to be added to the file as well.
The files in the photo should be named for example "DCAT040iMBE Test13.jpg"
but this file is being name "Test1DCAT040iMBE Test13.jpg"
Protected Sub GeneratedCode()
Dim path As String = "C:\Users\Grey\Documents\visual studio 2010\Projects\QRCodeGenerator\QRCodeGenerator\Output\"
LogoUpload.SaveAs(path + LogoUpload.FileName)
TextFile.SaveAs(path + TextFile.FileName)
Dim lines() As String = IO.File.ReadAllLines(path + TextFile.FileName)
For Each line As String In lines
Dim count As Integer
Dim encoder As New QRCodeEncoder()
encoder.QRCodeErrorCorrect = QRCodeEncoder.ERROR_CORRECTION.H
encoder.QRCodeScale = 10
Dim img As Bitmap = encoder.Encode(line)
Dim logo As System.Drawing.Image = System.Drawing.Image.FromFile(path + LogoUpload.FileName)
Dim left As Integer = (img.Width / 2) - (logo.Width / 2)
Dim top As Integer = (img.Height / 2) - (logo.Height / 2)
Dim g As Graphics = Graphics.FromImage(img)
Dim parseLine = line
Dim replaceDelimiter As String
If Not String.IsNullOrWhiteSpace(line) Then
replaceDelimiter = Replace(line, "&", "=")
End If
Dim fileNameSplit() As String = replaceDelimiter.Split("=")
Dim newFileName As String
Dim partTwo = fileNameSplit(1)
Dim partSix = fileNameSplit(5)
Dim objFSO
Dim newFolder As String
newFolder = "C:\Users\Grey\Documents\visual studio 2010\Projects\QRCodeGenerator\QRCodeGenerator\Output\" + partSix
objFSO = CreateObject("Scripting.FileSystemObject")
If (Not System.IO.Directory.Exists(newFolder)) Then
System.IO.Directory.CreateDirectory(newFolder)
End If
count += 1
g.DrawImage(logo, New Point(left, top))
newFileName = partTwo & " " & partSix & count & ".jpg"
img.Save(newFolder + newFileName, ImageFormat.Jpeg)
amountCreatedLbl.Text = count & " QRCodes Created"
logo.Dispose()
Next
End Sub
Could it be that I am generating my newFolder Values wrongly?
edited to add an example of data from the parsed txt file.
https://mywebsite.com/QRCode/default.aspx?materialcode=DTAT050&Logo=MyLogo&Companyloc=Test1
https://mywebsite.com/QRCode/default.aspx?materialcode=DCAT055iMB&Logo=MyLogo&Companyloc=Test1
https://mywebsite.com/QRCode/default.aspx?materialcode=DCAT040iMBE&Logo=MyLogo&Companyloc=Test1
https://mywebsite.com/QRCode/default.aspx?materialcode=DTAB060&Logo=MyLogo&Companyloc=Test1
https://mywebsite.com/QRCode/default.aspx?materialcode=DTAT050&Logo=MyLogo&Companyloc=Test2
https://mywebsite.com/QRCode/default.aspx?materialcode=DCAT055iMB&Logo=MyLogo&Companyloc=Test2
https://mywebsite.com/QRCode/default.aspx?materialcode=DCAT040iMBE&Logo=MyLogo&Companyloc=Test2
https://mywebsite.com/QRCode/default.aspx?materialcode=DTAB060&Logo=MyLogo&Companyloc=Test2
https://mywebsite.com/QRCode/default.aspx?materialcode=DTAT050&Logo=MyLogo&Companyloc=Test3
https://mywebsite.com/QRCode/default.aspx?materialcode=DCAT055iMB&Logo=MyLogo&Companyloc=Test3
https://mywebsite.com/QRCode/default.aspx?materialcode=DCAT040iMBE&Logo=MyLogo&Companyloc=Test3
https://mywebsite.com/QRCode/default.aspx?materialcode=DTAB060&Logo=MyLogo&Companyloc=Test
Looks like you are missing a slash on the line:
img.Save(newFolder + newFileName, ImageFormat.Jpeg)
It should be:
img.Save(newFolder + "\" + newFileName, ImageFormat.Jpeg)
The program doesn't realize that the newDirectory variable is supposed to be a directory, it's just being concatenated to the filename directly. A better option would be to use:
img.Save(System.IO.Path.Combine(newFolder, newFileName), ImageFormat.Jpeg)
The System.IO.Path.Combine() function automatically adds the missing slash between the directory and filename, as well as some additional checks to make sure the result is valid.
As a side note, I would also recommend using & instead of + when joining strings together. Hard to debug issues can come up when you do it that way. I would also recommend turning Option Strict On, you will see a couple of other warnings that come up with your code as is. But, to resolve your issue, the above will work.
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'm new to asp my code is working absolutely fine, but i am facing two problems although these problems are not affecting the application. I just want to make good functionality to the application logically.
When i upload excel file, if file with the same name it's already present, i overwrite it; if i manually change file name then file is saved with new name.
What i want to do is:
save this new file with unique name or new name, i don’t know how to do this.
save this file in the db with the login user information (for future reference)
i hope my problems will be solved. many thanks
this is the url from which I got help..
CODE
upload_excel.asp
< form action="upload_excel_process.asp" method="post" enctype="multipart/form-data" name="frmMain" onSubmit="return checkData();" >
<input name="file1" type="file"> <input type="submit" name="Submit" value="Submit">
< %mem_id=session("mem_id")%>
< input type="hidden" name="client_id" value="<%=mem_id%>">
< /form>
upload_excel_process.asp
<%client_id=session("mem_id")%>
<%
Dim xlApp,xlBook,xlSheet1,xlSheet2,OpenFile,i
Dim Conn,strSQL,client_id,objExec
Dim mySmartUpload
Dim sFileName
Set mySmartUpload = Server.CreateObject("aspSmartUpload.SmartUpload")
mySmartUpload.Upload
sFileName = mySmartUpload.Files("file1").FileName
If sFileName <> "" Then
mySmartUpload.Files("file1").SaveAs(Server.MapPath("excel/"&sFileName))
OpenFile = "excel/"&sFileName
Set xlApp = Server.CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(Server.MapPath(OpenFile))
Set xlSheet1 = xlBook.Worksheets(1)
Set Conn = Server.Createobject("ADODB.Connection")
Conn.Open "DRIVER=Microsoft Access Driver (*.mdb);DBQ=" & Server.MapPath("../db/database.mdb"),"" , ""
For i = 2 To 5
If Trim(xlSheet1.Cells.Item(i,1)) <> "" Then
strSQL = "" <br>
strSQL = strSQL &"INSERT INTO add_contacts "
strSQL = strSQL &"(client_id,name_receiver,contact_person_receiver,street_receiver,city_receiver, tel_receiver,fax_receiver,country_receiver,zip_code_receiver) "
> i have added fields to the db for file (file_name and file_id)
strSQL = strSQL &"VALUES "
strSQL = strSQL &"('"&client_id&"', '"&xlSheet1.Cells.Item(i,1)&"','"&xlSheet1.Cells.Item(i,2)&"','"&xlSheet1.Cells.Item(i,3) &"'"
strSQL = strSQL &",'"&xlSheet1.Cells.Item(i,4)&"','"&xlSheet1.Cells.Item(i,5)&"','"&xlSheet1. Cells.Item(i,6)&"','"&xlSheet1.Cells.Item(i,7)&"','"&xlSheet1.Cells.Item(i,8)&"')"
Set objExec = Conn.Execute(strSQL)
Set objExec = Nothing
End IF
Next
xlApp.Application.Quit
Conn.Close()
Set Conn = Nothing
Set xlSheet1 = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End If
Set mySmartUpload = Nothing
%>
Cheking of existens
If you want to check if a filename does aleready exists, you have to use the method FileExists from standard FilesystemObject (for more information see http://msdn.microsoft.com/en-us/library/x23stk5t(v=VS.85).aspx ).
So what do have to do?
If sFileName <> "" Then
Dim fullFilePath = Server.MapPath("excel/"&sFileName)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FileExists(filespec)) Then
//Rem Whatever you want to do here
End If
mySmartUpload.Files("file1").SaveAs(fullFilePath)
and so far...
If I understand your question you want to save the file with filename as unique to avoid the overwrite.
The best approach is to check before saving if the file exist in the destination directory or not. If it exists change the file name by appending some unique id like timestamp.
To save the file use saveas method.
strFileName = PMSmartUpload.Files.Item(1).FileName
strFilePath = strFileDirectory & "\" & strFileName
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FileExists(strFilePath)) Then
''rename suffix for file
strDateExt = cstr(month(Date)) +cstr(day(Date))+cstr(year(Date)) +cstr(Hour(Now)) +cstr(Minute(Now)) +cstr(Second(Now))
strFileExtension =fso.GetExtensionName(strFileName)
strFileBaseName = fso.GetBaseName(strFileName)
strFileName = strFileBaseName+"_"+ strDateExt +"."+strFileExtension
End If
'response.write strFileDirectory&"\"&strFileName
PMSmartUpload.Files.Item(1).saveas strFileDirectory&"\"&strFileName
In short the saveas method will save the posted file with specified name(full path)
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