Solved

convert asp to vbs

Posted on 2008-06-23
17
1,563 Views
Last Modified: 2010-04-21
Hello,

I have written an ASP script for the page which has to be scheduled to run every other weakday to get a xml file
from one of the FTP location, process the data and upload it on different server.
The script works fine but to me it dont seems reliable due to various script time out/ IIS issues.
Please can someone advice if it is possible to change the attached script into .vbs file? I would be glad If someone of you could please look into the attached script and also advice me if this can be further optimized.
Your help is much appreciated.
Many thanks for your help.

Regards
Sam
0
Comment
Question by:newbie27
  • 8
  • 7
  • 2
17 Comments
 
LVL 8

Author Comment

by:newbie27
Comment Utility
please have the script attached
thanks for looking
regards
sam
load_data.asp

-------------

<%@ Language=VBScript %>

<!--#include file="adovbs.inc"-->

<!--#include file="MD5.asp"-->

<%

t1=timer

server.scripttimeout = 1000000

Dim cnObj, rsObj, strSQL, cmdObj, iCntr, k, sLog
 

Set cnObj = server.createobject("ADODB.Connection")

set rsObj = server.createobject("ADODB.Recordset")
 

cnObj.open = "DRIVER={MySQL ODBC 5.1 Driver};"_

& "SERVER=localhost;"_

& "DATABASE=mysql;"_

& "UID=root;"_

& "PWD=root;"
 

If FTPServer = "" Then FTPServer = "XXX.XXX.XXX.XXX"

If ftpUserName = "" Then ftpUserName = "username"

If ftpPassword = "" Then ftpPassword = "pwd"
 

sLog = "Loading started " & now()  

'response.Write sLog

sTodaysDate = getTodaysDate(date)   ' to get the date in yyyymmdd format

call WriteFile("e:\tbp\logs\loadLogs"&sTodaysDate&".txt", sLog)
 
 

ftpDirectory = "/pnk/dtSearch/StockFiles/Foyles/data"

OutFolder ="E:\tbp\www\foyles\Data"

OutFile="foylesweb*.csv"

FTPGetOrPut="getFile"
 

ftpResult = FTPToServer(FTPServer, FTPDirectory, FTPuserName, FTPPassword, OutFile, FTPGetOrPut)

If ftpResult Then

    sLog = sLog & OutFile & " has been downloaded to " & FTPServer

   call AppendFile(sLog) 

   'Rename the .txt file we are getting from the FTP location

    'RenameFile

    'Before we start the new Load, archive the existing data into foyles_yesterday_data table    

    sArchiveFoylesData = archiveFoylesData()

Else

	sLog = sLog & OutFile & " could not be downloaded from the FTP server - " & FTPServer

	call AppendFile(sLog) 

   Response.End 

End If

          

 

'Load new CSV file into the foyles_data table

If sArchiveFoylesData = "OK" Then

     sLog =  "Archived Foyles Data to the Foyles_Yesterday_Data, cleaned Foyles_Data for the fresh load. "  

    call AppendFile(sLog)

    sloadData = loadData()

End If
 

RemoteServer="http://213.253.134.26"

  

If sloadData = "OK" Then   

   sLog =  "Load Successful !!"

   call AppendFile(sLog)

    sAppendLoadData = appendLoadData()

    If sAppendLoadData = "OK" Then    

        sLog = "Data from the temp table added to the Foyle_data table successfully ! "

        call AppendFile(sLog)        

        Set cmdObj= Server.CreateObject("ADODB.Command")

        cmdObj.ActiveConnection = cnObj

        cmdObj.CommandText = "sp_foyles_data"

        cmdObj.CommandType = 4
 

        Set rsObj=cmdObj.Execute

        while not rsObj.EOF 

          ISBN = rsObj("isbn")

          foyles_dp = rsObj("foyles_dp")  

          gard_stock =rsObj("gard_stock")  

          gard_cp =rsObj("gard_cp")

          gard_rrp =rsObj("gard_rrp")

          bert_stock =rsObj("bert_stock")

          bert_cp =rsObj("bert_cp")

          bert_rrp =rsObj("bert_rrp")

          foyles_rrp =rsObj("foyles_rrp")

          foyles_stock =rsObj("foyles_stock")

          foyles_cp =rsObj("foyles_cp")

          isbn_title = rsObj("title")

          

        ' Storing into HASH column to check if the data has changed

        sHash = ISBN&foyles_rrp&bert_rrp&gard_rrp&foyles_cp&gard_cp&bert_cp&foyles_dp
 

        MyMD5Hash=MD5(sHash)
 

        If ISBN <> "" then   
 

            prevHash=getPreviousHash(ISBN)

            

               If MyMD5Hash <> prevHash then    

                ' Check for Deep Discounts 

	                If isDeepDiscount(ISBN) <> "" Then

		                FDP = isDeepDiscount(ISBN)

	                ElseIf foyles_dp  <> "" Then

                ' Check for Foyles Discount Price

		                FDP = foyles_dp		

	                Else

                ' Check the Prices..

	                ' If Gardners RRP present then work out if there is a Discount as well

		                If gard_rrp <> "0" Then

			                x = SupplierCalc(gard_stock, gard_cp, gard_rrp, GardRRP, GardFDP)

			                FDP = GardFDP

	                ' If Bertrams RRP present then work out if there is a Discount as well

		                ElseIf bert_rrp <> "0" Then

			                x = SupplierCalc(bert_stock, bert_cp, bert_rrp, BertRRP, BertFDP)

			                FDP = BertFDP

		                ElseIf foyles_rrp <> "0" Then

	                ' If Foyles RRP present then work out if there is a Discount as well

			                x = SupplierCalc(foyles_stock, foyles_cp, foyles_rrp, FoylRRP, FoylFDP)

			                If foyles_stock > 0 Then

				                FDP = FoylFDP

			                End If

		                Else

			                FDP = ""

		                End If

	                End IF

                ' End oF Discount calcs,  nOW work out the RRP

                 		

		               	If gard_rrp <> "0" Then

							RRP = gard_rrp

				       	End IF 

				       	If bert_rrp <> "0" Then

							RRP = bert_rrp

		        	   	End IF 
 

		               ' If RRP = "" Then

		               '    rURL = RemoteServer & "/xmla/xml_results.asp?dbm=uk3&isbn=" & ISBN

                       '    y = GetXML(rUrl)

                       '    RRP= XMLField(y, "fv_uk_vat_price", false)

		               ' End If

				

		                If foyles_rrp > RRP Then

			                RRP = foyles_rrp

		                End If

			

		

				' Finally..

                        RRP = CalculatePrice(ISBN, "RRP", RRP,"")

		                If RRP <> "" Then

			                RRP = RRP	        

		                End If

                		

		                FDP = CalculatePrice(ISBN, "FDP", "" , FDP)

		                If FDP <> "" Then

			                FDP = FDP	

			                If isDeepDiscount(ISBN) <> "" Then

				                d_disc = "Y"

			                End IF

		                End If

                    

                    title = getTitle(ISBN)

                    

                    If Instr(title,"No Title Found")> 0 Then

                           rURL = RemoteServer & "/xmla/xml_results.asp?dbm=uk3&isbn=" & ISBN

                           x = GetXML(rUrl)

                           title= XMLField(x, "fv_ctitle", false)

                           If title <> "" Then 

                                call updateTitles(ISBN,title)

                           Else

                                title = "No Title Found"     

                           End If                                                         

                    End If

				   

                    If Instr(prevHash,"New Record")> 0 Then					

                        sAction = "Record Added"                

                    Else

                        sAction = "Record Updated"

                    End If

                    

                    'response.Write "RRP= " & RRP & "FDP=" & FDP & "Deep Discount=" & deep_discount & "<br>"             

                    If RRP <> "" OR FDP <>"" OR d_disc <>"" Then        

                        call(updateRecords(ISBN,RRP,FDP,d_disc,MyMD5Hash,title,sAction))

                    End If

           End If 

                    

            emptyVariables

            rsObj.movenext

                       

        End if    

        Wend        

       

    Else

        sLog = "Unable to append data "           

        call AppendFile(sLog)        

       

    End If

    

Else

    sLog = "Unable to Load Data.... There is some problem ! "       

    call AppendFile(sLog)        

       

End If

   
 

t2 = timer 

sLog = "Total time: [" & BDFormatCurrency((t2-t1)/60) & " Minutes]" & VbCrLf  & now()

call AppendFile(sLog)        
 

sExportInStockData  = exportInStockData()

If sExportInStockData = "OK" Then     

    sLog = "In stock data exported to the Foyles_Export_Data table succesffully.."

    sExportData = exportData()

    If sExportData="OK" Then    

      sLog = "AWExport In-stock data Sucess.."

      call AppendFile(sLog)        

           

            sloadTempData = loadTempData

            If sloadTempData="OK" Then

                sLog = "Data loaded into the foyles_temp_data table"  

                call AppendFile(sLog)        

            End IF

    Else

      sLog = "Unable to export !"  

      call AppendFile(sLog)        

           

    End If

