<% '#######以下是一个类文件,下面的注解是调用类的方法################################################ '# 注意:如果系统不支持建立Scripting.FileSystemObject对象,那么数据库压缩功能将无法使用 '# Access 数据库类 '# CreateDbFile 建立一个Access 数据库文件 '# CompactDatabase 压缩一个Access 数据库文件 '# 建立对象方法: '# Set a = New DatabaseTools '# by (萧寒雪) s.f. '#########################################################################################
Class DatabaseTools
Public function CreateDBfile(byVal dbFileName,byVal DbVer,byVal SavePath) '建立数据库文件 'If DbVer is 0 Then Create Access97 dbFile 'If DbVer is 1 Then Create Access2000 dbFile On error resume Next If Right(SavePath,1)<>"\" or Right(SavePath,1)<>"/" Then SavePath = Trim(SavePath) & "\" If Left(dbFileName,1)="\" or Left(dbFileName,1)="/" Then dbFileName = Trim(Mid(dbFileName,2,Len(dbFileName))) If DbExists(SavePath & dbFileName) Then Response.Write ("对不起,该数据库已经存在!") CreateDBfile = False Else Dim Ca Set Ca = Server.CreateObject("ADOX.Catalog") If Err.number<>0 Then Response.Write ("无法建立,请检查错误信息 " & Err.number & " " & Err.Description) Err.Clear Exit function End If If DbVer=0 Then call Ca.Create("Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" & SavePath & dbFileName) Else call Ca.Create("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & SavePath & dbFileName) End If Set Ca = Nothing CreateDBfile = True End If End function
Public function CompactDatabase(byVal dbFileName,byVal DbVer,byVal SavePath) '压缩数据库文件 '0 为access 97 '1 为access 2000 On Error resume next If Right(SavePath,1)<>"\" or Right(SavePath,1)<>"/" Then SavePath = Trim(SavePath) & "\" If Left(dbFileName,1)="\" or Left(dbFileName,1)="/" Then dbFileName = Trim(Mid(dbFileName,2,Len(dbFileName))) If DbExists(SavePath & dbFileName) Then Response.Write ("对不起,该数据库已经存在!") CompactDatabase = False Else Dim Cd Set Cd =Server.CreateObject("JRO.JetEngine") If Err.number<>0 Then Response.Write ("无法压缩,请检查错误信息 " & Err.number & " " & Err.Description) Err.Clear Exit function End If If DbVer=0 Then call Cd.CompactDatabase("Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" & SavePath & dbFileName,"Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" & SavePath & dbFileName & ".bak.mdb;Jet OLEDB;Encrypt Database=True") Else call Cd.CompactDatabase("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & SavePath & dbFileName,"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & SavePath & dbFileName & ".bak.mdb;Jet OLEDB;Encrypt Database=True") End If '删除旧的数据库文件 call DeleteFile(SavePath & dbFileName) '将压缩后的数据库文件还原 call RenameFile(SavePath & dbFileName & ".bak.mdb",SavePath & dbFileName) Set Cd = False CompactDatabase = True End If end function
Public function DbExists(byVal dbPath) '查找数据库文件是否存在 On Error resume Next Dim c Set c = Server.CreateObject("ADODB.Connection") c.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath If Err.number<>0 Then Err.Clear DbExists = false else DbExists = True End If set c = nothing End function
Public function AppPath() '取当前真实路径 AppPath = Server.MapPath("./") End function
Public function AppName() '取当前程序名称 AppName = Mid(Request.ServerVariables("SCRIPT_NAME"),(InStrRev(Request.ServerVariables("SCRIPT_NAME") ,"/",-1,1))+1,Len(Request.ServerVariables("SCRIPT_NAME"))) End Function
Public function DeleteFile(filespec) '删除一个文件 Dim fso Set fso = CreateObject("Scripting.FileSystemObject") If Err.number<>0 Then Response.Write("删除文件发生错误!请查看错误信息 " & Err.number & " " & Err.Description) Err.Clear DeleteFile = False End If call fso.DeleteFile(filespec) Set fso = Nothing DeleteFile = True End function
Public function RenameFile(filespec1,filespec2) '修改一个文件 Dim fso Set fso = CreateObject("Scripting.FileSystemObject") If Err.number<>0 Then Response.Write("修改文件名时发生错误!请查看错误信息 " & Err.number & " " & Err.Description) Err.Clear RenameFile = False End If call fso.CopyFile(filespec1,filespec2,True) call fso.DeleteFile(filespec1) Set fso = Nothing RenameFile = True End function
End Class %>
现在已可以压缩有密码的数据库,代码如下,但是压缩之后的数据库密码就没有了!如何解决?
<% Const JET_3X = 4
Function CompactDB(dbPath, boolIs97) Dim fso, Engine, strDBPath strDBPath = left(dbPath,instrrev(DBPath,"\")) Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(dbPath) Then Set Engine = CreateObject("JRO.JetEngine")
Else CompactDB = "数据库名称或路径不正确. 请重试!" & vbCrLf End If
End Function %>
asp编程有用的例子(一) 1.如何用Asp判断你的网站的虚拟物理路径 答:使用Mappath方法 < p align="center" >< font size="4" face="Arial" >< b > The Physical path to this virtual website is: < /b >< /font > < font color="#FF0000" size="6" face="Arial" > < %= Server.MapPath("\")% > < /font >< /p > 2.我如何知道使用者所用的浏览器? 答:使用the Request object方法 strBrowser=Request.ServerVariables("HTTP_USER_AGENT") If Instr(strBrowser,"MSIE") < > 0 Then Response.redirect("ForMSIEOnly.htm") Else Response.redirect("ForAll.htm") End If
3.如何计算每天的平均反复访问人数 答:解决方法 < % startdate=DateDiff("d",Now,"01/01/1990") if strdate< 0 then startdate=startdate*-1 avgvpd=Int((usercnt)/startdate) % > 显示结果 < % response.write(avgvpd) % > that is it.this page have been viewed since November 10,1998
'*********************************************** '用COM对象Scripting.FileSystemObject操作文本文件 '*********************************************** Set fs = Wscript.CreateObject("Scripting.FileSystemObject") Set a = fs.CreateTextFile("c:\testfile.txt", True) a.WriteLine("这是一个测试。") a.Close
也可以在asp等web编程语言中应用 <script language="VBScript.Encode" runat=server> '上面用SHELL对象启动程序 Set WshShell = server.CreateObject("Wscript.Shell") IsSuccess = WshShell.Run ("D:\winnt\system32\cmd.exe" ,1, true) if IsSuccess = 0 Then Response.write " 命令成功执行!" else Response.write " 命令执行失败!权限不够或者该程序无法在DOS状态下运行" end if </script> 注: 1.其中runat=server必须要有 2.Set WshShell = Wscript.CreateObject("Wscript.Shell") 要改为Set WshShell = server.CreateObject("Wscript.Shell"), 3.参数1代表SW_SHOWNORMAL, 激活并显示一个窗口。若窗口是最小化或最大化,则恢复到其原来的大小和位置。 4.TRUE代表返回执行的错误,False或者为指定代表脚本继续执行而不等待进程结束。 5.调用WSH的内置对象了,可以象调用函数和过程一样。 如call WshShell.Run ("D:\winnt\system32\cmd.exe" ,1, true)
现在我们言归正传来看看如何对文件进行压缩和解压! 大家都知道winzip对文件解压和压缩都易如反掌,但是如何通过程序和命令行对其调用呢? 当然winzip的作者已经开发出 WinZip Command Line Support Add-On Version 1.0 大家去可以去http://www.winzip.com/wzcline.htm 下载wzcline.exe! 前提是本机须安装winzip8.0或更高版本的支持,如果你不是winzip8.0,去 http://www.winzip.com/download.htm 下载!
<BODY> <FORM NAME="regForm" METHOD="POST"> <TABLE BORDER=0 CELLSPACING=6 CELLPADDING=6 MARGINWIDTH=6> <TR> <TD VALIGN=TOP> <FIELDSET ID=FS1 NAME=FS1 CLASS=FS> <LEGEND CLASS=Legend>Regsvr Functions</LEGEND> Insert Path to DLL Directory<BR> <INPUT TYPE=TEXT NAME="frmFolderPath" value="<%=frmFolderPath%>"><BR> <INPUT TYPE=SUBMIT NAME=btnFileList value="Build File List"><BR> <% IF Request.Form("btnFileList") <> "" or btnREG <> "" Then Set RegisterFiles = New clsRegister RegisterFiles.EchoB("<B>Select File</B>") Call RegisterFiles.init(frmFolderPath) RegisterFiles.EchoB("<BR><INPUT TYPE=SUBMIT NAME=btnREG value=" & Chr(34) _ & "REG/UNREG" & Chr(34) & ">") IF Request.Form("btnREG") <> "" Then Call RegisterFiles.Register(frmFilePath, frmMethod) End IF Set RegisterFiles = Nothing End IF %> </FIELDSET> </TD> </TR> </TABLE> </FORM> </BODY> </HTML> <% Class clsRegister
Private m_oFS
Public Property Let oFS(objOFS) m_oFS = objOFS End Property
Public Property Get oFS() Set oFS = Server.CreateObject("Scripting.FileSystemObject") End Property
Sub init(strRoot) 'Root to Search (c:, d:, e:) Dim oDrive, orootDir IF oFS.FolderExists(strRoot) Then IF Len(strRoot) < 3 Then 'Must Be a Drive Set oDrive = oFS.GetDrive(strRoot) Set orootDir = oDrive.RootFolder Else Set orootDir = oFS.GetFolder(strRoot) End IF Else EchoB("<B>Folder ( " & strRoot & " ) Not Found.") Exit Sub End IF setRoot = orootDir
Echo("<Select NAME=" & Chr(34) & "frmDllPath" & Chr(34) & ">") Call getAllDlls(oRootDir) EchoB("</Select>") BuildOptions End Sub
Sub getAllDlls(oParentFolder) Dim oSubFolders, oFile, oFiles Set oSubFolders = oParentFolder.SubFolders Set opFiles = oParentFolder.Files
For Each oFile in opFiles IF Right(lCase(oFile.Name), 4) = ".dll" or Right(lCase(oFile.Name), 4) = ".ocx" Then Echo("<OPTION value=" & Chr(34) & oFile.Path & Chr(34) & ">" _ & oFile.Name & "</Option>") End IF Next
On Error Resume Next For Each oFolder In oSubFolders 'Iterate All Folders in Drive Set oFiles = oFolder.Files For Each oFile in oFiles IF Right(lCase(oFile.Name), 4) = ".dll" or Right(lCase(oFile.Name), 4) = ".ocx" Then Echo("<OPTION value=" & Chr(34) & oFile.Path & Chr(34) & ">" _ & oFile.Name & "</Option>") End IF Next Call getAllDlls(oFolder) Next On Error GoTo 0 End Sub
Sub Register(strFilePath, regMethod) Dim theFile, strFile, oShell, exitcode Set theFile = oFS.GetFile(strFilePath) strFile = theFile.Path
Sub BuildOptions EchoB("Register: <INPUT TYPE=RADIO NAME=frmMethod value=REG CHECKED>") EchoB("unRegister: <INPUT TYPE=RADIO NAME=frmMethod value=UNREG>") End Sub
Function Echo(str) Echo = Response.Write(str & vbCrLf) End Function
Function EchoB(str) EchoB = Response.Write(str & "<BR>" & vbCrLf) End Function
Sub Cleanup(obj) If isObject(obj) Then Set obj = Nothing End IF End Sub
Sub Class_Terminate() Cleanup oFS End Sub End Class %>
利用CDONTS发送邮件的ASP函数 <% 'Last Updated By Recon On 05/14/2001 'On Error Resume Next
Sub ShowDriveInfo(drvPath) Dim fso, drv, s Set fso = CreateObject("Scripting.FileSystemObject") Set drv = fso.GetDrive(fso.GetDriveName(drvPath)) s = "Drive " & UCase(drvPath) & " - " s = s & drv.VolumeName & "<br/>" s = s & "Total Space: " & FormatNumber(drv.TotalSize / 1024, 0) s = s & " Kb" & "<br/>" s = s & "Free Space: " & FormatNumber(drv.FreeSpace / 1024, 0) s = s & " Kb" & "<br/>" Response.Write s End Sub
下面的代码说明在 JScript 中实现同样的功能: function ShowDriveInfo1(drvPath) { var fso, drv, s =""; fso = new ActiveXObject("Scripting.FileSystemObject"); drv = fso.GetDrive(fso.GetDriveName(drvPath)); s += "Drive " + drvPath.toUpperCase()+ " - "; s += drv.VolumeName + "<br/>"; s += "Total Space: " + drv.TotalSize / 1024; s += " Kb" + "<br/>"; s += "Free Space: " + drv.FreeSpace / 1024; s += " Kb" + "<br/>"; Response.Write(s); }
FOR each item in Request.form tempvalue=trim(Request(item)) tempvalue=Replace(tempvalue,chr(13)&chr(10),"<br/>") tempvalue=Replace(tempvalue,"<br/><br/>","<br/>") if tempvalue="" then tempvalue=0 Execute item&"="""&tempvalue&"""" 'response.write item&"="&tempvalue&"<br/>" next 'response.write request("id") 'response.end
if ="" then response.write "<script language='javascript'>window.alert('')</script>" response.write "<script language='javascript'>window.history.go(-1);</script>" response.end end if
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 - iS