ASP 語法 2

==============================================================
//get remote html
var url = "http://www.google.com.tw";
var xmlhttp = new ActiveXObject("MSXML2.ServerXMLHTTP");
xmlhttp.open("GET", url, 0);
xmlhttp.send("k=v");
document.getElementById("divContent").innerHTML = xmlhttp.responseText;
//document.write(xmlhttp.responseText);
xmlhttp = null;
==============================================================
//read xml config
Function getParameter(Section,ValueTag)
Dim objDOM
Set objDOM=Server.CreateObject("MSXML2.DOMDocument")
If objDOM.load(Server.MapPath("config/config.xml")) Then
selPath="/CONFIGURATION/" & Section & "/" & ValueTag
Set selNode=objDOM.documentElement.selectSingleNode(selPath)
If TypeName(selNode)="Nothing" Then
getParameter=""
ELse
getParameter=selNode.text
End If
Else
getParameter=""
End If
Set objDOM=Nothing
End Function

getParameter("TEST","DatabaseServer")

<?xml version="1.0" encoding="Big5"?>
<CONFIGURATION>
<TEST>
<DatabaseServer>10.0.0.0</DatabaseServer>
<DatabaseName>test</DatabaseName>
<DatabaseUserID>sa</DatabaseUserID>
<DatabasePassword>12345</DatabasePassword>
</TEST>
<PRD>
<DatabaseServer>11.11.11.11</DatabaseServer>
<DatabaseName>prd</DatabaseName>
<DatabaseUserID>sa</DatabaseUserID>
<DatabasePassword>56789</DatabasePassword>
</PRD>
</CONFIGURATION>
==============================================================
//generate guid
Function GetGuid()
Set TypeLib = CreateObject("Scriptlet.TypeLib")
GetGuid = replace(replace(Left(CStr(TypeLib.Guid), 38) ,"{",""),"}","")
Set TypeLib = Nothing
End Function
Response.Write GetGuid() 'E243B21C-9899-4068-9889-2D2C5225A35B
==============================================================
// URLEncode/URLDecode (not support 中文)
Function URLDecode(str)
str = Replace(str, "+", " ")
For i = 1 To Len(str)
sT = Mid(str, i, 1)
If sT = "%" Then
If i+2 < Len(str) Then
sR = sR & _
Chr(CLng("&H" & Mid(str, i+1, 2)))
i = i+2
End If
Else
sR = sR & sT
End If
Next
URLDecode = sR
End Function

Function URLEncode(str)
URLEncode = Server.URLEncode(str)
End Function

str1 = "http://www.google.com/abc.asp?p1=ABC&p2=123"
str2 = URLEncode(str1) 'http%3A%2F%2Fwww%2Egoogle%2Ecom%2Fabc%2Easp%3Fp1%3DABC%26p2%3D123
str3 = URLDecode(str2) 'http://www.google.com/abc.asp?p1=ABC&p2=123
==============================================================
//URLDecode 支援中文
Private Function URLDecode(strValue)
Dim varAry, varElement, objStream, lngLoop, Flag
strValue = Replace(strValue, "+", " ")
varAry = Split(strValue, "%")
Flag = varAry(0) = ""
Set objStream = Server.CreateObject("ADODB.Stream")
With objStream
.Type = 2
.Mode = 3
.Open
For Each varElement In varAry
If varElement <> Empty Then
If Len(varElement) >= 2 And Flag Then
.WriteText ChrB(CInt("&H" & Left(varElement, 2)))
For lngLoop = 3 To Len(varElement)
.WriteText ChrB(Asc(Mid(varElement, lngLoop, 1)))
Next
Else
For lngLoop = 1 To Len(varElement)
.WriteText ChrB(Asc(Mid(varElement, lngLoop, 1)))
Next
Flag = True
End If
End If
Next
.WriteText Chr(0)
.Position = 0
URLDecode = Replace(ConvUnicode(.ReadText), Chr(0), "", 1, -1, 0)
On Error Resume Next
.Close
Set objStream = Nothing
End With
End Function