Else

   sLog = "Unable to export In Stock data to the table.."       

   call AppendFile(sLog)   

End If
 

If sExportData = "OK" Then

    ftpDirectory = "/pne/tbp/DATA/Foyles/Download/AWe"

    OutFolder ="E:\tbp\www\foyles\Data"

    OutFile="Foyles-AWExport.csv"

    FTPGetOrPut="putFile"
 

    ftpResult = FTPToServer(FTPServer, FTPDirectory, FTPuserName, FTPPassword, OutFile, FTPGetOrPut)

    If ftpResult Then

        sLog =  OutFile & " has been FTPed to " & FTPServer

        call AppendFile(sLog) 

        'Before we start the new Load, archive the existing data into foyles_yesterday_data table

        sArchiveFoylesData = archiveFoylesData()

    Else

	    sLog =  OutFile & " could not be transfered to the FTP server - " & FTPServer

	    call AppendFile(sLog) 

        Response.End 

    End If

End If
 

sLog = "Loading done..." & now() 

call AppendFile(sLog)

        

set rsDiscObj = nothing

set rsTitleObj = nothing

set rsHashObj = nothing

Set cnObj = nothing 
 

'*******************************************************************************

'###############################################################################
 

Function CalculatePrice(ISBN, pType, pRRP, pFDP)

Dim RRP, FDP, parts, p, CurrencySymbol, ExRate

Dim GardFDP, GardRRP, BertRRP, BertFDP, FoylRRP, FoylFDP
 

	'CurrencySymbol = "£"

	IF ExRate = "" Then ExRate = 1
 

if pRRP <> "" then

   RRP = pRRP

end if

if pFDP <> "" then

  FDP = pFDP

end if     
 
 

' Finally..

	If Trim(Lcase(pType)) = "rrp" Then

		If RRP <> "" Then			

			CalculatePrice = BDFormatCurrency(RRP*ExRate)

		End If

	ElseIf Trim(Lcase(pType)) = "fdp" Then

		If FDP <> "" Then

			CalculatePrice = BDFormatCurrency(FDP*ExRate)

		End If

	Else

		CalculatePrice = ""

	End If

 'response.Write "CalucaltePrice=" & CalculatePrice & "<br>"

	

End Function
 

'*******************************************************************************

'###############################################################################
 

Function SupplierCalc(StockLevel, CostPrice, RRP, ByRef SupplierRRP, ByRef SupplierFDP)

Dim Diff, pDiff, cDiff
 

		If CostPrice = "" Then

			CostPrice = 0

		End If	

		

		Diff = RRP - CostPrice

		'response.write "<!-- (" & RRP & "-" &  CostPrice & ")[" & Diff & "] -->" & VbCrLF

		If Diff > 0 And CostPrice <> 0 Then

			pDiff = (Diff/RRP) * 100

		Else

			pDiff = 0

		End If

		'response.write "<!-- Percent Off [" & BDFormatCurrency(pDiff) & "%] -->" & VbCrLF

		If pDiff >= 47.9 Then

			cDiff = 24

		ElseIf pDiff >= 45 Then

			cDiff = 24

		ElseIf pDiff >= 40 Then

			cDiff = 15

		ElseIf pDiff >= 33 Then

			cDiff = 7.5

		Else 

			cDiff = 0

		End IF

		'response.write "<!-- Customer Discount [" & cDiff & "%] -->" & VbCrLF

		IF cDiff > 0 Then

			SupplierRRP = BDFormatCurrency(RRP)

			SupplierFDP = BDFormatCurrency(RRP * ((100 - cDiff)/100))

		Else

			SupplierRRP = BDFormatCurrency(RRP)

			SupplierFDP = ""

		End If

		

End Function

'*******************************************************************************

'###############################################################################

FUNCTION BDFormatCurrency(TheAmount)

	

	BDFormatCurrency = TheAmount

	If Not IsNull(TheAmount) And IsNumeric(TheAmount) Then

		BDFormatCurrency = cstr(cdbl(BDFormatCurrency) + 0.00001)		

		If BDFormatCurrency = "0" Then

			BDFormatCurrency = "0.00"

		Else

			BDFormatCurrency = left(BDFormatCurrency,instr(BDFormatCurrency,".")+2)

		End If

	End If 
 

END FUNCTION

'*******************************************************************************

'###############################################################################

Sub updateRecords(sIsbn, sFinalRrp, sFinalFdp, sDeepDisc, sHash, sTitle, sAction)

  

strUpdateQuery = "UPDATE foyles_data SET " &_

                 " final_rrp ='" & sFinalRrp & "',final_fdp='" & sFinalFdp & "'" &_

                 ",deep_discount='" & sDeepDisc & "'" &_

                 ",title='" & SqlEncode(sTitle) & "'" &_             

                 ",hash_stamp='" & sHash & "'" &_                 

                 ",time_stamp=UNIX_TIMESTAMP(CURDATE())"&_    

                 ",action='" & sAction & "'" &_    

                 " WHERE isbn='" & sIsbn & "'"
 

'response.Write "new=" & strUpdateQuery  & "<br>"

cnObj.Execute(strUpdateQuery)
 

End Sub

'*******************************************************************************

'###############################################################################
 
 

Function isDeepDiscount(ISBN)

    strQuery = "SELECT price FROM foyles_deep_discount WHERE isbn='"&ISBN&"'"

    Set rsDiscObj=cnObj.Execute(strQuery)

    If Not rsDiscObj.EOF then    

        isDeepDiscount = rsDiscObj("price")

    else

        isDeepDiscount = ""

    end if    

End Function

'*******************************************************************************

'###############################################################################
 
 

Function getTitle(ISBN)

    strQuery = "SELECT title FROM foyles_titles WHERE isbn='"&ISBN&"'"

    Set rsTitleObj=cnObj.Execute(strQuery)

    If Not rsTitleObj.EOF then    

        getTitle = rsTitleObj("title")

    else

        getTitle = "No Title Found"

    end if    

End Function

'*******************************************************************************

'###############################################################################
 

