Advertisement
Advertisement
| 09.16.2008 at 05:02PM PDT, ID: 23737097 | Points: 500 |
|
[x]
Attachment Details
|
||
1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135: 136: 137: 138: 139: 140: 141: 142: 143: 144: 145: 146: 147: 148: 149: 150: 151: 152: 153: 154: 155: 156: 157: 158: 159: 160: 161: 162: 163: 164: 165: 166: 167: 168: 169: 170: 171: 172: 173: 174: 175: 176: 177: 178: 179: 180: 181: 182: 183: 184: 185: 186: 187: 188: 189: 190: 191: 192: 193: 194: 195: 196: 197: 198: 199: 200: 201: 202: 203: 204: 205: 206: 207: 208: 209: 210: 211: 212: 213: 214: 215: 216: 217: 218: 219: 220: 221: 222: 223: 224: 225: 226: 227: 228: 229: 230: 231: 232: 233: 234: 235: 236: 237: 238: 239: 240: 241: 242: 243: 244: 245: 246: 247: 248: 249: 250: 251: 252: 253: 254: 255: 256: 257: 258: 259: 260: 261: 262: 263: 264: 265: 266: 267: 268: 269: 270: 271: 272: 273: 274: 275: 276: 277: 278: 279: 280: 281: 282: 283: 284: 285: 286: 287: 288: 289: 290: 291: 292: 293: 294: 295: 296: 297: 298: 299: 300: 301: 302: 303: 304: 305: 306: 307: 308: 309: 310: 311: 312: 313: 314: 315: 316: 317: 318: 319: 320: 321: 322: 323: 324: 325: 326: 327: 328: 329: 330: 331: 332: 333: 334: 335: 336: 337: 338: 339: 340: 341: 342: 343: 344: 345: 346: 347: 348: 349: 350: 351: 352: 353: 354: 355: 356: 357: 358: 359: 360: 361: 362: 363: 364: 365: 366: 367: 368: 369: 370: 371: 372: 373: 374: 375: 376: 377: 378: 379: 380: 381: 382: 383: 384: 385: 386: 387: 388: 389: 390: 391: 392: 393: 394: 395: 396: 397: 398: 399: 400: 401: 402: 403: 404: 405: 406: 407: 408: 409: 410: 411: 412: 413: 414: 415: 416: 417: 418: 419: 420: 421: 422: 423: 424: 425: 426: 427: 428: 429: 430: 431: 432: 433: 434: 435: 436: 437: 438: 439: 440: 441: 442: 443: 444: 445: 446: 447: 448: 449: 450: 451: 452: 453: 454: 455: 456: 457: 458: 459: 460: 461: 462: 463: 464: 465: 466: 467: 468: 469: 470: 471: 472: 473: 474: 475: 476: 477: 478: 479: 480: 481: 482: 483: 484: 485: 486: 487: 488: 489: 490: 491: 492: 493: 494: 495: 496: 497: 498: 499: 500: 501: 502: 503: 504: 505: 506: 507: 508: 509: 510: 511: 512: 513: 514: 515: 516: 517: 518: 519: 520: 521: 522: 523: 524: 525: 526: 527: 528: 529: 530: 531: 532: 533: 534: 535: 536: 537: 538: 539: 540: 541: 542: 543: 544: 545: 546: 547: 548: 549: 550: 551: 552: 553: 554: 555: 556: 557: 558: 559: 560: 561: 562: 563: 564: 565: 566: 567: 568: 569: 570: 571: 572: 573: 574: 575: 576: 577: 578: 579: 580: 581: 582: 583: 584: 585: 586: 587: 588: 589: 590: 591: 592: 593: 594: 595: 596: 597: 598: 599: 600: 601: 602: 603: 604: 605: 606: 607: 608: 609: 610: 611: 612: 613: 614: 615: 616: 617: 618: 619: 620: 621: 622: 623: 624: 625: 626: 627: 628: 629: 630: 631: 632: 633: 634: 635: 636: 637: 638: 639: 640: 641: 642: 643: 644: 645: 646: 647: 648: 649: 650: 651: 652: 653: 654: 655: 656: 657: 658: 659: 660: 661: 662: 663: 664: 665: 666: 667: 668: 669: 670: 671: 672: 673: 674: 675: 676: 677: 678: 679: 680: 681: 682: 683: 684: 685: 686: 687: 688: 689: 690: 691: 692: 693: 694: 695: 696: 697: 698: 699: 700: 701: 702: 703: 704: 705: 706: 707: 708: 709: 710: 711: 712: 713: 714: 715: 716: 717: 718: 719: 720: 721: 722: 723: 724: 725: 726: 727: 728: 729: 730: 731: 732: 733: 734: 735: 736: 737: 738: 739: 740: 741: 742: 743: 744: 745: 746: 747: 748: 749: 750: 751: 752: 753: 754: 755: 756: 757: 758: 759: 760: 761: 762: 763: 764: 765: 766: 767: 768: 769: 770: 771: 772: 773: 774: 775: 776: 777: 778: 779: 780: 781: 782: 783: 784: 785: 786: 787: 788: 789: 790: 791: 792: 793: 794: 795: 796: 797: 798: 799: 800: 801: 802: 803: 804: 805: 806: 807: 808: 809: 810: 811: 812: 813: 814: 815: 816: 817: 818: 819: 820: 821: 822: 823: 824: 825: 826: 827: 828: 829: 830: 831: 832: 833: 834: 835: 836: 837: 838: 839: 840: 841: 842: 843: 844: 845: 846: 847: 848: 849: 850: 851: 852: 853: 854: 855: 856: 857: 858: 859: 860: 861: 862: 863: 864: 865: 866: 867: 868: 869: 870: 871: 872: 873: 874: 875: 876: 877: 878: 879: 880: 881: 882: 883: 884: 885: 886: 887: 888: 889: 890: 891: 892: 893: 894: 895: 896: 897: 898: 899: 900: 901: 902: 903: 904: 905: 906: 907: 908: 909: 910: 911: 912: 913: 914: 915: 916: 917: 918: 919: 920: 921: 922: 923: 924: 925: 926: 927: 928: 929: 930: 931: 932: 933: 934: 935: 936: 937: 938: 939: 940: 941: 942: 943: 944: 945: 946: 947: 948: 949: 950: 951: 952: 953: 954: 955: 956: 957: 958: 959: 960: 961: 962: 963: 964: 965: 966: 967: 968: 969: 970: 971: 972: 973: 974: 975: 976: 977: 978: 979: 980: 981: 982: 983: 984: 985: 986: 987: 988: 989: 990: 991: 992: 993: 994: 995: 996: 997: 998: 999: 1000: 1001: 1002: 1003: 1004: 1005: 1006: 1007: 1008: 1009: 1010: 1011: 1012: 1013: 1014: 1015: 1016: 1017: 1018: 1019: 1020: 1021: 1022: 1023: 1024: 1025: 1026: 1027: 1028: 1029: 1030: 1031: 1032: 1033: 1034: 1035: 1036: 1037: 1038: 1039: 1040: 1041: 1042: 1043: 1044: 1045: 1046: 1047: 1048: 1049: 1050: 1051: 1052: 1053: 1054: 1055: 1056: 1057: 1058: 1059: 1060: 1061: 1062: 1063: 1064: 1065: 1066: 1067: 1068: 1069: 1070: 1071: 1072: 1073: 1074: 1075: 1076: 1077: 1078: 1079: 1080: 1081: 1082: 1083: 1084: 1085: 1086: 1087: 1088: 1089: 1090: 1091: 1092: 1093: 1094: 1095: 1096: 1097: 1098: 1099: 1100: 1101: 1102: 1103: 1104: 1105: 1106: 1107: 1108: 1109: 1110: 1111: 1112: 1113: 1114: 1115: 1116: 1117: 1118: 1119: 1120: 1121: 1122: 1123: 1124: 1125: 1126: 1127: 1128: 1129: 1130: 1131: 1132: 1133: 1134: 1135: 1136: 1137: 1138: 1139: 1140: 1141: 1142: 1143: 1144: 1145: 1146: 1147: 1148: 1149: 1150: 1151: 1152: 1153: 1154: 1155: 1156: 1157: 1158: 1159: 1160: 1161: 1162: 1163: 1164: 1165: 1166: 1167: 1168: 1169: 1170: 1171: 1172: 1173: 1174: 1175: 1176: 1177: 1178: 1179: 1180: 1181: 1182: 1183: 1184: 1185: 1186: 1187: 1188: 1189: 1190: 1191: 1192: 1193: 1194: 1195: 1196: 1197: 1198: 1199: 1200: 1201: 1202: 1203: 1204: 1205: 1206: 1207: 1208: 1209: 1210: 1211: 1212: 1213: 1214: 1215: 1216: 1217: 1218: 1219: 1220: 1221: 1222: 1223: 1224: 1225: 1226: 1227: 1228: 1229: 1230: 1231: 1232: 1233: 1234: 1235: 1236: 1237: 1238: 1239: 1240: 1241: 1242: 1243: 1244: 1245: 1246: 1247: 1248: 1249: 1250: 1251: 1252: 1253: 1254: 1255: 1256: 1257: 1258: 1259: 1260: 1261: 1262: 1263: 1264: 1265: 1266: 1267: 1268: 1269: 1270: 1271: 1272: 1273: 1274: 1275: 1276: 1277: 1278: 1279: 1280: 1281: 1282: 1283: 1284: 1285: 1286: 1287: 1288: 1289: 1290: 1291: 1292: 1293: 1294: 1295: 1296: 1297: 1298: 1299: 1300: 1301: 1302: 1303: 1304: 1305: 1306: 1307: 1308: 1309: 1310: 1311: 1312: 1313: 1314: 1315: 1316: 1317: 1318: 1319: 1320: 1321: 1322: 1323: 1324: 1325: 1326: 1327: 1328: 1329: 1330: 1331: 1332: 1333: 1334: 1335: 1336: 1337: 1338: 1339: 1340: 1341: 1342: 1343: 1344: 1345: 1346: 1347: 1348: 1349: 1350: 1351: 1352: 1353: 1354: 1355: 1356: 1357: 1358: 1359: 1360: 1361: 1362: 1363: 1364: 1365: 1366: 1367: 1368: 1369: 1370: 1371: 1372: 1373: 1374: 1375: 1376: 1377: 1378: 1379: 1380: 1381: 1382: 1383: 1384: 1385: 1386: 1387: 1388: 1389: 1390: 1391: 1392: 1393: 1394: 1395: 1396: 1397: 1398: 1399: 1400: 1401: 1402: 1403: 1404: 1405: 1406: 1407: 1408: 1409: 1410: 1411: 1412: 1413: 1414: 1415: 1416: 1417: 1418: 1419: 1420: 1421: 1422: 1423: 1424: 1425: 1426: 1427: 1428: 1429: 1430: 1431: 1432: 1433: 1434: 1435: 1436: 1437: 1438: 1439: 1440: 1441: 1442: 1443: 1444: 1445: 1446: 1447: 1448: 1449: 1450: 1451: 1452: 1453: 1454: 1455: 1456: 1457: 1458: 1459: 1460: 1461: 1462: 1463: 1464: 1465: 1466: 1467: 1468: 1469: 1470: 1471: 1472: 1473: 1474: 1475: 1476: 1477: 1478: 1479: 1480: 1481: 1482: 1483: 1484: 1485: 1486: 1487: 1488: 1489: 1490: 1491: 1492: 1493: 1494: 1495: 1496: 1497: 1498: 1499: 1500: 1501: 1502: 1503: 1504: 1505: 1506: 1507: 1508: 1509: 1510: 1511: 1512: 1513: 1514: 1515: 1516: 1517: 1518: 1519: 1520: 1521: 1522: 1523: 1524: 1525: 1526: 1527: 1528: 1529: 1530: 1531: 1532: 1533: 1534: 1535: 1536: 1537: 1538: 1539: 1540: 1541: 1542: 1543: 1544: 1545: 1546: 1547: 1548: 1549: 1550: 1551: 1552: 1553: 1554: 1555: 1556: 1557: 1558: 1559: 1560: 1561: 1562: 1563: 1564: 1565: 1566: 1567: 1568: 1569: 1570: 1571: 1572: 1573: 1574: 1575: 1576: 1577: 1578: 1579: 1580: 1581: 1582: 1583: 1584: 1585: 1586: 1587: 1588: 1589: 1590: 1591: 1592: 1593: 1594: 1595: 1596: 1597: 1598: 1599: 1600: 1601: 1602: 1603: 1604: 1605: 1606: 1607: 1608: 1609: 1610: 1611: 1612: 1613: 1614: 1615: 1616: 1617: 1618: 1619: 1620: 1621: 1622: 1623: 1624: 1625: 1626: 1627: 1628: 1629: 1630: 1631: 1632: 1633: 1634: 1635: 1636: 1637: 1638: 1639: 1640: 1641: 1642: 1643: 1644: 1645: 1646: 1647: 1648: 1649: 1650: 1651: 1652: 1653: 1654: 1655: 1656: 1657: 1658: 1659: 1660: 1661: 1662: 1663: 1664: 1665: 1666: 1667: 1668: 1669: 1670: 1671: 1672: 1673: 1674: 1675: 1676: 1677: 1678: 1679: 1680: 1681: 1682: 1683: 1684: 1685: 1686: 1687: 1688: 1689: 1690: 1691: 1692: 1693: 1694: 1695: 1696: 1697: 1698: 1699: 1700: 1701: 1702: 1703: 1704: 1705: 1706: 1707: |
<!-- #include virtual="/includes/global.asp" -->
<!-- #include virtual="/includes/error.asp" -->
<!-- #include virtual="/includes/validate.asp" -->
<!-- #include virtual="/includes/controls.asp" -->
<%
'VERIFY CONNECTION STRING
VerifyConnectionString()
' LOAD SYSTEM PARAMETERS
Function GenerateFileID()
Dim sResult
sResult = Server.Createobject("scriptlet.typelib").guid
sResult = Replace(sResult, "{", "")
sResult = Replace(sResult, "}", "")
sResult = Replace(sResult, "-", "")
GenerateFileID = Left(sResult,32)
End Function
Function QuoteCSV(sInput)
Dim bDblQuote
If Instr(sInput, ",") > 0 then
bDblQuote = true
end if
If Instr(sInput, """") > 0 then
bDblQuote = true
end if
If Instr(sInput, vbCrLf) > 0 then
bDblQuote = true
end if
if bDblQuote then
QuoteCSV = DblQuote(sInput)
else
QuoteCSV = sInput
end if
End Function
Function DblQuote(s)
Dim t
If IsEmpty(s) Then
DblQuote = ""
Else
t = Replace(s,"""","""""")
t = Replace(t,vbCrLf," ")
t = Trim(t)
DblQuote = """" & t & """"
End If
End Function
Sub VerifyConnectionString()
Dim iLoop, bIsDesignDB, bIsDesignServer
Dim sServerName
'aAddresses = Split(GLOBAL_DESIGN_DB_SERVERS, ",")
'bIsDesignDB = false
'For iLoop = LBound(aAddresses) to UBound(aAddresses)
'if Instr(UCase(GLOBAL_CONNECTION_STRING), aAddresses(iLoop)) > 0 then
' bIsDesignDB = true
' Exit For
'end if
' Next
'sServerName = GetServerName()
'aAddresses = Split(GLOBAL_DESIGN_SERVERS, ",")
'bIsDesignServer = false
'For iLoop = LBound(aAddresses) to UBound(aAddresses)
' if UCase(sServerName) = UCase(aAddresses(iLoop)) then
' bIsDesignServer = true
' Exit For
' end if
'Next
'VERIFY CONNECTION STRING AND SERVER
If (bIsDesignServer and not bIsDesignDB) or (not bIsDesignServer and bIsDesignDB) then
Response.Write "CONFIGURATION ERROR! Please change the database connection string"
Response.End
end if
End Sub
Function GetServerName()
Dim oWshNetwork, sResult
Set oWshNetwork = Server.CreateObject("WScript.Network")
sResult = oWshNetwork.ComputerName
set oWshNetwork = nothing
GetServerName = sResult
End Function
Function FolderExists(folderspec)
Dim fso
FolderExists = false
If Not IsEmpty(folderspec) Then
set fso = CreateObject("Scripting.FileSystemObject")
if not (fso.FolderExists(Server.MapPath(folderspec))) then
set fso = nothing
Exit Function
end if
set fso = nothing
End If
FolderExists = true
End Function
Function FileExists(sFile)
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileExists = oFSO.FileExists(Server.MapPath(sFile))
Set oFSO = Nothing
End Function
'we keep that function for backward compatibility
Function file_exists(sFile)
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
file_exists = oFSO.FileExists(Server.MapPath(sFile))
Set oFSO = Nothing
End Function
Function QuoteMultiple(sMultiple)
Dim aMultiple, iItem
If IsEmpty(sMultiple) Then
QuoteMultiple = "(NULL)"
Exit Function
End If
aMultiple = Split(sMultiple, ",")
For iItem = LBound(aMultiple) To UBound(aMultiple)
aMultiple(iItem) = Quote(aMultiple(iItem))
Next
QuoteMultiple = "(" & Join(aMultiple, ",") & ")"
End Function
Function NumberMultiple(sMultiple)
Dim aMultiple, iItem
If IsEmpty(sMultiple) Then
NumberMultiple = "(NULL)"
Exit Function
End If
aMultiple = Split(sMultiple, ",")
For iItem = LBound(aMultiple) To UBound(aMultiple)
aMultiple(iItem) = Number(aMultiple(iItem))
Next
NumberMultiple = "(" & Join(aMultiple, ",") & ")"
End Function
Function ProtectParam(sInput)
If IsEmpty(sInput) Then
ProtectParam = ""
Exit Function
End If
ProtectParam = Replace(sInput, ";","")
End Function
Function ChangeSortOrder(sKeyField, sTable, sSortField, sWhere, iKeyValue, sAction)
Dim sSQL
Dim res, NEXT_SORT_ORDER, NEXT_ID
Dim iRowsAffected
ChangeSortOrder = false
sSQL = "SELECT top 1 " & sKeyField & "," & sSortField & " FROM " & sTable
if sAction = "UP" then sSQL = sSQL & " WHERE " & sSortField & " < " else sSQL = sSQL & " WHERE " & sSortField & " > "
sSQL = sSQL & "(SELECT " & sSortField & " FROM " & sTable & " WHERE " & sKeyField & "=" & Number(iKeyValue) & ")"
if not IsEmpty(sWhere) then
sSQL = sSQL & " AND " & sWhere
end if
sSQL = sSQL & " ORDER BY " & sSortField
if sAction = "UP" then sSQL = sSQL & " DESC " else sSQL = sSQL & " ASC "
Response.Write sSQL & "<BR>"
Trace(sSQL)
set res = DB.Execute(sSQL)
if not res.eof then
NEXT_ID = res(sKeyField)
NEXT_SORT_ORDER = res(sSortField)
end if
res.close
set res = nothing
if isEmpty(NEXT_ID) then Exit Function
sSQL = "UPDATE " & sTable & " SET " & sSortField & "=(SELECT " & sSortField & " FROM " & sTable & " WHERE " & sKeyField & "=" & Number(iKeyValue) & ") WHERE " & sKeyField & "=" & Number(NEXT_ID)
iRowsAffected = ExecuteSQL(sSQL)
if DBErrors Or iRowsAffected = 0 then
Exit Function
End if
sSQL = "UPDATE " & sTable & " SET " & sSortField & "=" & Number(NEXT_SORT_ORDER) & " WHERE " & sKeyField & "=" & Number(iKeyValue)
iRowsAffected = ExecuteSQL(sSQL)
if DBErrors Or iRowsAffected = 0 then
Exit Function
End if
ChangeSortOrder = true
End Function
Function GetFilterFields()
Dim obj, dctFields, sIterator, dct
set dct = Server.CreateObject("Scripting.Dictionary")
If InStr(1, Request.ServerVariables( "HTTP_CONTENT_TYPE" ), "multipart/form-data", 0 ) > 0 Then
if not isObject(dGLOBAL_UPLOAD_OBJECT) then
set dGLOBAL_UPLOAD_OBJECT = Server.CreateObject("SoftArtisans.FileUp")
end if
set obj = dGLOBAL_UPLOAD_OBJECT
Else
set obj = Request
End If
for each sIterator in obj.Form
if UCase(Left(sIterator, 2)) = "F_" then dct(sIterator) = obj.Form(sIterator)
next
for each sIterator in Request.QueryString
if UCase(Left(sIterator, 2)) = "F_" then dct(sIterator) = Request.QueryString(sIterator)
next
set GetFilterFields = dct
End Function
Function PassFilterFieldsForm(sExceptionList)
Dim dct, sIterator, aException
aException = Split(sExceptionList, "|")
set dct = GetFilterFields()
for each sIterator in dct
if not IsInArray(aException, sIterator) then
%><input type=hidden name="<%=sIterator%>" value="<%=HTMLEncode(dct(sIterator))%>"><%=vbCrLf%><%
end if
next
End Function
Function PassFilterFieldsURL(sExceptionList)
Dim dct, sIterator, aException
Dim sResult, sConn
aException = Split(sExceptionList, "|")
set dct = GetFilterFields()
for each sIterator in dct
if not IsInArray(aException, sIterator) then
sResult = sResult & sConn & sIterator & "=" & URLEncode(dct(sIterator))
sConn = "&"
end if
next
PassFilterFieldsURL = sResult
End Function
Function iif(bCond, sTrue, sFalse)
if bCond then
iif = sTrue
else
iif = sFalse
end if
End Function
Function Escape(s)
Dim t
If IsEmpty(s) Then
Escape = "NULL"
Else
t = Replace(s,"'","\'")
t = Trim(t)
Escape = "'" & t & "'"
End If
End Function
Function DeleteFile(FULL_FILE_NAME)
Dim fso
DeleteFile = false
set fso = Server.CreateObject("Scripting.FileSystemObject")
if fso.FileExists(Server.MapPath(FULL_FILE_NAME)) then fso.DeleteFile(Server.MapPath(FULL_FILE_NAME))
set fso = nothing
DeleteFile = true
End Function
Function GenerateFileName(FIELD_NAME)
Dim sFullName, sExt
GenerateFileName = ""
sExt = GetFileExtension(dGLOBAL_UPLOAD_OBJECT.Form(FIELD_NAME).UserFileName)
sFullName = getGuid
if not IsEmpty(sExt) then sFullName = sFullName & "." & sExt
GenerateFileName = sFullName
End Function
Function UploadFile(FILENAME_GUID, OLD_FILENAME_GUID, FIELD_NAME, FILE_PATH)
Dim sPath
UploadFile = false
if dGLOBAL_UPLOAD_OBJECT.Form(FIELD_NAME).TotalBytes = 0 then
Session("ERROR_DESC") = "WRONG UPLOAD FILE NAME"
Exit Function
end if
sPath = FILE_PATH
if Right(sPath,1) <> "/" then sPath = sPath & "/"
On Error Resume Next
dGLOBAL_UPLOAD_OBJECT.Form(FIELD_NAME).SaveAs(Server.mappath(sPath & FILENAME_GUID))
If Err then
Session("ERROR_DESC") = "WRONG UPLOAD FILE NAME"
Exit Function
End if
call DeleteFile(sPath & OLD_FILENAME_GUID)
UploadFile = true
End Function
Function GetGUID()
Dim sResult
sResult = Server.Createobject("scriptlet.typelib").guid
sResult = Replace(sResult, "{", "")
sResult = Replace(sResult, "}", "")
sResult = Replace(sResult, "-", "")
GetGUID = Left(sResult,32)
End Function
Function MergeArrays(aArray1, aArray2)
Dim iArrayIndex
For iArrayIndex = LBound(aArray2) To UBound(aArray2)
ReDim Preserve aArray1(UBound(aArray1) + 1)
aArray1(UBound(aArray1)) = aArray2(iArrayIndex)
Next
MergeArrays = aArray1
End Function
Function DisplayOrdinal(n)
Dim sAppend
sAppend = "th"
If isNumeric(n) then
if right(cstr(n),1)="1" then
if right(cstr(n),2) <> "11" then
sAppend = "st"
end if
elseif right(cstr(n),1)="2" then
if right(cstr(n),2)<>"12" then
sAppend = "nd"
end if
elseif right(cstr(n),1)="3" then
if right(cstr(n),2)<>"13" then
sAppend = "rd"
end if
end if
DisplayOrdinal = cstr(n) & sAppend
End if
End Function
' **
' Signature:
' GetParam(sSysParamName)
' Type :
' Function
' Parameters :
' - sSysParamName : name of the parameter value to be returned. Key of the dictionary.
' Returns :
' - System parameter value.
' Assumptions:
' - Existing dGLOBAL_SYSTEM_PARAMETERS dictionary with system parameters.
' **
Function GetParam(sSysParamName)
Dim sSQL, rsSysparams
Trace(sSysParamName & " = " & dGLOBAL_SYSTEM_PARAMETERS(sSysParamName))
GetParam = dGLOBAL_SYSTEM_PARAMETERS(sSysParamName)
End Function
' **
' Signature:
' YesNo(sInput)
' Type :
' Function
' Parameters :
' - sInput : string or null to be tested.
' Returns :
' - "Yes" when string is not null or not empty.
' - "No" when string is null or empty.
' Assumptions:
' - Existing dGLOBAL_SYSTEM_PARAMETERS dictionary with system parameters.
' **
Function YesNo(sInput)
if not isEmpty(sInput) then
if IsNumeric(sInput) then
if CLng(sInput) > 0 then
YesNo = "<B><FONT color=green>YES</FONT></B>"
else
YesNo = "<B><FONT color=red>NO</FONT></B>"
end if
else
YesNo = "<B><FONT color=green>YES</FONT></B>"
end if
else
YesNo = "<B><FONT color=red>NO</FONT></B>"
end if
End Function
' **
' Signature:
' URLDecode(sURL)
' Type :
' Function
' Parameters :
' - sInput : string to be url decoded (removed url special characters).
' Returns :
' - decoded string
' Assumptions:
' - {nothing}
' **
Function URLDecode(sInput)
Dim x, sResult
if len(sInput) > 0 then
sInput = replace (sInput, "+", " ")
end if
x = InStr(sInput,"%")
Do While x > 0
sResult = sResult & Mid(sInput,1,x-1)
If LCase(Mid(sInput,x+1,1)) = "u" Then
sResult = sResult & ChrW(CLng("&H" & Mid(sInput,x+2,4)))
sInput = Mid(sInput,x+6)
Else
sResult = sResult & Chr(CLng("&H" & Mid(sInput,x+1,2)))
sInput = Mid(sInput,x+3)
End If
x = InStr(sInput,"%")
Loop
URLDecode = sResult & sInput
End Function
' **
' Signature:
' Str2URL(sURL)
' Type :
' Function
' Parameters :
' - sURL : string, url to be sufixed with "http://" for use in URLs
' Returns :
' - http:// + sURL
' Assumptions:
' - {nothing}
' **
Function Str2URL(sURL)
Str2URL = ""
If IsEmpty(sURL) then
Exit Function
End if
if Ucase(Left(sURL,7)) = "HTTP://" then
Str2URL = sURL
Exit Function
end if
if Ucase(Left(sURL,8)) = "HTTPS://" then
Str2URL = sURL
Exit Function
end if
Str2URL = "http://" & sURL
End Function
' **
' Signature:
' Write(sString)
' Type :
' Function
' Parameters :
' - sString : string to be responded to the current device (usually HTML).
' Returns :
' - {nothing}
' Output :
' - string
' Assumptions:
' - {nothing}
' **
Function Write(sString)
Response.Write sString
End Function
' **
' Signature:
' Write(sString)
' Type :
' Function
' Parameters :
' - sString : string to be responded to the current device (usually HTML).
' Returns :
' - {nothing}
' Output :
' - string and carriege return.
' Assumptions:
' - {nothing}
' **
Function WriteLn(sString)
Response.Write sString & vbCrLf
End Function
' **
' Signature:
' GetArraySize(aArray)
' Type :
' Function
' Parameters :
' - aArray : one dimentional array
' Returns :
' - integer >=0, length of the array
' - integer -1, error
' Output :
' - {nothing}
' Assumptions:
' - {nothing}
' **
Function GetArraySize(aArray)
Dim SIZE
On Error Resume Next
SIZE = UBound(aArray)
if Err then
GetArraySize = -1
Else
GetArraySize = SIZE
End if
End Function
' **
' Signature:
' DateTimeStart(sDate)
' Type :
' Function
' Parameters :
' - sDate : short date expression (no time)
' Returns :
' - date and time expression; time is set to start of the day. Usefull when comparing date ranges in SQL operations.
' Output :
' - {nothing}
' Assumptions:
' - the input must be a valid date expression formated like mm/dd/yy with two or four digits for the year.
' **
Function DateTimeStart(sDate)
Dim ArrayDATE
Dim y, t
If IsEmpty(sDate) Then
DateTimeStart = "NULL"
Else
ArrayDATE = Split(sDate,"/")
t = ArrayDATE(0) & "/" & ArrayDATE(1) & "/" & ConvertYear(ArrayDate(2))
DateTimeStart = quote(t & " 00:00:00")
End If
End Function
' **
' Signature:
' DateTimeStop(sDate)
' Type :
' Function
' Parameters :
' - sDate : short date expression (no time)
' Returns :
' - date and time expression; time is set to start of the day. Usefull when comparing date ranges in SQL operations.
' Output :
' - {nothing}
' Assumptions:
' - input must be a valid date expression formated like mm/dd/yy with two or four digits for the year.
' **
Function DateTimeStop(sDate)
Dim ArrayDATE
Dim y, t
If IsEmpty(sDate) Then
DateTimeStop = "NULL"
Else
ArrayDATE = Split(sDate,"/")
t = ArrayDATE(0) & "/" & ArrayDATE(1) & "/" & ConvertYear(ArrayDate(2))
DateTimeStop = quote(t & " 23:59:59")
End If
End Function
' **
' Signature:
' Trim(sString)
' Type :
' Function
' Parameters :
' - sString : string
' Returns :
' - string with no trailing spaces on the left and on the right. If null, empty string will be returned
' Output :
' - {nothing}
' Assumptions:
' - {nothing}
' **
Function Trim(sString)
Dim sTmp
sTmp = sString
sTmp = RTrim(sTmp)
sTmp = LTrim(sTmp)
if IsNull(sTmp) then
sTmp = ""
end if
Trim = sTmp
End Function
' **
' Signature:
' SendSimpleMail(FROM_USER_MAIL, FROM_USER_NAME, TO_USER_MAIL, TO_USER_NAME, SUBJECT, MESSAGE)
' Type :
' Function
' Parameters :
' - FROM_USER_MAIL : string, sender email
' - FROM_USER_NAME : string, sender name
' - TO_USER_MAIL : string, recipient email
' - TO_USER_NAME : string, recipient name
' - SUBJECT : string, email subject
' - MESSAGE : string, email body
' Returns :
' - true for success, false otherwise
' Output :
' - email
' Assumptions:
' - SMTPsvg.Mailer object registered on the server
' **
Function SendSimpleMail(FROM_USER_MAIL, FROM_USER_NAME, TO_USER_MAIL, TO_USER_NAME, SUBJECT, MESSAGE)
Dim SEND_DATE, FOLDER_ID
Dim SQL, res, nRowsAffected
Dim Mailer,myMail, MSG
Dim ADMIN_EMAIL
SendSimpleMail = false
ADMIN_EMAIL = GetParam("ADMIN_EMAIL")
'' SEND NOTIFICATION MESSAGE
'set Mailer = Server.CreateObject("SMTPsvg.Mailer")
'Mailer.RemoteHost = "smtprelay-01.americaneagle.com;smtprelay-02.americaneagle.com"
'Mailer.FromName = FROM_USER_NAME
'Mailer.FromAddress = FROM_USER_MAIL
'If not IsEmpty(TO_USER_MAIL) then
' Mailer.AddRecipient TO_USER_NAME , TO_USER_MAIL
'end if
'' SUBJECT
'Mailer.Subject = SUBJECT
'' BODY
'Mailer.BodyText = MESSAGE
'' SEND MAIL
'Mailer.SendMail
'' RELEASE MEMORY
'set Mailer = nothing
'''''CODED By QUALITY CLIX
Set myMail=CreateObject("CDO.Message")
myMail.Subject=SUBJECT
myMail.From=FROM_USER_MAIL
myMail.To=TO_USER_MAIL
myMail.TextBody=MESSAGE
myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing")=2
'Name or IP of remote SMTP server
myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") ="209.173.244.54"
'Server port
myMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport")=25
myMail.Configuration.Fields.Update
myMail.Send
set myMail=nothing
SendSimpleMail = true
End Function
Function SendSimpleHTMLMail(FROM_USER_MAIL, FROM_USER_NAME, TO_USER_MAIL, TO_USER_NAME, SUBJECT, MESSAGE)
Dim SEND_DATE, FOLDER_ID
Dim SQL, res, nRowsAffected
Dim Mailer, MSG
Dim ADMIN_EMAIL
SendSimpleHTMLMail = false
ADMIN_EMAIL = GetParam("ADMIN_EMAIL")
' SEND NOTIFICATION MESSAGE
set Mailer = Server.CreateObject("SMTPsvg.Mailer")
Mailer.RemoteHost = "smtprelay-01.americaneagle.com;smtprelay-02.americaneagle.com"
Mailer.FromName = FROM_USER_NAME
Mailer.FromAddress = FROM_USER_MAIL
If not IsEmpty(TO_USER_MAIL) then
Mailer.AddRecipient TO_USER_NAME , TO_USER_MAIL
end if
Mailer.ContentType = "text/html"
' SUBJECT
Mailer.Subject = SUBJECT
' BODY
Mailer.BodyText = MESSAGE
' SEND MAIL
Mailer.SendMail
' RELEASE MEMORY
set Mailer = nothing
SendSimpleHTMLMail = true
End Function
' **
' SendMail function (more flexible thatn sendsimplemail)
'
' Parameters:
'
' sFromAddress Sender email address
' sRecipients Email recipients
' This can be an email address of list of email addresses separated by comma
' sCC Carbon copy recipients
' This can be an email address of list of email addresses separated by comma
' sBCC Hidden Carbon Copy recipients
' This can be an email address of list of email addresses separated by comma
' sSubject Subject for the message
' sMsg Message body
' bIsHTML HTML email = true, Plain Text email = false
' bUseQMail Using QMail functionality = true, regular email = false
' ***
Function SendMail(sFromAddress, sRecipients, sCC, sBCC, sSubject, sMsg, bIsHTML, bUseQMail)
Dim aRecipients, aCC, aBCC, iLoop
Dim Mailer
SendMail = ""
' GET ARRAY OF RECIPIENTS
aRecipients = Split(sRecipients, ",")
if GetArraySize(aRecipients) = -1 then
Redim Preserve aRecipients(0)
aRecipients(0) = sRecipients
End if
' GET ARRAY OF CC
aCC = Split(sCC, ",")
if GetArraySize(aCC) = -1 then
Redim Preserve aCC(0)
aCC(0) = sCC
End if
' GET ARRAY OF BCC
aBCC = Split(sBCC, ",")
if GetArraySize(aBCC) = -1 then
Redim Preserve aBCC(0)
aBCC(0) = sBCC
End if
' SEND NOTIFICATION MESSAGE
set Mailer = Server.CreateObject("SMTPsvg.Mailer")
Mailer.RemoteHost = "smtprelay-01.americaneagle.com;smtprelay-02.americaneagle.com"
Mailer.FromName = sFromAddress
Mailer.FromAddress = sFromAddress
' IS THIS QMAIL?
if bUseQMail then
Mailer.QMessage = true
end if
' IS THIS HTML EMAIL?
if bIsHTML then
Mailer.ContentType = "text/html"
end if
' SET TIMOEUT FOR 18 SECONDS
Mailer.Timeout = 18
' ADD REGULAR RECIPIENTS
For iLoop=Lbound(aRecipients) to Ubound(aRecipients)
if not IsEmpty(aRecipients(iLoop)) then
Mailer.AddRecipient aRecipients(iLoop) , aRecipients(iLoop)
end if
Next
' ADD CC RECIPIENTS
For iLoop=Lbound(aCC) to Ubound(aCC)
if not IsEmpty(aCC(iLoop)) then
Mailer.AddCC aCC(iLoop) , aCC(iLoop)
end if
Next
' ADD BCC RECIPIENTS
For iLoop=Lbound(aBCC) to Ubound(aBCC)
if not IsEmpty(aBCC(iLoop)) then
Mailer.AddBCC aBCC(iLoop) , aBCC(iLoop)
end if
Next
'SUBJECT
Mailer.Subject = sSubject
' BODY
Mailer.BodyText = sMsg
'SEND MAIL
Mailer.SendMail
' RELEASE MEMORY
set Mailer = nothing
End Function
' **
' Signature:
' getValue(sField)
' Type :
' Function
' Parameters :
' - sField : string, name of value to be requested
' - GFS : session string, when "Y" the value is requested from the session collection.
' Returns :
' - string, value corresponding to the field name in sField
' Output :
' - {nothing}
' Assumptions:
' - {nothing}
' **
Function GetValue(sField)
Dim sTemp
if Instr(Request.ServerVariables("CONTENT_TYPE"), "multipart/form-data") <> 0 then
if not isObject (dGLOBAL_UPLOAD_OBJECT) then
set dGLOBAL_UPLOAD_OBJECT = Server.CreateObject("SoftArtisans.FileUp")
end if
If not IsEmpty(request.querystring("GFS")) then
sTemp = trim(Session(sField))
elseif isObject(dGLOBAL_UPLOAD_OBJECT.form(sField)) then
set sTemp = dGLOBAL_UPLOAD_OBJECT.form(sField)
else
sTemp = trim(dGLOBAL_UPLOAD_OBJECT.form(sField))
end if
else
If not IsEmpty(request.queryString("GFS")) then
sTemp = trim(Session(sField))
If IsEmpty(sTemp) Then sTemp = trim(request.form(sField))
If IsEmpty(sTemp) Then sTemp = trim(request.queryString(sField))
else
sTemp = trim(request.form(sField))
if isEmpty(sTemp) then sTemp = trim(request.queryString(sField))
end if
end if
if isObject(sTemp) then
set getValue = sTemp
else
getValue = sTemp
end if
End Function
Function GetWysiwygValue(sField)
Dim returnVal
returnVal = GetValue(sField)
If IsEmpty(returnVal) Then returnVal = ""
returnVal = Replace(returnVal, GLOBAL_REFERER_NAME, "")
returnVal = Replace(returnVal, "http://" & Request.ServerVariables("HTTP_HOST"), "")
returnVal = Replace(returnVal, "https://" & Request.ServerVariables("HTTP_HOST"), "")
GetWysiwygValue = returnVal
End Function
Function RequestTime(TIME_FIELD)
RequestTime = GetValue(TIME_FIELD&"_HOUR") & ":" & GetValue(TIME_FIELD&"_MINUTE") & " " & GetValue(TIME_FIELD&"_AMPM")
If IsEmpty(GetValue(TIME_FIELD&"_HOUR")) OR IsEmpty(GetValue(TIME_FIELD&"_MINUTE")) OR IsEmpty(GetValue(TIME_FIELD&"_AMPM")) Then
RequestTime = ""
End If
End function
Function RequestDate(DATE_FIELD)
dim sTemp, sYear
RequestDate = null
sYear= convertYear(GetValue(DATE_FIELD&"_YEAR"))
sTemp = GetValue(DATE_FIELD&"_MONTH")&"/"&GetValue(DATE_FIELD&"_DAY")&"/"& sYear
if isDate(sTemp) then
RequestDate = sTemp
else
if isEmpty(sTemp) then
RequestDate = GetValue(DATE_FIELD)
end if
end if
End function
Function RequestExpDate(DATE_FIELD)
RequestExpDate = GetValue(DATE_FIELD & "_MONTH") & "/1/" & GetValue(DATE_FIELD & "_YEAR")
if (RequestExpDate = "//") then RequestExpDate = ""
if not IsDate(RequestExpDate) then RequestExpDate = ""
End function
' **
' Signature:
' GetField(sField, sSQL)
' Type :
' Function
' Parameters :
' - sField : string, column name to be returned
' - sSQL : string, SQL statement with the column specified in sField included.
' Returns :
' - string, value of the requested column.
' Output :
' - {nothing}
' Assumptions:
' - Open Database
' **
Function GetField(sField,sSQL)
Dim res, result
Trace(sSQL)
set res = DB.execute(sSQL)
if not res.EOF then
result = res(sField)
else
result = NULL
end if
res.Close
set res = nothing
TRACE(sField & " = " & result)
GetField = result
End Function
' **
' Signature:
' HTMLEncode(sString)
' Type :
' Function
' Parameters :
' - sString : string to be HTML encoded (added special characters to out put html tags as strings).
' Returns :
' - string, HTML encoded string.
' Output :
' - {nothing}
' Assumptions:
' **
Function HTMLEncode(sString)
If IsEmpty(sString) then
HTMLEncode = sString
else
HTMLEncode = Server.HtmlEncode(sString)
end if
End Function
' **
' Signature:
' HTMLEncode(sString)
' Type :
' Function
' Parameters :
' - sString : string to be url encoded (added special characters to pass strings of values by the query string).
' Returns :
' - string, URL encoded string.
' Output :
' - {nothing}
' Assumptions:
Function URLEncode(sString)
If IsEmpty(sString) then
URLEncode = sString
else
URLEncode = Server.URLEncode(sString)
end if
End Function
Function GetFileExtension(FILE_NAME)
Dim POSITION
GetFileExtension = ""
POSITION = InstrRev(FILE_NAME, ".")
If POSITION <> 0 then
GetFileExtension = Mid(FILE_NAME, POSITION+1 , len(FILE_NAME)-POSITION)
Exit Function
End if
End Function
Function GetFileName(FILE_NAME)
Dim POSITION
GetFileName = ""
POSITION = InstrRev(FILE_NAME, "%2")
If POSITION <> 0 then
GetFileName = Mid(FILE_NAME, POSITION+2 , len(FILE_NAME)-POSITION)
Exit Function
End if
POSITION = InstrRev(FILE_NAME, "\")
If POSITION <> 0 then
GetFileName = Mid(FILE_NAME, POSITION+1 , len(FILE_NAME)-POSITION)
Exit Function
End if
POSITION = InstrRev(FILE_NAME, "/")
If POSITION <> 0 then
GetFileName = Mid(FILE_NAME, POSITION+1 , len(FILE_NAME)-POSITION)
Exit Function
End if
GetFileName = FILE_NAME
End Function
Function Display(str)
If IsEmpty(str) then
Display = " "
else
Display = str
End If
End Function
Function GetDate(FULL_DATE, MONTH_DATE, DAY_DATE, YEAR_DATE)
Dim ArrayDATE, aDate
GetDate = false
MONTH_DATE = ""
DAY_DATE = ""
YEAR_DATE = ""
TRACE("FULL_DATE=" & FULL_DATE)
If IsEmpty(FULL_DATE) then
Exit Function
End if
aDate = Split(Trim(FULL_DATE), " ")
If not IsEmpty(FULL_DATE) then
ArrayDATE = split(aDate(0),"/")
MONTH_DATE = trim(ArrayDATE(0))
DAY_DATE = trim(ArrayDATE(1))
YEAR_DATE = trim(ArrayDATE(2))
end if
GetDate = true
End Function
Function GetTime(FULL_TIME, HOUR_TIME, MINUTE_TIME, AM_PM_TIME)
Dim ArrayTMP
Dim ArrayTIME
HOUR_TIME = ""
MINUTE_TIME = ""
AM_PM_TIME = ""
If not IsEmpty(FULL_TIME) then
ArrayTMP = split(FULL_TIME," ")
AM_PM_TIME = trim(ArrayTMP(1))
ArrayTIME = split(ArrayTMP(0),":")
HOUR_TIME = trim(ArrayTIME(0))
MINUTE_TIME = trim(ArrayTIME(1))
end if
End Function
Function FormatTime(IN_TIME)
Dim HOURS
Dim MINUTES
Dim SECONDS
Dim AMPM
HOURS = Hour(IN_TIME)
MINUTES = Minute(IN_TIME)
SECONDS = Second(IN_TIME)
AMPM = "AM"
If HOURS >= 12 Then
AMPM = "PM"
HOURS = HOURS - 12
End If
If HOURS = 0 Then HOURS = HOURS + 12
If MINUTES < 10 Then MINUTES = "0" & MINUTES
If SECONDS < 10 Then SECONDS = "0" & SECONDS
FormatTime = HOURS & ":" & MINUTES & " " & AMPM
End Function
Function ConvertYear(byVal y)
Dim dTmp
If IsEmpty(y) then
Exit Function
elseif Not IsNumeric(y) then
Exit Function
End if
dTmp = CDate("1/1/" & y)
y = Year(dTmp)
ConvertYear = y
End Function
Function FormatDate(str)
Dim s, ArrayDATE
Dim MonthString, MonthArray
Dim y
if IsEmpty(str) then
Exit function
end if
s = str
MonthString = "January,February,March,April,May,June,July,August,September,October,November,December"
MonthARRAY = split(MonthString,",")
if IsEmpty(s) then
FormatDate = ""
Exit Function
end if
If not IsDate(s) then
FormatDate = ""
Exit Function
End if
s = FormatDateTime(s,2)
ArrayDATE = Split(s,"/")
y = ArrayDate(2)
y = ConvertYear(y)
FormatDate = MonthArray(ArrayDATE(0)-1) & " " & ArrayDATE(1) & ", " & y
End Function
Function BuildPhone(PHONE1, PHONE2, PHONE3)
if IsEmpty(PHONE1) then
Exit Function
end if
if IsEmpty(PHONE2) then
Exit Function
end if
if IsEmpty(PHONE3) then
Exit Function
end if
BuildPhone = PHONE1 & "-" & PHONE2 & "-" & PHONE3
End Function
Function BuildTime(hh,mm, ampm)
if IsEmpty(hh) then
Exit Function
end if
if IsEmpty(mm) then
Exit Function
end if
if IsEmpty(ampm) then
Exit Function
end if
BuildTime = hh & ":" & mm & " " & ampm
End Function
Function BuildDate(m,d,y)
Dim dayString, monthString
BuildDate = ""
if IsEmpty(m) then
Exit Function
End if
if IsEmpty(d) then
Exit Function
End if
if IsEmpty(y) then
Exit Function
End if
if Not IsNumeric(m) then
Exit Function
End if
if Not IsNumeric(d) then
Exit Function
End if
if Not IsNumeric(y) then
Exit Function
End if
d = CInt(d)
m = CInt(m)
y = CInt(y)
y = ConvertYear(y)
if d < 10 then
dayString = "0" & d
else
dayString = d
end if
if m < 10 then
monthString = "0" & m
else
monthString = m
end if
BuildDate = monthString & "/" & dayString & "/" & y
End Function
Function GetIndexInArray(arrayNAME, VALUE)
Dim i
GetIndexInArray = -1
if GetArraySize(arrayNAME) = -1 then
Exit function
end if
for i=LBound(arrayNAME) to Ubound(arrayNAME)
if UCase(trim(arrayNAME(i))) = UCase(trim(VALUE)) then
GetIndexInArray = i
Exit Function
end if
next
End Function
Function GetElement(arrayNAME, index)
Dim sResult
GetElement = ""
On Error Resume Next
sResult = arrayNAME(index)
If not Err then
GetElement = sResult
End if
End Function
Function IsInList(sList, sValue)
IsInList = IsInArray(Split(Replace(sList, ", ", ","), ","), sValue)
End Function
Function IsInArray(arrayNAME, VALUE)
Dim i
IsInArray = false
if GetArraySize(arrayNAME) = -1 then
Exit function
end if
for i=LBound(arrayNAME) to Ubound(arrayNAME)
if UCase(trim(arrayNAME(i))) = UCase(trim(VALUE)) then
IsInArray = true
Exit Function
end if
next
End Function
Function AutoInsertSQL(SQL)
Dim NEW_ID, rsResults
' STORE SQL STATEMENT FOR FUTURE USE
Session("ERROR_SQL") = SQL
On Error Resume Next
Trace(SQL)
set rsResults = DB.Execute(SQL & "; SELECT @@identity AS new_id").nextrecordset
NEW_ID = rsResults.Fields("NEW_ID").value
rsResults.close
AutoInsertSQL = NEW_ID
End Function
Function InsertSQL(SQL)
Dim NEW_ID, rsResults
' STORE SQL STATEMENT FOR FUTURE USE
Session("ERROR_SQL") = SQL
On Error Resume Next
Trace(SQL)
set rsResults = DB.Execute(SQL)
NEW_ID = rsResults.Fields("NEW_ID").value
rsResults.close
InsertSQL = NEW_ID
End Function
Function ExecuteSQL(SQL)
Dim nRowsAffected
nRowsAffected = 0
' STORE SQL STATEMENT FOR FUTURE USE
Session("ERROR_SQL") = SQL
On Error Resume Next
Trace(SQL)
DB.execute SQL, nRowsAffected, &H00000080
ExecuteSQL = nRowsAffected
End Function
Sub OpenDatabase()
Dim SQL
If TypeName(DB) = "Connection" then
Exit Sub
end if
Trace("OPEN DATABASE")
Set DB = Server.CreateObject("ADODB.Connection")
' SET TIMEOT TO CONNECTION
DB.ConnectionTimeout = GLOBAL_CONNECTION_TIMEOUT
Db.Errors.Clear
End Sub
Sub CloseDatabase()
If Not TypeName(DB) = "Connection" then
Exit Sub
end if
Trace("CLOSE DATABASE")
DB.close
Set DB = nothing
End Sub
Sub Trace(str)
'RAY
'Response.Write vbCrLf & "<!-- TRACE: " & str & " //-->" & vbCrLf
End Sub
Function IsEmpty(s)
If IsNull(s) Then
IsEmpty = True
Else
If len(Trim(s)) = 0 Then
IsEmpty = True
Elseif Trim(s) = "NULL" Then
IsEmpty = True
Else
IsEmpty = False
End If
End If
End Function
Function chk2str(chk)
Dim value
value = chk
if not IsEmpty(value) then value = "Y"
chk2str = quote(value)
End Function
Function DateTime(s)
DateTime = Quote(s)
End Function
Function Time(s)
Dim ArrayTIME
Dim t
t=s
If not IsEmpty(t) Then
TRACE("TIME=" & t)
ArrayTIME = Split(t,":")
t = ArrayTIME(0) & ":" & ArrayTIME(1)
End If
Time = quote(t)
End Function
Function Number(n)
Dim t
If IsEmpty(n) Then
Number = "NULL"
Else
On Error Resume Next
t = CDbl(n)
if Err then
Number = "NULL"
else
Number = t
end if
End If
End Function
Function FilterQuote(s)
Dim t
If IsEmpty(s) Then
FilterQuote = "NULL"
Else
t = Replace(s,"'","''")
t = Trim(t)
FilterQuote = "'%" & t & "%'"
End If
End Function
Function Quote(s)
Dim t
If IsEmpty(s) Then
Quote = "NULL"
Else
t = Replace(s,"'","''")
t = Trim(t)
Quote = "'" & t & "'"
End If
End Function
Function GetText(FIELD)
Dim TEMP
GetText = ""
TEMP = FIELD.GetChunk(256)
While Not IsEmpty(TEMP)
GetText = GetText & TEMP
TEMP = FIELD.GetChunk(256)
Wend
End Function
Function Max(a,b)
If a - b < 0 then
Max = b
Else
Max = a
End if
End Function
Function Min(a,b)
If a - b < 0 then
Min = a
Else
Min = b
End if
End Function
Function IsLeap (sYear)
If IsDate("02/29/" & sYear) Then
IsLeap = True
Else
IsLeap = False
End If
End Function
Function GetNumOfDays(DATE_MONTH, DATE_YEAR)
Dim StringArray, MonthArray
MonthArray = Array(31,28,31,30,31,30,31,31,30,31,30,31)
DATE_YEAR = ConvertYear(DATE_YEAR)
If DATE_MONTH - 1 < 0 Or DATE_MONTH - 12 > 0 then
Exit Function
End if
If IsLeap(DATE_YEAR) then
MonthArray(1) = MonthArray(1) + 1
End if
GetNumOfDays = MonthArray(DATE_MONTH - 1)
End Function
Function Str2HTML(sText)
Str2HTML = ""
If IsEmpty(sText) then
Exit Function
End if
Str2HTML = Replace(sText, vbCrLf, "<br>")
End Function
Function trimWYSIWYG(sStr)
if not isEmptyWYSIWYG(sStr) then
if left(sStr,3)="<P>" then
sStr=Right(sStr,len(sSTr)-3)
end if
if Right(sStr,4)="</P>" then
sStr=Left(sStr, len(sStr)-4)
end if
end if
trimWYSIWYG=sStr
End function
Function IsEmptyWYSIWYG(byVal sString)
IsEmptyWYSIWYG = false
sString = trim(sString)
if instr(uCase(sString ), "<IMG") = 0 then
sString = stripHTML(sString)
sString = replace(sString, vbCrlf, "")
end if
sString = replace(sString, " ", "")
if isEmpty(sString) then
IsEmptyWYSIWYG = true
end if
End function
' Strips the HTML tags from strHTML
Function stripHTML(ByVal strHTML)
strHTML = trim(strHTML)
Dim objRegExp, strOutput
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<(.|\n)+?>"
'Replace all HTML tag matches with the empty string
strOutput = objRegExp.Replace(strHTML, " ")
'Replace all < and > with < and >
strOutput = Replace(strOutput, "<", "<")
strOutput = Replace(strOutput, ">", ">")
strOutput = Replace(strOutput, " ", " ")
stripHTML = strOutput 'Return the value of strOutput
Set objRegExp = Nothing
End Function
Function CopyFile(strFileSource, strFileDestination, byRef strError)
Dim fso, f2
if IsEmpty(strFileSource) OR IsEmpty(strFileDestination) then
strError = "Error - You must supply both a source and a destination"
exit function
end if
set fso = Server.CreateObject("Scripting.FileSystemObject")
if Not fso.FileExists(strFileSource) then
strError = "Error - Source file does not exist"
exit function
end if
if IsEmpty(strError) then
Set f2 = fso.GetFile(strFileSource)
f2.Copy(strFileDestination)
Set f2 = nothing
end if
Set fso = nothing
End Function
function aspinfotext()
Dim ServerVariablesArray
Dim i, v, ELEMENTS_ARRAY
ELEMENTS_ARRAY = array("Request.Form", "Request.QueryString", "Application.Contents", "Session.Contents", "Request.Cookies", "Request.ClientCertificate", "Request.ServerVariables")
ServerVariablesArray = ""
for i = 0 to ubound(ELEMENTS_ARRAY)
for each v in eval(ELEMENTS_ARRAY(i))
ServerVariablesArray = ServerVariablesArray & v
On Error Resume Next
ServerVariablesArray = ServerVariablesArray & " " & eval(ELEMENTS_ARRAY(i) & "(""" & v & """)") & vbCrlf
If Err then
ServerVariablesArray = ServerVariablesArray & " N/A" & vbCrlf
end if
On Error Goto 0
next
next
aspinfotext = ServerVariablesArray
end function
function aspinfo()
Dim ServerVariablesArray
Dim i, v, ELEMENTS_ARRAY
ELEMENTS_ARRAY = array("Request.Form", "Request.QueryString", "Application.Contents", "Session.Contents", "Request.Cookies", "Request.ClientCertificate", "Request.ServerVariables")
ServerVariablesArray = ""
for i = 0 to ubound(ELEMENTS_ARRAY)
ServerVariablesArray = ServerVariablesArray & "<P><TABLE width=600 cellpadding=0 cellspacing=0 border=0 align=center><TR bgcolor=000000><TD>" & vbCrlf
ServerVariablesArray = ServerVariablesArray & "<TABLE width=100% cellpadding=2 cellspacing=1 border=0 align=center>" & vbCrlf
ServerVariablesArray = ServerVariablesArray & "<TR bgcolor=9999CC><TH colspan=2 width=""100%"">" & ELEMENTS_ARRAY(i) & "</TH></TR>" & vbCrlf
for each v in eval(ELEMENTS_ARRAY(i))
ServerVariablesArray = ServerVariablesArray & "<TR valign=top><TD bgcolor=CCCCFF width=""25%"">" & v & "</TD>" & vbCrlf
On Error Resume Next
ServerVariablesArray = ServerVariablesArray & "<TD bgcolor=CCCCCC>" & eval(ELEMENTS_ARRAY(i) & "(""" & v & """)") & "</TD></TR>" & vbCrlf
If Err then
ServerVariablesArray = ServerVariablesArray & "<TD bgcolor=CCCCCC>N/A</TD></TR>" & vbCrlf
end if
On Error Goto 0
next
ServerVariablesArray = ServerVariablesArray & "</TABLE>" & vbCrlf
ServerVariablesArray = ServerVariablesArray & "</TD></TR></TABLE></P>" & vbCrlf
next
aspinfo = ServerVariablesArray
end function
Function REReplace(sStringToSearch, sPattern, sReplacement)
Dim oRegExp
Set oRegExp = New RegExp
oRegExp.Pattern = sPattern
oRegExp.Global = True
oRegExp.IgnoreCase = False
REReplace = oRegExp.Replace(sStringToSearch, sReplacement)
End Function
Function REReplaceNoCase(sStringToSearch, sPattern, sReplacement)
Dim oRegExp
Set oRegExp = New RegExp
oRegExp.Pattern = sPattern
oRegExp.Global = True
oRegExp.IgnoreCase = True
REReplaceNoCase = oRegExp.Replace(sStringToSearch, sReplacement)
End Function
' **
' Signature:
' HttpXmlGet (sMethod, sUrl, sUserName, sPassword, sSendType, sSendData)
' Type :
' Function
' Parameters :
' - sMethod: required; string; "post" or "get" (not case sensitive)
' - sUrl: required; string; Address you are posting/getting and later reading
' - sUserName/sPassword: optional; string.
' - sSendType: required; string; type of data you are sending, only XML and
' VALUEPAIRS have been implemented here, so far.
' - sSendData: optional; string; XML to pass, value pairs built like a query string
' or check Microsoft documentation for other types.
' Returns : string with response from the URL of the type requested on sSendType
' Assumptions:
' - MSXML2.XMLHTTP component present (Microsfot XMLHTTP V.3 or later)
' **
function HttpXmlGet(sMethod, sUrl, sUserName, sPassword, sSendType, sSendData)
dim oHttpXml, bASync
dim sResult
bASync = false 'wait for the full response to be back (check documentation)
set oHttpXml = server.createObject("MSXML2.XMLHTTP")
oHttpXml.open sMethod, sUrl, bASync, sUserName, sPassword
select case sSendType
case "XML"
oHttpXml.setRequestHeader "Content-Type", "text/xml"
oHttpXml.send(sSendData)
sResult = oHttpXml.responseXML.xml
case "VALUEPAIRS"
oHttpXml.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
oHttpXml.send(sSendData)
sResult = oHttpXml.responseText
end select
set oHttpXml = nothing
HttpXmlGet = trim(sResult)
end function
Function UCFirst(strWord)
strWord = trim(strWord & "")
if len(strWord) > 0 then
ucFirst = uCase(left(strWord, 1)) & _
lcase(right(strWord, len(strWord) - 1))
end if
End Function
Function TitleCase(strWords)
Dim arWords, i, strFormatted
strWords = trim(strWords & "")
strFormatted = ""
if len(strWords) > 0 then
arWords = split(strWords, " ")
for i = 0 to uBound(arWords)
strFormatted = strFormatted & " " & ucFirst(arWords(i))
next
end if
ucWords = strFormatted
End Function
Function GenerateImage(sOriginalPath, sSavePath, HEIGHT, WIDTH)
Dim jpeg
Set jpeg = Server.CreateObject("ImageResize.ImageResize")
Call jpeg.ResizeImage(Server.MapPath(sOriginalPath), Server.MapPath(sSavePath), Height, Width)
Set jpeg = Nothing
End Function
%>
|