Public Function ConvUnicode(ByVal strData)
Dim rs, stm, bytAry, intLen
If Len(strData & "") > 0 Then
strData = MidB(strData, 1)
intLen = LenB(strData)
Set rs = Server.CreateObject("ADODB.Recordset")
Set stm = Server.CreateObject("ADODB.Stream")
With rs
.Fields.Append "X", 205, intLen
.Open
.AddNew
rs(0).AppendChunk strData & ChrB(0)
.Update
bytAry = rs(0).GetChunk(intLen)
End With
With stm
.Type = 1
.Open
.Write bytAry
.Position = 0
.Type = 2
.Charset = "Big5"
ConvUnicode = .ReadText
End With
End If
On Error Resume Next
stm.Close
Set stm = Nothing
rs.Close
Set rs = Nothing
End Function

dim urlEncode
urlEncode = server.URLEncode("http://www.google.com/abc.asp?p1=ABC&p2=中文")
'Response.Write(urlEncode) 'http%3A%2F%2Fwww%2Egoogle%2Ecom%2Fabc%2Easp%3Fp1%3DABC%26p2%3D%A4%A4%A4%E5
'Response.Write(URLDecode(urlEncode)) 'http://www.google.com/abc.asp?p1=ABC&p2=中文
==============================================================
//Unicode 轉成系統的預設編碼
Private Function FromUnicode(strData)
Dim objStm
Set objStm = Server.CreateObject("ADODB.Stream")
With objStm
.Charset = "Big5"
.Type = 2
.Open
.WriteText strData
.Position = 0
.Charset = "Unicode"
.Type = 1
FromUnicode = MidB(.Read, 1)
End With
End Function

//系統的預設編碼轉成 Unicode
Public Function ConvUnicode(ByVal strData)
Dim rs, stm, bytAry, intLen
If Len(strData & "") > 0 Then
strData = MidB(strData, 1)
intLen = LenB(strData)
Set rs = Server.CreateObject("ADODB.Recordset")
Set stm = Server.CreateObject("ADODB.Stream")
With rs
.Fields.Append "X", 205, intLen
.Open
.AddNew
rs(0).AppendChunk strData & ChrB(0)
.Update
bytAry = rs(0).GetChunk(intLen)
End With

With stm
.Type = 1
.Open
.Write bytAry
.Position = 0
.Type = 2
.Charset = "Big5"
ConvUnicode = .ReadText
End With
End If

On Error Resume Next
stm.Close
Set stm = Nothing
rs.Close
Set rs = Nothing
End Function

'簡體轉換測試
Response.Write ConvUnicode(FromUnicode("?索的字?或字符?"))
==============================================================
//global.asa (online user count)
<script language=vbScript runat=server>

sub session_onStart()

application.lock()
application("SCount") = application("SCount") + 1
application.unlock()

end sub

sub session_onEnd()

application.lock()
application("SCount") = application("SCount") - 1
application.unlock()

end sub

sub application_onStart()

' don't need a lock in onStart()
application("SCount") = 0

end sub

</script>
==============================================================
//變色顯示關鍵字
Function ShowKeyWord(strContent,word)
If word="" Then
ShowKeyWord = strContent
Exit Function
End IF
dim objRegExp
Set objRegExp=new RegExp
objRegExp.IgnoreCase =true
objRegExp.Global=True

objRegExp.Pattern="(" & word & ")"
strContent=objRegExp.Replace(strContent,"$1" )

Set objRegExp=Nothing
ShowKeyWord=strContent
End Function

Response.Write(ShowKeyWord("投資組合有其風險,故需謹慎投資金錢","投資"))
==============================================================
//計算中文字數
Function GetLength(strChinese1)
Dim strWord, ascWord, lenTotal
strChinese1 = Trim(strChinese1)

If strChinese1 = "" Or Vartype(strChinese1) = vbNull Then
GetLength = 0
Exit Function
End If