Function SqlEncode(ByVal strValue)

   SqlEncode = Replace(Replace(strValue, "\", "\\"), "'", "\'")

End Function
 

'*******************************************************************************

'###############################################################################
 

Sub emptyVariables

    RRP=""

    FDP=""

    d_disc=""

    title=""

    stimeStamp=""

    sAction=""

   

End Sub    

'*******************************************************************************

'###############################################################################
 

Function getPreviousHash(ISBN)

    hashQuery = "SELECT hash_stamp FROM foyles_data WHERE isbn='"&ISBN&"'"

    Set rsHashObj = cnObj.Execute(hashQuery)

    If Not rsHashObj.EOF Then

        getPreviousHash = rsHashObj("hash_stamp")

    Else

        getPreviousHash = "New Record"    

    End If

End Function
 

'*******************************************************************************

'###############################################################################
 

Function loadData()
 

    strSql= "LOAD DATA LOCAL INFILE 'e:/tbp/www/foyles/data/foylesweb.csv'" &_

         " INTO TABLE foyles_data " &_

         " FIELDS TERMINATED BY ',' " &_

         " LINES TERMINATED BY '\r\n' " &_        

         " (wco,isbn,foyles_stock,foyles_rrp,foyles_dp,foyles_cp,bert_stock,bert_rrp,bert_cp,gard_rrp,gard_stock,gard_cp,weight);"
 

    cnObj.Execute(strSql)

    

    If err.number <> 0 Then

       loadData = err.Description       

    Else

       loadData = "OK"       

    End If

    

End Function

'*******************************************************************************

'###############################################################################
 
 

Function appendLoadData()

'To fetch Title,Hash_Stamp,Unix_DateStamp,Final_RRP etc

    Set cObj= Server.CreateObject("ADODB.Command")

    cObj.ActiveConnection = cnObj

    cObj.CommandText = "sp_foyles_data_update"

    cObj.CommandType = 4

    cObj.Execute

    

    If err.number <> 0 then

        appendLoadData = err.Description 

    Else

        appendLoadData = "OK"    

    End If

    

    Set cObj = Nothing

End Function

'*******************************************************************************

'###############################################################################
 

Function exportInStockData()
 

    Set cObj= Server.CreateObject("ADODB.Command")

    cObj.ActiveConnection = cnObj

    cObj.CommandText = "sp_export_data"

    cObj.CommandType = 4

    

    cObj.Execute

    

    If err.number <> 0 then

        exportInStockData = err.Description 

    Else

        exportInStockData = "OK"    

    End If

    

    Set cObj = Nothing     

    

End Function

'*******************************************************************************

'###############################################################################
 

Function exportData()
 

    strExportSql= " SELECT 'Product_Id','Product_Name','Merchant_Category','Deep_Link','Price','Date_stamp','Jacket' UNION " &_

				  " SELECT product_id,product_name,merchant_category,deep_link,price,date_stamp,jacket INTO OUTFILE 'e:/tbp/www/foyles/data/Foyles-AWExport.csv'" &_

                  " FIELDS TERMINATED BY '|' " &_

                  " LINES TERMINATED BY '\r\n' " &_        

                  " FROM foyles_export_data;"

    'response.Write strExportSql

    'response.End 

    cnObj.Execute(strExportSql)

    

    If err.number <> 0 Then

       exportData = err.Description       

    Else

       exportData = "OK"       

    End If

    

End Function

'*******************************************************************************

'###############################################################################
 

Function loadTempData()
 

    Set cObj= Server.CreateObject("ADODB.Command")

    cObj.ActiveConnection = cnObj

    cObj.CommandText = "sp_load_temp_data"

    cObj.CommandType = 4

    

    cObj.Execute

    

    If err.number <> 0 then

        loadTempData = err.Description 

    Else

        loadTempData = "OK"    

    End If

    

    Set cObj = Nothing     

    

End Function

'*******************************************************************************

'###############################################################################
 

Function archiveFoylesData()
 

    Set cObj= Server.CreateObject("ADODB.Command")

    cObj.ActiveConnection = cnObj

    cObj.CommandText = "sp_archive_foyles_data"

    cObj.CommandType = 4

    

    cObj.Execute

    

    If err.number <> 0 then

        archiveFoylesData = err.Description 

    Else

        archiveFoylesData = "OK"    

    End If

    

    Set cObj = Nothing     

End Function

'*******************************************************************************

'###############################################################################
 

FUNCTION WriteFile(FileName, blob)

     

Dim FSO, File

	On Error Resume Next

	WriteFile = False

	Set FSO = CreateObject("Scripting.FileSystemObject")

	Set File = FSO.CreateTextFile(FileName, True)

	If Err.Number = 0 Then

		File.Write blob

		File.Close

		If Err.Number = 0 Then

			WriteFile = True

		End If

	Else

		'response.write "<br>" & "Error creating file; [" & Err.Description & "]"

	End If

	Err.Clear

	Set File = Nothing

	Set FSO = Nothing

	

END FUNCTION

'*******************************************************************************

'###############################################################################
 

Sub AppendFile(fileText)

 Dim fs, f, txtStream

   Const ForAppending = 8

 

   Set fs = Server.CreateObject("Scripting.FileSystemObject")

  

   if (fs.FileExists("E:\tbp\logs\loadLogs"&sTodaysDate&".txt")) = True Then

       FileName = "E:\tbp\logs\loadLogs"&sTodaysDate&".txt"       

    Set f = fs.GetFile(FileName)

    Set txtStream = f.OpenAsTextStream(ForAppending)

      txtStream.WriteLine

      txtStream.WriteLine (fileText)        

   end if

    txtStream.Close

    

End Sub
 

'*******************************************************************************

'###############################################################################
 

Sub RenameFile
 

    Dim objFSO, Folder, File, SourceFile, DestFile 

    Set objFSO = server.CreateObject("Scripting.FileSystemObject")

    Set Folder = objFSO.GetFolder("E:\tbp\www\foyles\data")    

    For Each File In Folder.Files 

      If Right(File.Name,3) = "txt" Then

            If objFSO.FileExists(folder&"\foylesweb.csv") Then

                objFSO.DeleteFile(folder&"\foylesweb.csv")

                objFSO.moveFile File, folder &"\foylesweb.csv"

            End If

      ElseIf Right(File.Name,3) = "csv" Then

             If objFSO.FileExists(folder&"\Foyles-AWExport.csv") Then

                objFSO.DeleteFile(folder&"\Foyles-AWExport.csv")                

             End If

      End If

      

    Next

    Set objFSO = Nothing

    

End Sub

'*******************************************************************************

'###############################################################################
 

Function getTodaysDate(MyVariable)

    ' to change the date format to yyyymmdd

    varFld = CDate(MyVariable)

    intMonth = Month(varFld)

    intDay = Day(varFld)

    intYr = Year(varFld)
 

    If intMonth < 10 Then

    strMonth = "0" & CStr(intMonth)

    Else

    strMonth = CStr(intMonth)

    End If
 

    If intDay < 10 Then

    strDay = "0" & CStr(intDay)

    Else

    strDay = CStr(intDay)

    End If
 

    strYr = Right(CStr(intYr), 4) ' And change the 4 to 2 for 2 year dates.
 

    getTodaysDate = CStr(strYr & strMonth & strDay )
 

End Function

'*******************************************************************************

'###############################################################################
 

FUNCTION GetXML(rURL)

Dim objHttp, RemoteOutput, sResolve, sConnect, sSend, sReceive, SecondsOut
 

	'on error resume next

	SecondsOut = 25  ' How many seconds to wait for responsefrom XMLA

	rURL = Replace(rURL, "http://", "")

	rURL = "http://" & rURL

	

	Set objHttp = CreateObject("MSXML2.ServerXMLHTTP")

	sResolve = SecondsOut * 1000: sConnect = SecondsOut * 1000: sSend = SecondsOut * 1000: sReceive = SecondsOut * 1000

	objHttp.SetTimeouts sResolve, sConnect, sSend, sReceive

	objHttp.Open "POST", rUrl, False

	objHttp.Send

	If Err.Number = 0 Then

		GetXML = objHttp.ResponseText

	Else

		Response.write "<!-- xproxy failed to retrieve XML -->"

	End if

	Set objHttp = Nothing

	

END FUNCTION

'*******************************************************************************

'###############################################################################
 

Function XMLField(ByVal XMLText, FieldName, ire)

' 2007-06-03: Retrieves one or more values for the submitted FieldName separated by pipes '|'

' 2007-07-25: Includes Attribute fix & returns Attr parameter (if declared as Global Variable).

' 2007-11-28: Includes Case fix & CDATA cleanup & short form element tags "<br />" handler

	

Dim fieldlist, fl

Dim CurrentText, FieldData
 

	CurrentText = XMLText

	FieldName = Replace(FieldName, "\", "/")	'"

	fieldlist = Split(FieldName, "/")

	For each fl in fieldlist

		FieldData = ExtractXMLField(CurrentText, fl, ire)

		CurrentText = FieldData

		'msg(CurrentText)

	Next

	

' Tidy

	If ire = False then

		FieldData = Replace(FieldData, "<![CDATA[", "")

		FieldData = Replace(FieldData, "]]>", "")

	End If

	

	XMLField = FieldData
 

End Function
 

'*******************************************************************************

'###############################################################################
 

Function ExtractXMLField(ByVal XMLText, ElementName, ire)

Dim FieldName, pos1, pos2, StartTag, EndTag, StartPointer

Dim FieldData, FieldDelimiter
 

	StartPointer = 1

	FieldDelimiter = "|"

	FieldName = lcase(ElementName)

	If Instr(1, XMLText, "<"&FieldName&" ", 1) > 0 Then

		' you know the Element has an attribute

		StartTag = "<" & FieldName & " "

		EndTag = "</" & Replace(FieldName, " ", "") & ">"

		' This should find short version elements eg <br /> without breaking the rest of the script. Hah!!

		If instr(1, XMLText, EndTag, 1) < 1 Then 

			' Enter here a list of HTML tags you might want to retrieve which end ">" [i.e. deprecated ones!]

			If instr(1, "<img", Trim(StartTag), 1) > 0 Then

				EndTag = ">"

			Else

				EndTag = "/>"

			End If

		End If

	Else

		StartTag = "<" & FieldName & ">"

		EndTag = "</" & FieldName & ">"

	End If

	'msg("Tags: [" & StartTag & "] [" & EndTag & "]")

	

	pos1 = 0

	Do While (pos1 < Len(XMLText))

		pos1 = instr(StartPointer, XMLText, StartTag, 1)

		'pos2 = instr(StartPointer, XMLText, EndTag, 1)

		' Added next line and changed pos2 to start from pos1 for short version tags like <img src="blah" />

		if pos1 = 0 Then exit Do

		pos2 = instr(pos1, XMLText, EndTag, 1)

		'msg("pos1=" & pos1 & "  " & "pos2=" & pos2)

		if pos1 > 0 AND pos1 < pos2 then 

			' what we normally expect

			If ire = True Then

				' include the requested element tags in the return

				AttributeLength = (Instr(pos1+Len(StartTag)-1, XMLText, ">")) - (pos1+Len(StartTag)) + 1

				If AttributeLength > 0 Then

					Attr = Attr & Mid(XMLText, pos1+Len(StartTag), AttributeLength-1) & FieldDelimiter

				End If

				FieldData = FieldData & Mid(XMLText, pos1, (pos2 + Len(EndTag)) - Pos1) & FieldDelimiter

			Else

				'return just the contents

				If Right(StartTag, 1) <> ">" Then

					AttributeLength = (Instr(pos1+Len(StartTag)-1, XMLText, ">")) - (pos1+Len(StartTag)) + 1

					If AttributeLength > 0 Then

						Attr = Attr & Mid(XMLText, pos1+Len(StartTag), AttributeLength-1) & FieldDelimiter

					End If

					FieldData = FieldData & Mid(XMLText, pos1+Len(StartTag)+AttributeLength, (pos2)-(pos1+Len(StartTag)+AttributeLength)) & FieldDelimiter

				Else

					FieldData = FieldData & Mid(XMLText, pos1+Len(StartTag), (pos2)-(pos1+Len(StartTag))) & FieldDelimiter

				End If

			End if

			StartPointer = pos2 + Len(EndTag)

		ElseIf pos1 <= 0 Or pos2 <= 0 Then

			' Either No Starttag or No EndTag or Neither of them

			' The value is either empty or meaningless

			Exit Do

		End if

	Loop

	If Right(FieldData, 1) = FieldDelimiter Then FieldData = Left(FieldData, Len(FieldData)-1)

	If Right(Attr, 1) = FieldDelimiter Then Attr = Left(Attr, Len(Attr)-1)

	ExtractXMLField = FieldData
 

End Function

'*******************************************************************************

'###############################################################################
 

Sub updateTitles(sIsbn, sTitle)
 

strInsertQuery = "INSERT INTO foyles_titles(isbn,title)" & _

                 " VALUES('" & sIsbn & "','" & SqlEncode(sTitle) & "')" & _

                 " ON DUPLICATE KEY UPDATE title='" & SqlEncode(sTitle) & "'"  

cnObj.Execute(strInsertQuery)
 

End Sub

'*******************************************************************************

'###############################################################################
 

Function FTPToServer(byval ftpServer, byVal ftpDirectory, Byval ftpUserName, byVal ftpPassword, byVal ftpFile, byVal ftpCommand)

	

	' This script assumes the file to be FTP'ed is in the same directory as this script.

	' It should be obvious how to change this (*hint* change the lcd line)

	' You may specify a wildcard in ftp_files_to_put (e.g. *.txt)

	Dim objFSO, objTextFile, oScript, oScriptNet, oFileSys, oFile, strCMD, strTempFile, strCommandResult
 

	On Error Resume Next

	Set oScript = CreateObject("WSCRIPT.SHELL")

	Set oFileSys = CreateObject("Scripting.FileSystemObject")

	Set objFSO = CreateObject("Scripting.FileSystemObject")

	' Build our ftp-commands file

	Set objTextFile = objFSO.CreateTextFile(OutFolder & "/aws.ftp")

	objTextFile.WriteLine "lcd " & OutFolder

	objTextFile.WriteLine "open " & ftpServer

	objTextFile.WriteLine ftpUserName

	objTextFile.WriteLine ftpPassword

	

	' Check to see if we need to issue a 'cd' command

	If ftpDirectory <> "" Then

	   objTextFile.WriteLine "cd " & ftpDirectory

	End If

	

	objTextFile.WriteLine "prompt"

	

	' If we want to download a file then we use 'get' else 'put' to upload the file

	

	If Instr(ftpCommand,"getFile") > 0 Then

	    objTextFile.WriteLine "mget " & ftpFile

	ElseIf Instr(ftpCommand,"putFile") > 0 Then

	    objTextFile.WriteLine "put " & ftpFile     

	End If

	objTextFile.WriteLine "bye"

	objTextFile.Close

	Set objTextFile = Nothing

	' Use cmd.exe to run ftp.exe, parsing our newly created command file

	strCMD = "ftp.exe -s:" & OutFolder & "/aws.ftp"	

	

	strTempFile = "C:\" & oFileSys.GetTempName( )	'"

	

	

	' Pipe output from cmd.exe to a temporary file 

	Call oScript.Run ("cmd.exe /c " & strCMD & " > " & strTempFile, 0, True) 

	Set oFile = oFileSys.OpenTextFile (strTempFile, 1, False, 0)

	

	On Error Resume Next

	' Grab output from temporary file

	strCommandResult = oFile.ReadAll

	'response.write strCommandResult

	oFile.Close

	' Delete the temporary & ftp-command files

	Call oFileSys.DeleteFile( strTempFile, True )

	Call objFSO.DeleteFile( OutFolder & "/aws.ftp", True )

	Set oFileSys = Nothing

	Set objFSO = Nothing

	' Print result of FTP session to screen

	If Instr(strCommandResult, "226 Transfer complete.") > 0 Then

		FTPToServer = True

	Else

		FTPToServer = false

	End If

	

End Function
 

'*******************************************************************************

Function GetLoadFiles(folderspec, FilePattern)

Dim folder, files, file, fn, ft, fnp, ftp

Dim Matchstr, x

   

   	msg("Finding files matching pattern ["& FilePattern & "]")

	FilePattern = replace(FilePattern, "*", "")

	If FilePattern = "" then 

		FilePattern = "*.*"

		msg("..defaulting to file pattern [*.*]")

	End If

	If instr(FilePattern, ".") > 0 then

		fnp = Left(FilePattern, InstrRev(FilePattern, ".")-1)

		ftp = Right(FilePattern, Len(FilePattern) - InstrRev(FilePattern, "."))

	Else

		fnp = FilePattern

		ftp = "*"

	End If

	If fnp = "" then fnp = "*": If ftp = "" then ftp = "*"

	'msg("fnp [" & fnp & "] " & "ftp [" & ftp & "]")

	

	Set fso = server.CreateObject("Scripting.FileSystemObject")

	Set folder = fso.GetFolder(folderspec)

	Set files = folder.Files

	For Each file in files

		MatchName = 0: MatchType = 0

		If instr(file.Name, ".") > 0 then

			fn = Left(file.Name, InstrRev(file.Name, ".")-1)

			ft = Right(file.Name, Len(file.Name) - InstrRev(file.Name, "."))

		End If

		'msg("fn [" & fn & "] " & "ft [" & ft & "]")

		

		' Does the File.name contain the fnp?

		If instr(lcase(fn), Lcase(fnp)) > 0 Or fnp = "*" then

			MatchName = MatchName + 1

		End if

		' Does the FileType contain the ftp?

		If instr(lcase(ft), lcase(ftp)) > 0 Or ftp = "*" then

			MatchType = MatchType + 1

		End if
 

		'msg("MatchType: [" & MatchType & "] " & "MatchName: [" & matchName & "] Filename: [" & file.name & "] fnp: [" & fnp & "] ftp: [" & ftp &"]")

		

		If MatchType = 1 And MatchName = 1 Then

			GetLoadFiles = GetLoadFiles & file.Name & "|"

		Else

			'

		End if
 

	Next

	If right(GetLoadFiles, 1) = "|" Then GetLoadFiles = Left(GetLoadFiles, len(GetLoadFiles)-1)

	

End Function

'###############################################################################

Function DeleteFile(PathAndName)

Dim x
 

	On Error Resume Next

	Set FSO = Server.CreateObject("Scripting.FileSystemObject")

	DeleteFile = False

	If (fso.FileExists(PathAndName)) Then

	   x = fso.DeleteFile(PathAndName, true)

	Else

		msg("File not found..["& PathAndName & "]")

	End If

	If Err.Number = 0 then

		DeleteFile = true

	Else

		msg("ERROR: Deleting File [" & PathAndName & "]: [" & Err.Description & "]")

	End if

	Set FSO = Nothing

	

End Function

'###############################################################################

%>

md5.asp

-------

<%

Private Const BITS_TO_A_BYTE=8

Private Const BYTES_TO_A_WORD=4

Private Const BITS_TO_A_WORD=32

Private m_lOnBits(30)

Private m_l2Power(30)

m_lOnBits(0)=CLng(1)

m_lOnBits(1)=CLng(3)

m_lOnBits(2)=CLng(7)

m_lOnBits(3)=CLng(15)

m_lOnBits(4)=CLng(31)

m_lOnBits(5)=CLng(63)

m_lOnBits(6)=CLng(127)

m_lOnBits(7)=CLng(255)

m_lOnBits(8)=CLng(511)

m_lOnBits(9)=CLng(1023)

m_lOnBits(10)=CLng(2047)

m_lOnBits(11)=CLng(4095)

m_lOnBits(12)=CLng(8191)

m_lOnBits(13)=CLng(16383)

m_lOnBits(14)=CLng(32767)

m_lOnBits(15)=CLng(65535)

m_lOnBits(16)=CLng(131071)

m_lOnBits(17)=CLng(262143)

m_lOnBits(18)=CLng(524287)

m_lOnBits(19)=CLng(1048575)

m_lOnBits(20)=CLng(2097151)

m_lOnBits(21)=CLng(4194303)

m_lOnBits(22)=CLng(8388607)

m_lOnBits(23)=CLng(16777215)

m_lOnBits(24)=CLng(33554431)

m_lOnBits(25)=CLng(67108863)

m_lOnBits(26)=CLng(134217727)

m_lOnBits(27)=CLng(268435455)

m_lOnBits(28)=CLng(536870911)

m_lOnBits(29)=CLng(1073741823)

m_lOnBits(30)=CLng(2147483647)
 

m_l2Power(0)=CLng(1)

m_l2Power(1)=CLng(2)

m_l2Power(2)=CLng(4)

m_l2Power(3)=CLng(8)

m_l2Power(4)=CLng(16)

m_l2Power(5)=CLng(32)

m_l2Power(6)=CLng(64)

m_l2Power(7)=CLng(128)

m_l2Power(8)=CLng(256)

m_l2Power(9)=CLng(512)

m_l2Power(10)=CLng(1024)

m_l2Power(11)=CLng(2048)

m_l2Power(12)=CLng(4096)

m_l2Power(13)=CLng(8192)

m_l2Power(14)=CLng(16384)

m_l2Power(15)=CLng(32768)

m_l2Power(16)=CLng(65536)

m_l2Power(17)=CLng(131072)

m_l2Power(18)=CLng(262144)

m_l2Power(19)=CLng(524288)

m_l2Power(20)=CLng(1048576)

m_l2Power(21)=CLng(2097152)

m_l2Power(22)=CLng(4194304)

m_l2Power(23)=CLng(8388608)

m_l2Power(24)=CLng(16777216)

m_l2Power(25)=CLng(33554432)

m_l2Power(26)=CLng(67108864)

m_l2Power(27)=CLng(134217728)

m_l2Power(28)=CLng(268435456)

m_l2Power(29)=CLng(536870912)

m_l2Power(30)=CLng(1073741824)
 

Private Function LShift(lValue,iShiftBits)

  If iShiftBits=0 Then

    LShift=lValue

    Exit Function

  ElseIf iShiftBits=31 Then

    If lValue And 1 Then

      LShift=&H80000000

    Else

      LShift=0

    End If

    Exit Function

  ElseIf iShiftBits<0 Or iShiftBits>31 Then

    Err.Raise 6

  End If
 

  If (lValue And m_l2Power(31-iShiftBits)) Then

    LShift=((lValue And m_lOnBits(31-(iShiftBits+1)))*m_l2Power(iShiftBits)) Or &H80000000

  Else

    LShift=((lValue And m_lOnBits(31-iShiftBits))*m_l2Power(iShiftBits))

  End If

End Function
 

Private Function RShift(lValue,iShiftBits)

  If iShiftBits=0 Then

    RShift=lValue

    Exit Function

  ElseIf iShiftBits=31 Then

    If lValue And &H80000000 Then

      RShift=1

    Else

      RShift=0

    End If

    Exit Function

  ElseIf iShiftBits<0 Or iShiftBits>31 Then

    Err.Raise 6

  End If

  

  RShift=(lValue And &H7FFFFFFE)\m_l2Power(iShiftBits)
 

  If (lValue And &H80000000) Then

    RShift=(RShift Or (&H40000000\m_l2Power(iShiftBits-1)))

  End If

End Function
 

Private Function RotateLeft(lValue,iShiftBits)

  RotateLeft=LShift(lValue,iShiftBits) Or RShift(lValue,(32-iShiftBits))

End Function
 

Private Function AddUnsigned(lX,lY)

  Dim lX4

  Dim lY4

  Dim lX8

  Dim lY8

  Dim lResult
 

  lX8=lX And &H80000000

  lY8=lY And &H80000000

  lX4=lX And &H40000000

  lY4=lY And &H40000000
 

  lResult=(lX And &H3FFFFFFF)+(lY And &H3FFFFFFF)
 

  If lX4 And lY4 Then

    lResult=lResult Xor &H80000000 Xor lX8 Xor lY8

  ElseIf lX4 Or lY4 Then

    If lResult And &H40000000 Then

      lResult=lResult Xor &HC0000000 Xor lX8 Xor lY8

    Else

      lResult=lResult Xor &H40000000 Xor lX8 Xor lY8

    End If

  Else

    lResult=lResult Xor lX8 Xor lY8

  End If
 

  AddUnsigned=lResult

End Function
 

Private Function F(x,y,z)

  F=(x And y) Or ((Not x) And z)

End Function
 

Private Function G(x,y,z)

  G=(x And z) Or (y And (Not z))

End Function
 

Private Function H(x,y,z)

  H=(x Xor y Xor z)

End Function
 

Private Function I(x,y,z)

  I=(y Xor (x Or (Not z)))

End Function
 

Private Sub FF(a,b,c,d,x,s,ac)

  a=AddUnsigned(a,AddUnsigned(AddUnsigned(F(b,c,d),x),ac))

  a=RotateLeft(a,s)

  a=AddUnsigned(a,b)

End Sub
 

Private Sub GG(a,b,c,d,x,s,ac)

  a=AddUnsigned(a,AddUnsigned(AddUnsigned(G(b,c,d),x),ac))

  a=RotateLeft(a,s)

  a=AddUnsigned(a,b)

End Sub
 

Private Sub HH(a,b,c,d,x,s,ac)

  a=AddUnsigned(a,AddUnsigned(AddUnsigned(H(b,c,d),x),ac))

  a=RotateLeft(a,s)

  a=AddUnsigned(a,b)

End Sub
 

Private Sub II(a,b,c,d,x,s,ac)

  a=AddUnsigned(a,AddUnsigned(AddUnsigned(I(b,c,d),x),ac))

  a=RotateLeft(a,s)

  a=AddUnsigned(a,b)

End Sub
 

Private Function ConvertToWordArray(sMessage)

  Dim lMessageLength

  Dim lNumberOfWords

  Dim lWordArray()

  Dim lBytePosition

  Dim lByteCount

  Dim lWordCount

  Dim lByteValue    ' need these variables to handle byte value and input argument type

  Dim lMessageType
 

  Const MODULUS_BITS=512

  Const CONGRUENT_BITS=448

  

  lMessageType=Vartype(sMessage)

  Select Case lMessageType    ' strings or Variant Byte Arrays: nothing else!

    Case 8    : lMessageLength=Len(sMessage)

    Case 8209 : lMessageLength=LenB(sMessage)

    Case Else Err.Raise -1,"MD5","Unknown Type passed to MD5 function"

  End Select

  

  lNumberOfWords=(((lMessageLength+((MODULUS_BITS-CONGRUENT_BITS)\BITS_TO_A_BYTE))\(MODULUS_BITS\BITS_TO_A_BYTE))+1)*(MODULUS_BITS\BITS_TO_A_WORD)

  ReDim lWordArray(lNumberOfWords-1)

  

  lBytePosition=0

  lByteCount=0

  Do Until lByteCount >=lMessageLength

    lWordCount=lByteCount\BYTES_TO_A_WORD

    lBytePosition=(lByteCount Mod BYTES_TO_A_WORD)*BITS_TO_A_BYTE

    Select Case lMessageType    ' get the next byte value

      Case 8    : lByteValue = Asc (Mid (sMessage,lByteCount+1,1))

      Case 8209 : lByteValue = AscB(MidB(sMessage,lByteCount+1,1))

    End Select

    lWordArray(lWordCount)=lWordArray(lWordCount) Or LShift(lByteValue,lBytePosition)

    lByteCount=lByteCount+1

  Loop
 

  lWordCount=lByteCount\BYTES_TO_A_WORD

  lBytePosition=(lByteCount Mod BYTES_TO_A_WORD)*BITS_TO_A_BYTE
 

  lWordArray(lWordCount)=lWordArray(lWordCount) Or LShift(&H80,lBytePosition)
 

  lWordArray(lNumberOfWords-2)=LShift(lMessageLength,3)

  lWordArray(lNumberOfWords-1)=RShift(lMessageLength,29)

  

  ConvertToWordArray=lWordArray

End Function
 

Private Function WordToHex(lValue)

  Dim lByte

  Dim lCount

  

  For lCount=0 To 3

    lByte=RShift(lValue,lCount*BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE-1)

    WordToHex=WordToHex & Right("0" & Hex(lByte),2)

  Next

End Function
 

Public Function MD5(sMessage)

  Dim x

  Dim k

  Dim AA

  Dim BB

  Dim CC

  Dim DD

  Dim a

  Dim b

  Dim c

  Dim d

  

  Const S11=7

  Const S12=12

  Const S13=17

  Const S14=22

  Const S21=5

  Const S22=9

  Const S23=14

  Const S24=20

  Const S31=4

  Const S32=11

  Const S33=16

  Const S34=23

  Const S41=6

  Const S42=10

  Const S43=15

  Const S44=21
 

  x=ConvertToWordArray(sMessage)

  

  a=&H67452301

  b=&HEFCDAB89

  c=&H98BADCFE

  d=&H10325476
 

  For k=0 To UBound(x) Step 16

    AA=a

    BB=b

    CC=c

    DD=d
 

    FF a,b,c,d,x(k+0),S11,&HD76AA478

    FF d,a,b,c,x(k+1),S12,&HE8C7B756

    FF c,d,a,b,x(k+2),S13,&H242070DB

    FF b,c,d,a,x(k+3),S14,&HC1BDCEEE

    FF a,b,c,d,x(k+4),S11,&HF57C0FAF

    FF d,a,b,c,x(k+5),S12,&H4787C62A

    FF c,d,a,b,x(k+6),S13,&HA8304613

    FF b,c,d,a,x(k+7),S14,&HFD469501

    FF a,b,c,d,x(k+8),S11,&H698098D8

    FF d,a,b,c,x(k+9),S12,&H8B44F7AF

    FF c,d,a,b,x(k+10),S13,&HFFFF5BB1

    FF b,c,d,a,x(k+11),S14,&H895CD7BE

    FF a,b,c,d,x(k+12),S11,&H6B901122

    FF d,a,b,c,x(k+13),S12,&HFD987193

    FF c,d,a,b,x(k+14),S13,&HA679438E

    FF b,c,d,a,x(k+15),S14,&H49B40821
 

    GG a,b,c,d,x(k+1),S21,&HF61E2562

    GG d,a,b,c,x(k+6),S22,&HC040B340

    GG c,d,a,b,x(k+11),S23,&H265E5A51

    GG b,c,d,a,x(k+0),S24,&HE9B6C7AA

    GG a,b,c,d,x(k+5),S21,&HD62F105D

    GG d,a,b,c,x(k+10),S22,&H2441453

    GG c,d,a,b,x(k+15),S23,&HD8A1E681

    GG b,c,d,a,x(k+4),S24,&HE7D3FBC8

    GG a,b,c,d,x(k+9),S21,&H21E1CDE6

    GG d,a,b,c,x(k+14),S22,&HC33707D6

    GG c,d,a,b,x(k+3),S23,&HF4D50D87

    GG b,c,d,a,x(k+8),S24,&H455A14ED

    GG a,b,c,d,x(k+13),S21,&HA9E3E905

    GG d,a,b,c,x(k+2),S22,&HFCEFA3F8

    GG c,d,a,b,x(k+7),S23,&H676F02D9

    GG b,c,d,a,x(k+12),S24,&H8D2A4C8A

        

    HH a,b,c,d,x(k+5),S31,&HFFFA3942

    HH d,a,b,c,x(k+8),S32,&H8771F681

    HH c,d,a,b,x(k+11),S33,&H6D9D6122

    HH b,c,d,a,x(k+14),S34,&HFDE5380C

    HH a,b,c,d,x(k+1),S31,&HA4BEEA44

    HH d,a,b,c,x(k+4),S32,&H4BDECFA9

    HH c,d,a,b,x(k+7),S33,&HF6BB4B60

    HH b,c,d,a,x(k+10),S34,&HBEBFBC70

    HH a,b,c,d,x(k+13),S31,&H289B7EC6

    HH d,a,b,c,x(k+0),S32,&HEAA127FA

    HH c,d,a,b,x(k+3),S33,&HD4EF3085

    HH b,c,d,a,x(k+6),S34,&H4881D05

    HH a,b,c,d,x(k+9),S31,&HD9D4D039

    HH d,a,b,c,x(k+12),S32,&HE6DB99E5

    HH c,d,a,b,x(k+15),S33,&H1FA27CF8

    HH b,c,d,a,x(k+2),S34,&HC4AC5665
 

    II a,b,c,d,x(k+0),S41,&HF4292244

    II d,a,b,c,x(k+7),S42,&H432AFF97

    II c,d,a,b,x(k+14),S43,&HAB9423A7

    II b,c,d,a,x(k+5),S44,&HFC93A039

    II a,b,c,d,x(k+12),S41,&H655B59C3

    II d,a,b,c,x(k+3),S42,&H8F0CCC92

    II c,d,a,b,x(k+10),S43,&HFFEFF47D

    II b,c,d,a,x(k+1),S44,&H85845DD1

    II a,b,c,d,x(k+8),S41,&H6FA87E4F

    II d,a,b,c,x(k+15),S42,&HFE2CE6E0

    II c,d,a,b,x(k+6),S43,&HA3014314

    II b,c,d,a,x(k+13),S44,&H4E0811A1

    II a,b,c,d,x(k+4),S41,&HF7537E82

    II d,a,b,c,x(k+11),S42,&HBD3AF235

    II c,d,a,b,x(k+2),S43,&H2AD7D2BB

    II b,c,d,a,x(k+9),S44,&HEB86D391
 

    a=AddUnsigned(a,AA)

    b=AddUnsigned(b,BB)

    c=AddUnsigned(c,CC)

    d=AddUnsigned(d,DD)

  Next

  

  MD5=LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))

End Function

%>

Open in new window

0
 
LVL 67

Expert Comment

by:sirbounty
Comment Utility
Try removing lines 1-8
Then take lines 11-12 and remove the server reference:
Set cnObj = createobject("ADODB.Connection")
set rsObj = createobject("ADODB.Recordset")
and in line 66:
        Set cmdObj= CreateObject("ADODB.Command")
line 443:
Set cObj= CreateObject("ADODB.Command")
line 462:
    Set cObj= CreateObject("ADODB.Command")

and for all others...just do a search/replace for server.createobject with createobject...
remove/replace all response.write with wscript.echo
and it should work...
0
 
LVL 10

Expert Comment

by:Dxpert
Comment Utility
ASP is vbscript to run under IIS. All you should need to do is, remove the tags <% %>. You can copy and paste the code from the Include files to the top of your vbscript file. I think that's it. Give it a try.
0
 
LVL 10

Expert Comment

by:Dxpert
Comment Utility
oh yeah... the CreateObject... good catch ;-)
0
 
