Solved

convert asp to vbs

Posted on 2008-06-23
17
1,572 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
ID: 21846225
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
ID: 21846374
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
ID: 21846393
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
Netscaler Common Configuration How To guides

If you use NetScaler you will want to see these guides. The NetScaler How To Guides show administrators how to get NetScaler up and configured by providing instructions for common scenarios and some not so common ones.

 
LVL 10

Expert Comment

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

Author Comment

by:newbie27
ID: 21846501
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
ID: 21846577
No, I don't believe so...none that comes to mind anyway...
0
 
LVL 10

Expert Comment

by:Dxpert
ID: 21846600
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
ID: 21847721
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
 
LVL 10

Expert Comment

by:Dxpert
ID: 21847820
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
ID: 21847852
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
ID: 21848390

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
ID: 21848544
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
ID: 21848684
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
ID: 21850892
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
ID: 21854923
0
 
LVL 8

Author Comment

by:newbie27
ID: 21855032
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
ID: 31469741
thanks
0

Featured Post

Master Your Team's Linux and Cloud Stack!

The average business loses $13.5M per year to ineffective training (per 1,000 employees). Keep ahead of the competition and combine in-person quality with online cost and flexibility by training with Linux Academy.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

In this article we want to have a look at the directory attributes which are used by Microsoft to store the so called Security Identifiers (SID). These SIDs plays an important role in delegating and granting permissions and in authentication of trus…
Welcome back!  My apologies for taking so long to write part two of this series; it's been a long time coming!  As I promised in Part 1, this article will focus on how to locate those elusive AD properties that you are searching for.  Why is this us…
Established in 1997, Technology Architects has become one of the most reputable technology solutions companies in the country. TA have been providing businesses with cost effective state-of-the-art solutions and unparalleled service that is designed…
Email security requires an ever evolving service that stays up to date with counter-evolving threats. The Email Laundry perform Research and Development to ensure their email security service evolves faster than cyber criminals. We apply our Threat…

777 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