lenTotal = 0
For GetLengthi=1 to Len(strChinese1)
strWord = Mid(strChinese1, GetLengthi, 1)
ascWord = Asc(strWord)
If ascWord < 0 or ascWord > 127 then
lenTotal = lenTotal + 1
Elseif ascWord = 63 And strWord <> "?" then
lenTotal = lenTotal + 1
Elseif ascWord = 44 And strWord <> "," then
lenTotal = lenTotal + 1
Elseif ascWord = 33 And strWord <> "!" then
lenTotal = lenTotal + 1
Else
lenTotal = lenTotal
End If
Next

GetLength = lenTotal
End Function

Response.Write(GetLength("A5中文字數K91")) '4
==============================================================
//取出多筆資料的所有欄位和值
<%
dim case_no
if Request.QueryString("case_no") = vbnullstring then
case_no = 608598
else
case_no = Request.QueryString("case_no")
end if

dim connstr ,Conn ,Rs, strSql
connstr = "driver={SQL Server};server=10.86.18.104,1744;uid=gmuw;pwd=gmuw;database=gmcard_rd"
Set Conn = Server.CreateObject("ADODB.Connection")
Conn.Open connstr
strSql = "select case apy_type when 1 then '現金卡' else '信貸' end as 種類 ,* from application_status where case_no = " & case_no
'strSql = "select * from application_detail where case_no = " & case_no
'strSql = "select * from vw_case_info where case_no = " & case_no

set Rs = CreateObject("ADODB.Recordset")
Rs.Open strSql,Conn ,1,1

'for each x in Rs.Fields '該筆資料的所有欄位和值
'Response.Write x.Name & "="
'Response.Write x.Value & " "
'next
while not Rs.eof '多筆資料的所有欄位和值
for i=0 to Rs.Fields.Count -1
Response.Write "" & Rs(i).Name & "="
Response.Write Rs(i).Value & " "
next
Response.Write ""
Rs.MoveNext
wend
Response.Write "  "
%>
==============================================================
//Recordset Sort Filter
dim connstr ,Conn ,Rs, strSql
connstr = "driver={SQL Server};server=10.86.18.104,1744;uid=gmuw;pwd=gmuw;database=gmcard_rd"
Set Conn = Server.CreateObject("ADODB.Connection")
Conn.Open connstr

strSql = "select top 30 * from application_status"
set Rs = CreateObject("ADODB.Recordset")
Rs.CursorLocation = 3
Rs.Open strSql,Conn ,3, 3

Rs.Sort = "case_no desc"
Rs.Filter = "case_no > 605159"
while not Rs.eof
Response.Write Rs("case_no") & " "
Rs.MoveNext
wend

Rs.Close()
Conn.Close()
set Rs = Nothing
set Conn = Nothing
==============================================================
//String 2 Binary/Binary 2 String (only support english)
Function StringToBinary(Text, CharSet)
Const adTypeText = 2
Const adTypeBinary = 1

'Create Stream object
Dim BinaryStream 'As New Stream
Set BinaryStream = CreateObject("ADODB.Stream")

'Specify stream type - we want To save text/string data.
BinaryStream.Type = adTypeText

'Specify charset For the source text (unicode) data.
If Len(CharSet) > 0 Then
BinaryStream.CharSet = CharSet
Else
BinaryStream.CharSet = "us-ascii"
End If

'Open the stream And write text/string data To the object
BinaryStream.Open
BinaryStream.WriteText Text

'Change stream type To binary
BinaryStream.Position = 0
BinaryStream.Type = adTypeBinary

'Ignore first two bytes - sign of
BinaryStream.Position = 0

'Open the stream And get binary data from the object
StringToBinary = BinaryStream.Read
End Function

Function BinaryToString(Binary)
Dim I, S
For I = 1 To LenB(Binary)
S = S & Chr(AscB(MidB(Binary, I, 1)))
Next
BinaryToString = S
End Function

'test
dim binary
binary = StringToBinary("only support english 0987", "us-ascii")
'Response.Write lenb(binary) '25
'Response.BinaryWrite binary 'only support english 0987
'Response.Write chr(ascb(midb(binary,2,1))) 'n index start from 1

'Response.Write BinaryToString(binary) 'only support english 0987
==============================================================

Home

搜尋此網誌

ASP 語法 2

標籤