LVL 8

Author Comment

by:newbie27
Comment Utility
Hello Folks,
Thanks for your comments.
Is there no way I can include the md5 script in load.vbs, without actually copy and paste from md5.asp and adovbs.inc
thanks for your help
regards
sam
0
 
LVL 67

Expert Comment

by:sirbounty
Comment Utility
No, I don't believe so...none that comes to mind anyway...
0
 
LVL 10

Expert Comment

by:Dxpert
Comment Utility
I think you can use the ExecuteGlobal statement, see here:
http://www.source-code.biz/snippets/vbscript/5.htm

0
 
LVL 8

Author Comment

by:newbie27
Comment Utility
Hello,
ExecuteGlobal seems quite confusing to me, can we not use import statement ? I know it was possible in VB but i am sure whether it will going to work, let me try this.

import md5.asp ?

0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 10

Expert Comment

by:Dxpert
Comment Utility
What do you mean "it was possible in vb"??? Are you talking about vb6? As far as I know, there's no "import" in vb6. There is however a "imports" in VB.NET...
0
 
LVL 10

Expert Comment

by:Dxpert
Comment Utility
Although I have never used it, it doesn't seem that hard to implement ExecuteGlobal
http://msdn.microsoft.com/en-us/library/342311f1(VS.85).aspx

