Set objDict = server.CreateObject("Scripting.Dictionary") objDict.CompareMode = 1
CreateKeywords
Set objFSO = server.CreateObject("Scripting.FileSystemObject") End Sub
Private Sub Class_Terminate() Set objDict = Nothing Set objFSO = Nothing End Sub
Public Property Let CodeColor(inColor) m_CodeColor = "<font color=" & inColor & "><Strong>" End Property Private Property Get CodeColor() CodeColor = m_CodeColor End Property
Public Property Let CommentColor(inColor) m_CommentColor = "<font color=" & inColor & ">" End Property Private Property Get CommentColor() CommentColor = m_CommentColor End Property
Public Property Let StringColor(inColor) m_StringColor = "<font color=" & inColor & ">" End Property Private Property Get StringColor() StringColor = m_StringColor End Property
Public Property Let TabSpaces(inSpaces) m_TabSpaces = inSpaces End Property Private Property Get TabSpaces() TabSpaces = m_TabSpaces End Property
Public Property Let TableBGColor(inColor) m_TableBGColor = inColor End Property
Private Property Get TableBGColor() TableBGColor = m_TableBGColor End Property
Public Property Get ProcessingTime() ProcessingTime = Second(m_EndTime - m_StartTime) End Property
Public Property Get LineCount() LineCount = m_LineCount End Property
Public Property Get PathToFile() PathToFile = m_strPathToFile End Property Public Property Let PathToFile(inPath) m_strPathToFile = inPath End Property
Private Property Let KeyMin(inMin) m_intKeyMin = inMin End Property Private Property Get KeyMin() KeyMin = m_intKeyMin End Property Private Property Let KeyMax(inMax) m_intKeyMax = inMax End Property Private Property Get KeyMax() KeyMax = m_intKeyMax End Property
' Check for the top script line that set's the default script language ' for the page. If left( tempString, 3 ) = Chr(60) & "%@" And right(tempString, 2) = "%" & Chr(62) Then Response.Write "<table><tr bgcolor=yellow><td>" Response.Write server.HTMLEncode(m_strReadLine) Response.Write "</td></tr></table>" blnInScriptBlock = False ' Check for an opening script tag ElseIf Left( tempString, 2) = Chr(60) & "%" Then ' Check for a closing script tag on the same line If right( RTrim(tempString), 2 ) = "%" & Chr(62) Then Response.Write "<table><tr><td bgcolor=yellow><%</td>" Response.Write "<td>" Response.Write CharacterParse(mid(m_strReadLine, 3, Len(m_strReadLine) - 4)) Response.Write "</td>" Response.Write "<td bgcolor=yellow>%gt;</td></tr></table>" blnInScriptBlock = False Else Response.Write "<table><tr bgcolor=yellow><td><%</td></tr></table>" ' We've got an opening script tag so set the flag to true so ' that we know to start parsing the lines for keywords/comments blnInScriptBlock = True End If Else If blnInScriptBlock Then If blnEmptyLine Then Response.Write vbCrLf Else If right(tempString, 2) = "%" & Chr(62) Then Response.Write "<table><tr bgcolor=yellow><td>%></td></tr></table>" blnInScriptBlock = False Else Response.Write CharacterParse(m_strReadLine) & vbCrLf End If End If Else If blnOutputHTML Then If blnEmptyLine Then Response.Write vbCrLf Else Response.Write server.HTMLEncode(m_strReadLine) & vbCrLf End If End If End If End If Loop
' Grab the time at the completion of processing m_EndTime = Time()
' Close the outside table Response.Write "</PRE></td></tr></table>"
' Close the file and destroy the file object objFile.close Set objFile = Nothing End Sub
' This function parses a line character by character Private Function CharacterParse(inLine) Dim charBuffer, tempChar, i, outputString Dim insideString, workString, holdChar
insideString = False outputString = ""
For i = 1 to Len(inLine) tempChar = mid(inLine, i, 1) Select Case tempChar Case " " If Not insideString Then charBuffer = charBuffer & " " If charBuffer <>" " Then If left(charBuffer, 1) = " " Then outputString = outputString & " "
' Check for a 'rem' style comment marker If LCase(Trim(charBuffer)) = "rem" Then outputString = outputString & CommentColor outputString = outputString & "REM" workString = mid( inLine, i, Len(inLine)) workString = replace(workString, "<", "＆ｌｔ；") workString = replace(workString, ">", "＆ｇｔ；") outputString = outputString & workString & "</font>" charBuffer = "" Exit For End If
outputString = outputString & FindReplace(Trim(charBuffer)) If right(charBuffer, 1) = " " Then outputString = outputString & " " charBuffer = "" End If Else outputString = outputString & " " End If Case "(" If left(charBuffer, 1) = " " Then outputString = outputString & " " End If outputString = outputString & FindReplace(Trim(charBuffer)) & "(" charBuffer = "" Case Chr(60) outputString = outputString & "<" Case Chr(62) outputString = outputString & ">" Case Chr(34) ' catch quote chars and flip a boolean variable to denote that ' whether or not we're "inside" a quoted string insideString = Not insideString If insideString Then outputString = outputString & StringColor outputString = outputString & "＆ｑｕｏｔ；" Else outputString = outputString & """" outputString = outputString & "</font>" End If Case "'" ' Catch comments and output the rest of the line ' as a comment IF we're not inside a string. If Not insideString Then outputString = outputString & CommentColor workString = mid( inLine, i, Len(inLine)) workString = replace(workString, "<", "＆ｌｔ；") workString = replace(workString, ">", "＆ｇｔ；") outputString = outputString & workString outputString = outputString & "</font>" Exit For Else outputString = outputString & "'" End If Case Else ' We've dealt with special case characters so now ' we'll begin adding characters to our outputString ' or charBuffer depending on the state of the insideString ' boolean variable If insideString Then outputString = outputString & tempChar Else charBuffer = charBuffer & tempChar End If End Select Next
' Deal with the last part of the string in the character buffer If Left(charBuffer, 1) = " " Then outputString = outputString & " " End If ' Check for closing parentheses at the end of a string If right(charBuffer, 1) = ")" Then charBuffer = Left(charBuffer, Len(charBuffer) - 1) CharacterParse = outputString & FindReplace(Trim(charBuffer)) & ")" Exit Function End If
CharacterParse = outputString & FindReplace(Trim(charBuffer)) End Function
' return true or false if a passed in number is between KeyMin and KeyMax Private Function InRange(inLen) If inLen >= KeyMin And inLen <= KeyMax Then InRange = True Exit Function End If InRange = False End Function
' Evaluate the passed in string and see if it's a keyword in the ' dictionary. If it is we will add html formatting to the string ' and return it to the caller. Otherwise just return the same ' string as was passed in. Private Function FindReplace(inToken) ' Check the length to make sure it's within the range of KeyMin and KeyMax If InRange(Len(inToken)) Then If objDict.Exists(inToken) Then FindReplace = CodeColor & objDict.Item(inToken) & "</Strong></Font>" Exit Function End If End If ' Keyword is either too short or too long or doesn't exist in the ' dictionary so we'll just return what was passed in to the function FindReplace = inToken End Function
End Class %>
使用前把里面的全角字符转换成半角的
<!--#include file="token.asp"--> <% ' ************************************************************************* ' This is all test/example code showing the calling syntax of the ' cBuffer class ... the interface to the cBuffer object is quite simple. ' ' Use it for reference ... delete it ... whatever. ' *************************************************************************
REM This is a rem type comment just for testing purposes!
' This variable will hold an instance of the cBuffer class Dim objBuffer
' Set up the error handling On Error Resume Next
' create the instance of the cBuffer class Set objBuffer = New cBuffer
' Set the PathToFile property of the cBuffer class ' ' Just for kicks we'll use the asp file that we created ' in the last installment of this article series for testing purposes objBuffer.PathToFile = "../081899/random.asp" '这是文件名啦。
' Here's an example of how to add a new keyword to the keyword array ' You could add a list of your own function names, variables or whatever...cool! ' NOTE: You can add different HTML formatting if you like, the <strong> ' attribute will applied to all keywords ... this is likely to change ' in the near future. ' 'objBuffer.AddKeyword "response.write", "<font color=Red>Response.Write</font>"
' Here are examples of changing the table background color, code color, ' comment color, string color and tab space properties ' 'objBuffer.TableBGColor = "LightGrey" ' or 'objBuffer.TableBGColor = "#ffffdd" ' simple right? 'objBuffer.CodeColor = "Red" 'objBuffer.CommentColor = "Orange" 'objBuffer.StringColor = "Purple" 'objBuffer.TabSpaces = " "
' Call the ParseFile method of the cBuffer class, pass it true if you want the ' HTML contained in the page output or false if you don't objBuffer.ParseFile False '注意：显示代码的response.write已经在class中。这里调用方法就可以了。
' Check for errors that may have been raised and write them out If Err.number <> 0 Then Response.Write Err.number & ":" & Err.description & ":" & Err.source & "<br>" End If
' Output the processing time and number of lines processed by the script Response.Write "<strong>Processing Time:</strong> " & objBuffer.ProcessingTime & " seconds<br>" Response.Write "<strong>Lines Processed:</strong> " & objBuffer.LineCount & "<br>"
' Destroy the instance of our cBuffer class Set objBuffer = Nothing %>
引用自http://www.china-askpro.com/vbasic11.shtml ]]>http://www.is21.cn/default.asp?id=378<![CDATA[透明效果]]>adminhttp://www.is21.cn/lianxiangpanjin@163.com2008-06-21T01:40:46+08:002008-06-21T01:40:46+08:00 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20) ' 设置窗体的透明度
Private Const LWA_ALPHA = &H2
Private Sub Form_Activate()
On Error Resume Next
For i = 0 To 150 Step 2.5
SetLayeredWindowAttributes Me.hwnd, 0, i, LWA_ALPHA
'打开、另存文件对话框 Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type
'打开目录对话框 Public Declare Function SHGetPathFromIDList Lib "Shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Public Declare Function SHBrowseForFolder Lib "Shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Public Const BIF_RETURNONLYFSDIRS = &H1 Public pidl As Long
'读取INI文件 Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
'移动、复制、删除目录 Declare Function SHFileOperation Lib "Shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long Type SHFILEOPSTRUCT hwnd As Long '窗口句柄 wFunc As Long '执行的操作 pFrom As String '原地点 pTo As String '目标地点 fFlags As Long '操作执行方式 fAnyOperationsAborted As Long '错误代码返回 hNameMappings As Long lpszProgressTitle As String End Type Public Const FO_MOVE As Long = &H1 Public Const FO_COPY As Long = &H2 Public Const FO_Delete As Long = &H3 Public Const FO_RENAME As Long = &H4 Public Const FOF_MULTIDESTFILES As Long = &H1 Public Const FOF_CONFIRMMOUSE As Long = &H2 Public Const FOF_SILENT As Long = &H4 Public Const FOF_RENAMEONCOLLISION As Long = &H8 Public Const FOF_NOCONFIRMATION As Long = &H10 Public Const FOF_WANTMAPPINGHANDLE As Long = &H20 Public Const FOF_CreatePROGRESSDLG As Long = &H0 Public Const FOF_ALLOWUNDO As Long = &H40 Public Const FOF_FILESONLY As Long = &H80 Public Const FOF_SIMPLEPROGRESS As Long = &H100 Public Const FOF_NOCONFIRMMKDIR As Long = &H200
'读写注册表 Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value. Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value. Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Const HKEY_CLASSES_ROOT = &H80000000 Public Const HKEY_CURRENT_USER = &H80000001 Public Const HKEY_LOCAL_MACHINE = &H80000002
Function wReadIni(wAppName As String, wKeyName As String, wIniFilePath As String) As String Dim RetStr As String RetStr = String(255, Chr(0)) wReadIni = Left(RetStr, GetPrivateProfileString(wAppName, ByVal wKeyName, "", RetStr, Len(RetStr), wIniFilePath)) End Function
Function wWriteIni(wAppName As String, wKeyName As String, wText As String, wIniFilePath As String) As Long wWriteIni = WritePrivateProfileString(wAppName, wKeyName, wText, wIniFilePath) End Function
Function wCutFolder(wSource As String, wDestination As String, wHwnd As Long) As Long Dim DelFileOp As SHFILEOPSTRUCT
.fFlags = FOF_NOCONFIRMATION End With wCopyFolder = SHFileOperation(DelFileOp) End Function Function wDelFolder(wFoldPath As String, wHwnd As Long) As Long Dim DelFileOp As SHFILEOPSTRUCT
.fFlags = FOF_NOCONFIRMATION End With wDelFolder = SHFileOperation(DelFileOp) End Function
Function wSelectFolder(wCaption As String, wHwnd As Long) As String Dim bi As BROWSEINFO Dim r As Long Dim pidl As Long Dim path As String Dim pos As Integer '句柄 bi.hOwner = wHwnd '展开根目录 bi.pidlRoot = 0& '列表框标题 bi.lpszTitle = wCaption '规定只能选择文件夹，其他无效 bi.ulFlags = BIF_RETURNONLYFSDIRS '调用API函数显示列表框 pidl = SHBrowseForFolder(bi) '利用API函数获取返回的路径 path = Space$(512) r = SHGetPathFromIDList(ByVal pidl&, ByVal path) If r Then pos = InStr(path, Chr$(0)) wSelectFolder = Left(path, pos - 1) Else wSelectFolder = "" End If End Function
Function wOpenFile(wCaption As String, wFilter As String, wHwnd As Long) As String Dim ofn As OPENFILENAME Dim rtn As String
If rtn >= 1 Then wOpenFile = ofn.lpstrFile Else wOpenFile = "" End If End Function
Function wSaveFile(wCaption As String, wFilter As String, wHwnd As Long) As String Dim i As Integer Dim ofn As OPENFILENAME Dim filename As String ofn.lStructSize = Len(ofn) ofn.hwndOwner = wHwnd ofn.hInstance = App.hInstance ofn.lpstrFile = Space(254) ofn.nMaxFile = 255 ofn.lpstrFileTitle = Space(254) ofn.nMaxFileTitle = 255 ofn.lpstrInitialDir = App.path ofn.flags = 6148 '过虑对话框文件类型 ofn.lpstrFilter = wFilter '"文本文件 (*.TXT)" + Chr$(0) + "*.TXT" + Chr$(0) + "所有文件 (*.*)" + Chr$(0) + "*.*" + Chr$(0)
'对话框标题栏文字 ofn.lpstrTitle = wCaption i = GetSaveFileName(ofn) '显示保存文件对话框 If i >= 1 Then '取得对话中用户选择输入的文件名及路径 filename = ofn.lpstrFile wSaveFile = Left(filename, InStr(filename, Chr(0)) - 1) End If End Function
Function wReadReg(wMainKey As Long, wKeySubPath As String, wSubKey As String) As Variant '参数顺序为：根键，子路径主键，键名 Dim rqveValue, apiFunHandle, apiFunData, apiFunType As Long Dim srqvStr As String If RegOpenKeyEx(wMainKey, wKeySubPath, 0&, &H20019, apiFunHandle) <> 0& Then Exit Function
If RegCloseKey(apiFunHandle) <> 0& Then apiFunType = -1& wReadReg = srqvStr End Function
Function wWriteReg(wMainKey As Long, wKeySubPath As String, ParamArray SKnKV()) As Boolean '参数顺序为：根键、子路径主键、要建立的键名,键值列表，（可以一次调用本函数来建立多个同路径的键名，但键值只能为字符串，一只调用最多是16383个），如果写入正确，则函数返回true Dim KeyLong As Long Dim Revalue As Long Dim Keyvalue As String Dim Sk() As String, Kv() As String Dim SkKvNum As Integer Dim i As Integer, Scl As Integer SkKvNum = (UBound(SKnKV) + 1) / 2 ReDim Sk(SkKvNum) ReDim Kv(SkKvNum) For i = 1 To SkKvNum Sk(i) = SKnKV(Scl) Scl = Scl + 1 Kv(i) = SKnKV(Scl) Scl = Scl + 1 Next Revalue = RegCreateKey(wMainKey, wKeySubPath, KeyLong) For i = 1 To SkKvNum Revalue = RegSetValueEx(KeyLong, Sk(i), 0&, 1, ByVal Kv(i), Len(Kv(i)) + 1) Next wWriteReg = True If Err <> 0 Then Err = 0 wWriteReg = False End If End Function
Function wProgress(wPictureBox As Control, ByVal wPercent) Dim Num As String Dim BarString As String If Not wPictureBox.AutoRedraw Then wPictureBox.AutoRedraw = -1 End If wPictureBox.Cls wPictureBox.ScaleWidth = 100 wPictureBox.DrawMode = 10 Num = BarString & Format$(wPercent, "###") + "%" wPictureBox.CurrentX = 50 - wPictureBox.TextWidth(Num) / 2 wPictureBox.CurrentY = (wPictureBox.ScaleHeight - wPictureBox.TextHeight(Num)) / 2 wPictureBox.Print Num wPictureBox.Line (0, 0)-(wPercent, wPictureBox.ScaleHeight), RGB(22, 17, 238), BF wPictureBox.Refresh End Function
点击下载此文件