Web Development eCommerce E-Business and Web Programming from RIaK, LLC.

Technology


ASP/VBScript Functions Currency Exchange Rate Function for any country to any country <% ' ************************************************************************************************************ ' This function returns the rate at which to multiply some currency amount to get another currency amount ' This function requires http://webcontinuum.net website to be up and operational ' Example: intPriceUSD = intPriceGBP * GetExchangeRate("GBP", "USD") ' ********************************************************************************************************** Function GetExchangeRate(sCurrIn, sCurrOut) strRep1 = "<?xml version=""1.0"" encoding=""utf-8""?>" strRep2 = "<float xmlns=""http://webcontinuum.net/webcontccydemo1"">" strRep3 = "</float>" Set objHTTP = Server.CreateObject("Msxml2.ServerXMLHTTP") strURL = "http://www.webcontinuum.net/webservices/ccydemo.asmx/calcExcRate?sCurrIn=" & sCurrIn & "&sCurrOut=" & sCurrOut & "&fAmt=1.00" objHTTP.Open "GET", strURL, false objHTTP.setRequestHeader "Content-type", "application/x-www-form-urlencoded" objHTTP.Send 'Read and return the contents of the file as a string. strHTTPContents = objHttp.responseText set objHttp = nothing strRate = strHTTPContents strRate = Replace(strRate, strRep1, "") strRate = Replace(strRate, strRep2, "") strRate = Replace(strRate, strRep3, "") strRate = Replace(strRate, vbCRLF, "") GetExchangeRate = strRate End Function ' *********************** ' Currency Symbols Reference ' ************************* 'Albanian Lek (ALL) 'Algerian Dinar (DZD) 'Aluminium Ounces (XAL) 'Argentine Peso (ARS) 'Aruba Florin (AWG) 'Australian Dollar (AUD) 'Bahamian Dollar (BSD) 'Bahraini Dinar (BHD) 'Bangladesh Taka (BDT) 'Barbados Dollar (BBD) 'Belarus Ruble (BYR) 'Belize Dollar (BZD) 'Bermuda Dollar (BMD) 'Bhutan Ngultrum (BTN) 'Bolivian Boliviano (BOB) 'Brazilian Real (BRL) 'British Pound (GBP) 'Brunei Dollar (BND) 'Bulgarian Lev (BGN) 'Burundi Franc (BIF) 'Cambodia Riel (KHR) 'Canadian Dollar (CAD) 'Cayman Islands Dollar (KYD) 'CFA Franc (BCEAO) (XOF) 'CFA Franc (BEAC) (XAF) 'Chilean Peso (CLP) 'Chinese Yuan (CNY) 'Colombian Peso (COP) 'Comoros Franc (KMF) 'Copper Ounces (XCP) 'Costa Rica Colon (CRC) 'Croatian Kuna (HRK) 'Cuban Peso (CUP) 'Cyprus Pound (CYP) 'Czech Koruna (CZK) 'Danish Krone (DKK) 'Dijibouti Franc (DJF) 'Dominican Peso (DOP) 'East Caribbean Dollar (XCD) 'Ecuador Sucre (ECS) 'Egyptian Pound (EGP) 'El Salvador Colon (SVC) 'Eritrea Nakfa (ERN) 'Estonian Kroon (EEK) 'Ethiopian Birr (ETB) 'Euro (EUR) 'Falkland Islands Pound (FKP) 'Gambian Dalasi (GMD) 'Ghanian Cedi (GHC) 'Gibraltar Pound (GIP) 'Gold Ounces (XAU) 'Guatemala Quetzal (GTQ) 'Guinea Franc (GNF) 'Haiti Gourde (HTG) 'Honduras Lempira (HNL) 'Hong Kong Dollar (HKD) 'Hungarian Forint (HUF) 'Iceland Krona (ISK) 'Indian Rupee (INR) 'Indonesian Rupiah (IDR) 'Iran Rial (IRR) 'Israeli Shekel (ILS) 'Jamaican Dollar (JMD) 'Japanese Yen (JPY) 'Jordanian Dinar (JOD) 'Kazakhstan Tenge (KZT) 'Kenyan Shilling (KES) 'Korean Won (KRW) 'Kuwaiti Dinar (KWD) 'Lao Kip (LAK) 'Latvian Lat (LVL) 'Lebanese Pound (LBP) 'Lesotho Loti (LSL) 'Libyan Dinar (LYD) 'Lithuanian Lita (LTL) 'Macau Pataca (MOP) 'Macedonian Denar (MKD) 'Malagasy Franc (MGF) 'Malawi Kwacha (MWK) 'Malaysian Ringgit (MYR) 'Maldives Rufiyaa (MVR) 'Maltese Lira (MTL) 'Mauritania Ougulya (MRO) 'Mauritius Rupee (MUR) 'Mexican Peso (MXN) 'Moldovan Leu (MDL) 'Mongolian Tugrik (MNT) 'Moroccan Dirham (MAD) 'Mozambique Metical (MZM) 'Namibian Dollar (NAD) 'Nepalese Rupee (NPR) 'Neth Antilles Guilder (ANG) 'New Turkish Lira (TRY) 'New Zealand Dollar (NZD'Nicaragua Cordoba (NIO) 'Nigerian Naira (NGN) 'Norwegian Krone (NOK) 'Omani Rial (OMR) 'Pacific Franc (XPF) 'Pakistani Rupee (PKR) 'Palladium Ounces (XPD) 'Panama Balboa (PAB) 'Papua New Guinea Kina (PGK) 'Paraguayan Guarani (PYG) 'Peruvian Nuevo Sol (PEN) 'Philippine Peso (PHP) 'Platinum Ounces (XPT) 'Polish Zloty (PLN) 'Qatar Rial (QAR) 'Romanian Leu (ROL) 'Romanian New Leu (RON) 'Russian Rouble (RUB) 'Rwanda Franc (RWF) 'Samoa Tala (WST) 'Sao Tome Dobra (STD) 'Saudi Arabian Riyal (SAR) 'Seychelles Rupee (SCR) 'Sierra Leone Leone (SLL) 'Silver Ounces (XAG) 'Singapore Dollar (SGD) 'Slovak Koruna (SKK) 'Slovenian Tolar (SIT) 'Somali Shilling (SOS) 'South African Rand (ZAR) 'Sri Lanka Rupee (LKR) 'St Helena Pound (SHP) 'Sudanese Dinar (SDD) 'Surinam Guilder (SRG) 'Swaziland Lilageni (SZL) 'Swedish Krona (SEK) 'Swiss Franc (CHF) 'Syrian Pound (SYP) 'Taiwan Dollar (TWD) 'Tanzanian Shilling (TZS) 'Thai Baht (THB) 'Tonga Pa'anga (TOP) 'Trinidad&Tobago Dollar (TTD) 'Tunisian Dinar (TND) 'U.S. Dollar (USD) 'UAE Dirham (AED) 'Ugandan Shilling (UGX) 'Ukraine Hryvnia (UAH) 'Uruguayan New Peso (UYU) 'Vanuatu Vatu (VUV) 'Venezuelan Bolivar (VEB) 'Vietnam Dong (VND) 'Yemen Riyal (YER) 'Zambian Kwacha (ZMK) 'Zimbabwe Dollar (ZWD) %> CDOSys Email Function <% Function SendMailCDOSYS(smtp, sUsername, sPassword, sTo, sCC, SBCC, sFrom, sPriority, sSubject, sBody, sAttachment, bHTML) ' This Version supports sCC and sBCC ' See http://www.invisionportal.com/show_tutorial.asp?TutorialID=160 ' See http://www.aspin.com/func/content?id=5956410 on error resume next 'Dimension variables Dim objCDOSYSCon Dim objCDOSYSMail cdoLow = 0 ' Low importance cdoNormal = 1 ' Normal importance (default) cdoHigh = 2 ' High importance 'Create the e-mail server object Set objCDOSYSMail = Server.CreateObject("CDO.Message") Set objCDOSYSCon = Server.CreateObject("CDO.Configuration") 'objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.yoursite.com" objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtp if len(sUsername) > 0 AND len(sPassword) > 0 then objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = sUsername objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = sPassword end if objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60 objCDOSYSCon.Fields.Update 'Update the CDOSYS Configuration Set objCDOSYSMail.Configuration = objCDOSYSCon sPriority = ucase(sPriority) '0=low, 1=normal, 2=high if sPriority = "LOW" then objCDOSYSMail.Fields("urn:schemas:httpmail:importance").Value = cdoLow elseif sPriority = "HIGH" then objCDOSYSMail.Fields("urn:schemas:httpmail:importance").Value = cdoHigh else objCDOSYSMail.Fields("urn:schemas:httpmail:importance").Value = cdoNormal end if objCDOSYSMail.From = sFrom objCDOSYSMail.To = sTo if NOT(IsNull(sCC)) AND LEN(sCC) > 0 then objCDOSYSMail.CC = sCC end if if NOT(IsNull(sBCC)) AND LEN(sBCC) > 0 then objCDOSYSMail.BCC = sBCC end if objCDOSYSMail.Subject = sSubject 'Set the e-mail body format (HTMLBody=HTML TextBody=Plain) if bHTML then objCDOSYSMail.HTMLBody = sBody else objCDOSYSMail.TextBody = sBody end if if sAttachment <> "" then 'objCDOSYSMail.AddAttachment = "file://d:\ptsp\test\test.doc" objCDOSYSMail.AddAttachment = sAttachment end if objCDOSYSMail.Send 'Close the server mail object Set objCDOSYSMail = Nothing Set objCDOSYSCon = Nothing 'response.write "Err=" & Err 'response.end if Err then SendMailCDOSYS = FALSE else SendMailCDOSYS = TRUE end if End Function %> FormatDate Function <% Function FormatDate( _ byVal strDate, _ byVal strFormat _ ) ' Accepts strDate as a valid date/time, ' strFormat as the output template. ' The function finds each item in the ' template and replaces it with the ' relevant information extracted from strDate. ' You are free to use this code provided the following line remains ' www.adopenstatic.com/resources/code/formatdate.asp ' Example: FormatDate(SomeDate, "%M/%D/%y") outputs mm/dd/yy ' Template items ' %m Month as a decimal no. 2 ' %M Month as a padded decimal no. 02 ' %B Full month name February ' %b Abbreviated month name Feb ' %d Day of the month eg 23 ' %D Padded day of the month eg 09 ' %O Ordinal of day of month (eg st or rd or nd) ' %j Day of the year 54 ' %Y Year with century 1998 ' %y Year without century 98 ' %w Weekday as integer (0 is Sunday) ' %a Abbreviated day name Fri ' %A Weekday Name Friday ' %H Hour in 24 hour format 24 ' %h Hour in 12 hour format 12 ' %N Minute as an integer 01 ' %n Minute as optional if minute <> 00 ' %S Second as an integer 55 ' %P AM/PM Indicator PM On Error Resume Next Dim intPosItem Dim int12HourPart Dim str24HourPart Dim strMinutePart Dim strSecondPart Dim strAMPM ' Insert Month Numbers strFormat = Replace(strFormat, "%m", DatePart("m", strDate), 1, -1, vbBinaryCompare) ' Insert Padded Month Numbers strFormat = Replace(strFormat, "%M", Right("0" & DatePart("m", strDate), 2), 1, -1, vbBinaryCompare) ' Insert non-Abbreviated Month Names strFormat = Replace(strFormat, "%B", MonthName(DatePart("m", strDate), False), 1, -1, vbBinaryCompare) ' Insert Abbreviated Month Names strFormat = Replace(strFormat, "%b", MonthName(DatePart("m", strDate), True), 1, -1, vbBinaryCompare) ' Insert Day Of Month strFormat = Replace(strFormat, "%d", DatePart("d",strDate), 1, -1, vbBinaryCompare) ' Insert Padded Day Of Month strFormat = Replace(strFormat, "%D", Right ("0" & DatePart("d",strDate), 2), 1, -1, vbBinaryCompare) ' Insert Day of Month Ordinal (eg st, th, or rd) strFormat = Replace(strFormat, "%O", GetDayOrdinal(Day(strDate)), 1, -1, vbBinaryCompare) ' Insert Day of Year strFormat = Replace(strFormat, "%j", DatePart("y",strDate), 1, -1, vbBinaryCompare) ' Insert Long Year (4 digit) strFormat = Replace(strFormat, "%Y", DatePart("yyyy",strDate), 1, -1, vbBinaryCompare) ' Insert Short Year (2 digit) strFormat = Replace(strFormat, "%y", Right(DatePart("yyyy",strDate),2), 1, -1, vbBinaryCompare) ' Insert Weekday as Integer (eg 0 = Sunday) strFormat = Replace(strFormat, "%w", DatePart("w",strDate,1), 1, -1, vbBinaryCompare) ' Insert Abbreviated Weekday Name (eg Sun) strFormat = Replace(strFormat, "%a", WeekDayName(DatePart("w",strDate,1), True), 1, -1, vbBinaryCompare) ' Insert non-Abbreviated Weekday Name strFormat = Replace(strFormat, "%A", WeekDayName(DatePart("w",strDate,1), False), 1, -1, vbBinaryCompare) ' Insert Hour in 24hr format str24HourPart = DatePart("h",strDate) If Len(str24HourPart) < 2 then str24HourPart = "0" & str24HourPart strFormat = Replace(strFormat, "%H", str24HourPart, 1, -1, vbBinaryCompare) ' Insert Hour in 12hr format int12HourPart = DatePart("h",strDate) Mod 12 If int12HourPart = 0 then int12HourPart = 12 strFormat = Replace(strFormat, "%h", int12HourPart, 1, -1, vbBinaryCompare) ' Insert Minutes strMinutePart = DatePart("n",strDate) If Len(strMinutePart) < 2 then strMinutePart = "0" & strMinutePart strFormat = Replace(strFormat, "%N", strMinutePart, 1, -1, vbBinaryCompare) ' Insert Optional Minutes If CInt(strMinutePart) = 0 then strFormat = Replace(strFormat, "%n", "", 1, -1, vbBinaryCompare) Else If CInt(strMinutePart) < 10 then strMinutePart = "0" & strMinutePart strMinutePart = ":" & strMinutePart strFormat = Replace(strFormat, "%n", strMinutePart, 1, -1, vbBinaryCompare) End If ' Insert Seconds strSecondPart = DatePart("s",strDate) If Len(strSecondPart) < 2 then strSecondPart = "0" & strSecondPart strFormat = Replace(strFormat, "%S", strSecondPart, 1, -1, vbBinaryCompare) ' Insert AM/PM indicator If DatePart("h",strDate) >= 12 then strAMPM = "PM" Else strAMPM = "AM" End If strFormat = Replace(strFormat, "%P", strAMPM, 1, -1, vbBinaryCompare) FormatDate = strFormat End Function Function GetDayOrdinal( _ byVal intDay _ ) ' Accepts a day of the month ' as an integer and returns the ' appropriate suffix On Error Resume Next Dim strOrd Select Case intDay Case 1, 21, 31 strOrd = "st" Case 2, 22 strOrd = "nd" Case 3, 23 strOrd = "rd" Case Else strOrd = "th" End Select GetDayOrdinal = strOrd End Function %> Mask Credit Card <% Function MaskCreditCard(strCCNum) strCCNum = replace(strCCNum, " ", "") strCCNum = replace(strCCNum, "-", "") Dim b, k, c b = LEN(strCCNum) k = RIGHT(strCCNum,4) a = LEFT(strCCNum,12) For i = 0 to len(strCCNum) c = Replace(strCCNum,strCCNum,"XXXX-XXXX-XXXX-" & k) Next MaskCreditCard = c End Function %> IsGUID Function <% Function IsGUID(strGUID) dim regEx set regEx = New RegExp regEx.Pattern = Replace("{########-####-####-####-############}", "#", "[0-9,A-F]") isGUID = regEx.Test(strGUID) if LEN(strGUID) > 39 then isGUID = FALSE end if End Function %> IsEmailAddressValid Function <% Function IsEmailAddressValid(strEmail) ' Requires http://www.hexillion.com/samples/SimpleEmailValidation.asp be up and running Set objHTTP = Server.CreateObject("Msxml2.ServerXMLHTTP") objHTTP.Open "GET", "http://www.hexillion.com/samples/SimpleEmailValidation.asp?email="&strEmail, false objHTTP.setRequestHeader "Content-type", "application/x-www-form-urlencoded" objHTTP.Send myPostString 'Read and return the contents of the page. strHTTPContents = objHttp.responseText set objHttp = nothing if InStr(strHTTPContents, "Bad address") then IsEmailAddressValid = FALSE else IsEmailAddressValid = TRUE end if End Function %> Calendar Function <% 'calendar() displays a calendar page of the chosen month and year. 'The function takes a date string as its only parameter. 'For the current server date to be used, a null must be passed. function calendar(today) if isnull(today) then today = date end if today = DateValue(today) todays_day = day(today) todays_month = month(today) todays_year = year(today) month_names = Array("January", _ "February", _ "March", _ "April", _ "May", _ "June", _ "July", _ "August", _ "September", _ "October", _ "November", _ "December") this_month = datevalue(todays_month & "/1/" & todays_year) next_month = datevalue(dateadd("m", 1, todays_month & "/1/" & todays_year)) 'Find out when this month starts and ends. first_week_day = weekday(this_month) - 1 days_in_this_month = datediff("d", this_month, next_month) calendar_html = "<table style=""background-color:666699; color:ffffff;"">" calendar_html = calendar_html & _ "<tr><td colspan=""7"" align=""center"" style=""background-color:9999cc; color:000000;"">" & _ month_names(todays_month - 1) & " " & todays_year & "</td></tr>" calendar_html = calendar_html & "<tr>" 'Fill the first week of the month with the appropriate number of blanks. for week_day = 0 to first_week_day - 1 calendar_html = calendar_html & "<td style=""background-color:9999cc; color:000000;""> </td>" next week_day = first_week_day for day_counter = 1 to days_in_this_month week_day = week_day mod 7 if week_day = 0 then calendar_html = calendar_html & "</tr><tr>" end if 'Do something different for the current day. if todays_day = day_counter then calendar_html = calendar_html & "<td align=""center""><b>" & day_counter & "</b></td>" else calendar_html = calendar_html & _ "<td align=""center"" style=""background-color:9999cc; color:000000;""> " & _ day_counter & " </td>" end if week_day = week_day + 1 next calendar_html = calendar_html & "</tr>" calendar_html = calendar_html & "</table>" Calendar = calendar_html end function %>