- All you have to do, is read the content of the file to be imported into a String, then call the ExecuteGlobal. Then your code should work the same way. Just make sure that you do all of this at the top of your code.
0
 
LVL 8

Author Comment

by:newbie27
Comment Utility

hello Dxpert,
please can you see if this is correct?

Include "md5.vbs"

Sub Include(sCodeFile)
  Dim sCode
  with createobject("scripting.filesystemobject")
    sCode = .OpenTextFile(sCodeFile).ReadAll
  End With
  ExecuteGlobal sCode
End Sub

thanks

md5.vbs

--------

Private Const BITS_TO_A_BYTE=8

Private Const BYTES_TO_A_WORD=4

Private Const BITS_TO_A_WORD=32

Private m_lOnBits(30)

Private m_l2Power(30)

m_lOnBits(0)=CLng(1)

m_lOnBits(1)=CLng(3)

m_lOnBits(2)=CLng(7)

m_lOnBits(3)=CLng(15)

m_lOnBits(4)=CLng(31)

m_lOnBits(5)=CLng(63)

m_lOnBits(6)=CLng(127)

m_lOnBits(7)=CLng(255)

m_lOnBits(8)=CLng(511)

m_lOnBits(9)=CLng(1023)

m_lOnBits(10)=CLng(2047)

m_lOnBits(11)=CLng(4095)

m_lOnBits(12)=CLng(8191)

m_lOnBits(13)=CLng(16383)

m_lOnBits(14)=CLng(32767)

m_lOnBits(15)=CLng(65535)

m_lOnBits(16)=CLng(131071)

m_lOnBits(17)=CLng(262143)

m_lOnBits(18)=CLng(524287)

m_lOnBits(19)=CLng(1048575)

m_lOnBits(20)=CLng(2097151)

m_lOnBits(21)=CLng(4194303)

m_lOnBits(22)=CLng(8388607)

m_lOnBits(23)=CLng(16777215)

m_lOnBits(24)=CLng(33554431)

m_lOnBits(25)=CLng(67108863)

m_lOnBits(26)=CLng(134217727)

m_lOnBits(27)=CLng(268435455)

m_lOnBits(28)=CLng(536870911)

m_lOnBits(29)=CLng(1073741823)

m_lOnBits(30)=CLng(2147483647)
 

m_l2Power(0)=CLng(1)

m_l2Power(1)=CLng(2)

m_l2Power(2)=CLng(4)

m_l2Power(3)=CLng(8)

m_l2Power(4)=CLng(16)

m_l2Power(5)=CLng(32)

m_l2Power(6)=CLng(64)

m_l2Power(7)=CLng(128)

m_l2Power(8)=CLng(256)

m_l2Power(9)=CLng(512)

m_l2Power(10)=CLng(1024)

m_l2Power(11)=CLng(2048)

m_l2Power(12)=CLng(4096)

m_l2Power(13)=CLng(8192)

m_l2Power(14)=CLng(16384)

m_l2Power(15)=CLng(32768)

m_l2Power(16)=CLng(65536)

m_l2Power(17)=CLng(131072)

m_l2Power(18)=CLng(262144)

m_l2Power(19)=CLng(524288)

m_l2Power(20)=CLng(1048576)

m_l2Power(21)=CLng(2097152)

m_l2Power(22)=CLng(4194304)

m_l2Power(23)=CLng(8388608)

m_l2Power(24)=CLng(16777216)

m_l2Power(25)=CLng(33554432)

m_l2Power(26)=CLng(67108864)

m_l2Power(27)=CLng(134217728)

m_l2Power(28)=CLng(268435456)

m_l2Power(29)=CLng(536870912)

m_l2Power(30)=CLng(1073741824)
 

Private Function LShift(lValue,iShiftBits)

  If iShiftBits=0 Then

    LShift=lValue

    Exit Function

  ElseIf iShiftBits=31 Then

    If lValue And 1 Then

      LShift=&H80000000

    Else

      LShift=0

    End If

    Exit Function

  ElseIf iShiftBits<0 Or iShiftBits>31 Then

    Err.Raise 6

  End If
 

  If (lValue And m_l2Power(31-iShiftBits)) Then

    LShift=((lValue And m_lOnBits(31-(iShiftBits+1)))*m_l2Power(iShiftBits)) Or &H80000000

  Else

    LShift=((lValue And m_lOnBits(31-iShiftBits))*m_l2Power(iShiftBits))

  End If

End Function
 

Private Function RShift(lValue,iShiftBits)

  If iShiftBits=0 Then

    RShift=lValue

    Exit Function

  ElseIf iShiftBits=31 Then

    If lValue And &H80000000 Then

      RShift=1

    Else

      RShift=0

    End If

    Exit Function

  ElseIf iShiftBits<0 Or iShiftBits>31 Then

    Err.Raise 6

  End If

  

  RShift=(lValue And &H7FFFFFFE)\m_l2Power(iShiftBits)
 

  If (lValue And &H80000000) Then

    RShift=(RShift Or (&H40000000\m_l2Power(iShiftBits-1)))

  End If

End Function
 

Private Function RotateLeft(lValue,iShiftBits)

  RotateLeft=LShift(lValue,iShiftBits) Or RShift(lValue,(32-iShiftBits))

End Function
 

Private Function AddUnsigned(lX,lY)

  Dim lX4

  Dim lY4

  Dim lX8

  Dim lY8

  Dim lResult
 

  lX8=lX And &H80000000

  lY8=lY And &H80000000

  lX4=lX And &H40000000

  lY4=lY And &H40000000
 

  lResult=(lX And &H3FFFFFFF)+(lY And &H3FFFFFFF)
 

  If lX4 And lY4 Then

    lResult=lResult Xor &H80000000 Xor lX8 Xor lY8

  ElseIf lX4 Or lY4 Then

    If lResult And &H40000000 Then

      lResult=lResult Xor &HC0000000 Xor lX8 Xor lY8

    Else

      lResult=lResult Xor &H40000000 Xor lX8 Xor lY8

    End If

  Else

    lResult=lResult Xor lX8 Xor lY8

  End If
 

  AddUnsigned=lResult

End Function
 

Private Function F(x,y,z)

  F=(x And y) Or ((Not x) And z)

End Function
 

Private Function G(x,y,z)

  G=(x And z) Or (y And (Not z))

End Function
 

Private Function H(x,y,z)

  H=(x Xor y Xor z)

End Function
 

Private Function I(x,y,z)

  I=(y Xor (x Or (Not z)))

End Function
 

Private Sub FF(a,b,c,d,x,s,ac)

  a=AddUnsigned(a,AddUnsigned(AddUnsigned(F(b,c,d),x),ac))

  a=RotateLeft(a,s)

  a=AddUnsigned(a,b)

End Sub
 

Private Sub GG(a,b,c,d,x,s,ac)

  a=AddUnsigned(a,AddUnsigned(AddUnsigned(G(b,c,d),x),ac))

  a=RotateLeft(a,s)

  a=AddUnsigned(a,b)

End Sub
 

Private Sub HH(a,b,c,d,x,s,ac)

  a=AddUnsigned(a,AddUnsigned(AddUnsigned(H(b,c,d),x),ac))

  a=RotateLeft(a,s)

  a=AddUnsigned(a,b)

End Sub
 

Private Sub II(a,b,c,d,x,s,ac)

  a=AddUnsigned(a,AddUnsigned(AddUnsigned(I(b,c,d),x),ac))

  a=RotateLeft(a,s)

  a=AddUnsigned(a,b)

End Sub
 

Private Function ConvertToWordArray(sMessage)

  Dim lMessageLength

  Dim lNumberOfWords

  Dim lWordArray()

  Dim lBytePosition

  Dim lByteCount

  Dim lWordCount

  Dim lByteValue    ' need these variables to handle byte value and input argument type

  Dim lMessageType
 

  Const MODULUS_BITS=512

  Const CONGRUENT_BITS=448

  

  lMessageType=Vartype(sMessage)

  Select Case lMessageType    ' strings or Variant Byte Arrays: nothing else!

    Case 8    : lMessageLength=Len(sMessage)

    Case 8209 : lMessageLength=LenB(sMessage)

    Case Else Err.Raise -1,"MD5","Unknown Type passed to MD5 function"

  End Select

  

  lNumberOfWords=(((lMessageLength+((MODULUS_BITS-CONGRUENT_BITS)\BITS_TO_A_BYTE))\(MODULUS_BITS\BITS_TO_A_BYTE))+1)*(MODULUS_BITS\BITS_TO_A_WORD)

  ReDim lWordArray(lNumberOfWords-1)

  

  lBytePosition=0

  lByteCount=0

  Do Until lByteCount >=lMessageLength

    lWordCount=lByteCount\BYTES_TO_A_WORD

    lBytePosition=(lByteCount Mod BYTES_TO_A_WORD)*BITS_TO_A_BYTE

    Select Case lMessageType    ' get the next byte value

      Case 8    : lByteValue = Asc (Mid (sMessage,lByteCount+1,1))

      Case 8209 : lByteValue = AscB(MidB(sMessage,lByteCount+1,1))

    End Select

    lWordArray(lWordCount)=lWordArray(lWordCount) Or LShift(lByteValue,lBytePosition)

    lByteCount=lByteCount+1

  Loop
 

  lWordCount=lByteCount\BYTES_TO_A_WORD

  lBytePosition=(lByteCount Mod BYTES_TO_A_WORD)*BITS_TO_A_BYTE
 

  lWordArray(lWordCount)=lWordArray(lWordCount) Or LShift(&H80,lBytePosition)
 

  lWordArray(lNumberOfWords-2)=LShift(lMessageLength,3)

  lWordArray(lNumberOfWords-1)=RShift(lMessageLength,29)

  

  ConvertToWordArray=lWordArray

End Function
 

Private Function WordToHex(lValue)

  Dim lByte

  Dim lCount

  

  For lCount=0 To 3

    lByte=RShift(lValue,lCount*BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE-1)

    WordToHex=WordToHex & Right("0" & Hex(lByte),2)

  Next

End Function
 

Public Function MD5(sMessage)

  Dim x

  Dim k

  Dim AA

  Dim BB

  Dim CC

  Dim DD

  Dim a

  Dim b

  Dim c

  Dim d

  

  Const S11=7

  Const S12=12

  Const S13=17

  Const S14=22

  Const S21=5

  Const S22=9

  Const S23=14

  Const S24=20

  Const S31=4

  Const S32=11

  Const S33=16

  Const S34=23

  Const S41=6

  Const S42=10

  Const S43=15

  Const S44=21
 

  x=ConvertToWordArray(sMessage)

  

  a=&H67452301

  b=&HEFCDAB89

  c=&H98BADCFE

  d=&H10325476
 

  For k=0 To UBound(x) Step 16

    AA=a

    BB=b

    CC=c

    DD=d
 

    FF a,b,c,d,x(k+0),S11,&HD76AA478

    FF d,a,b,c,x(k+1),S12,&HE8C7B756

    FF c,d,a,b,x(k+2),S13,&H242070DB

    FF b,c,d,a,x(k+3),S14,&HC1BDCEEE

    FF a,b,c,d,x(k+4),S11,&HF57C0FAF

    FF d,a,b,c,x(k+5),S12,&H4787C62A

    FF c,d,a,b,x(k+6),S13,&HA8304613

    FF b,c,d,a,x(k+7),S14,&HFD469501

    FF a,b,c,d,x(k+8),S11,&H698098D8

    FF d,a,b,c,x(k+9),S12,&H8B44F7AF

    FF c,d,a,b,x(k+10),S13,&HFFFF5BB1

    FF b,c,d,a,x(k+11),S14,&H895CD7BE

    FF a,b,c,d,x(k+12),S11,&H6B901122

    FF d,a,b,c,x(k+13),S12,&HFD987193

    FF c,d,a,b,x(k+14),S13,&HA679438E

    FF b,c,d,a,x(k+15),S14,&H49B40821
 

    GG a,b,c,d,x(k+1),S21,&HF61E2562

    GG d,a,b,c,x(k+6),S22,&HC040B340

    GG c,d,a,b,x(k+11),S23,&H265E5A51

    GG b,c,d,a,x(k+0),S24,&HE9B6C7AA

    GG a,b,c,d,x(k+5),S21,&HD62F105D

    GG d,a,b,c,x(k+10),S22,&H2441453

    GG c,d,a,b,x(k+15),S23,&HD8A1E681

    GG b,c,d,a,x(k+4),S24,&HE7D3FBC8

    GG a,b,c,d,x(k+9),S21,&H21E1CDE6

    GG d,a,b,c,x(k+14),S22,&HC33707D6

    GG c,d,a,b,x(k+3),S23,&HF4D50D87

    GG b,c,d,a,x(k+8),S24,&H455A14ED

    GG a,b,c,d,x(k+13),S21,&HA9E3E905

    GG d,a,b,c,x(k+2),S22,&HFCEFA3F8

    GG c,d,a,b,x(k+7),S23,&H676F02D9

    GG b,c,d,a,x(k+12),S24,&H8D2A4C8A

        

    HH a,b,c,d,x(k+5),S31,&HFFFA3942

    HH d,a,b,c,x(k+8),S32,&H8771F681

    HH c,d,a,b,x(k+11),S33,&H6D9D6122

    HH b,c,d,a,x(k+14),S34,&HFDE5380C

    HH a,b,c,d,x(k+1),S31,&HA4BEEA44

    HH d,a,b,c,x(k+4),S32,&H4BDECFA9

    HH c,d,a,b,x(k+7),S33,&HF6BB4B60

    HH b,c,d,a,x(k+10),S34,&HBEBFBC70

    HH a,b,c,d,x(k+13),S31,&H289B7EC6

    HH d,a,b,c,x(k+0),S32,&HEAA127FA

    HH c,d,a,b,x(k+3),S33,&HD4EF3085

    HH b,c,d,a,x(k+6),S34,&H4881D05

    HH a,b,c,d,x(k+9),S31,&HD9D4D039

    HH d,a,b,c,x(k+12),S32,&HE6DB99E5

    HH c,d,a,b,x(k+15),S33,&H1FA27CF8

    HH b,c,d,a,x(k+2),S34,&HC4AC5665
 

    II a,b,c,d,x(k+0),S41,&HF4292244

    II d,a,b,c,x(k+7),S42,&H432AFF97

    II c,d,a,b,x(k+14),S43,&HAB9423A7

    II b,c,d,a,x(k+5),S44,&HFC93A039

    II a,b,c,d,x(k+12),S41,&H655B59C3

    II d,a,b,c,x(k+3),S42,&H8F0CCC92

    II c,d,a,b,x(k+10),S43,&HFFEFF47D

    II b,c,d,a,x(k+1),S44,&H85845DD1

    II a,b,c,d,x(k+8),S41,&H6FA87E4F

    II d,a,b,c,x(k+15),S42,&HFE2CE6E0

    II c,d,a,b,x(k+6),S43,&HA3014314

    II b,c,d,a,x(k+13),S44,&H4E0811A1

    II a,b,c,d,x(k+4),S41,&HF7537E82

    II d,a,b,c,x(k+11),S42,&HBD3AF235

    II c,d,a,b,x(k+2),S43,&H2AD7D2BB

    II b,c,d,a,x(k+9),S44,&HEB86D391
 

    a=AddUnsigned(a,AA)

    b=AddUnsigned(b,BB)

    c=AddUnsigned(c,CC)

    d=AddUnsigned(d,DD)

  Next

  

  MD5=LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))

End Function

Open in new window

0
 
LVL 8

Author Comment

by:newbie27
Comment Utility
I think that has kind of worked, however I am having an error in the attached function, it is now saying the procedure "sp_archive_folyes_data"" not found, it works when I run in ASP


cObj.CommandType = 4 ' this is another constant which I am using from adovbs.vbs file.

can you please advice if the above is correct to include files ?

thanks



Function archivefolyesData()
 

    Set cObj= CreateObject("ADODB.Command")

    cObj.ActiveConnection = cnObj

    cObj.CommandText = "sp_archive_folyes_data"

    cObj.CommandType = 4

    

    cObj.Execute

    

    If err.number <> 0 then

        archivefolyesData = err.Description 

    Else

        archivefolyesData = "OK"    

    End If

    

    Set cObj = Nothing     

End Function

'******************

Open in new window

0
 
LVL 10

Accepted Solution

by:
Dxpert earned 500 total points
Comment Utility
Include the adovbs.vbs the same way you did with the md5.vbs. Try to check the connection state inside of archivefolyesData(), make sure it's got an open connection. Not sure why it wouldn't find the stored procedure.

wscript.echo cnObj.state
or
msgbox cnObj.state



Constant  		Value	Description

adStateClosed 		0 	The object is closed

adStateOpen		1 	The object is open

adStateConnecting	2 	The object is connecting

adStateExecuting	4 	The object is executing a command

adStateFetching		8 	The rows of the object are being retrieved

Open in new window

0
 
LVL 8

Author Comment

by:newbie27
Comment Utility
wscript.echo cnObj.state
or
msgbox cnObj.state

the above returns 1
-------------------------------
this is what i am getting ... please can you advice
[MySQL][ODBC 3.51 Driver][mysqld-5.1.22-rc-community]PROCEDURE mysql.sp_archive_folyes_data does not exist
0
 
LVL 10

Expert Comment

by:Dxpert
Comment Utility
0
 
LVL 8

Author Comment

by:newbie27
Comment Utility
hmm...apparently his problem was different then mine Dxpert, he has defined a function and was using a stored procedure syntax to call from the ASP page

i am still unable to figure this out why !

[MySQL][ODBC 5.1 Driver][mysqld-5.1.22-rc-community]PROCEDURE mysql.sp_archive_folyes_data does not exist

thanks for your time !

0
 
LVL 8

Author Closing Comment

by:newbie27
Comment Utility
thanks
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Introduction During my participation as a VBScript contributor at Experts Exchange, one of the most common questions I come across is this: "I have a script that runs against only one computer. How can I make it run against a list of computers in …
This article is the result of a quest to better understand Task Scheduler 2.0 and all the newer objects available in vbscript in this version over  the limited options we had scripting in Task Scheduler 1.0.  As I started my journey of knowledge I f…
Get a first impression of how PRTG looks and learn how it works.   This video is a short introduction to PRTG, as an initial overview or as a quick start for new PRTG users.
This demo shows you how to set up the containerized NetScaler CPX with NetScaler Management and Analytics System in a non-routable Mesos/Marathon environment for use with Micro-Services applications.

728 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now