<
% @ LANGUAGE
=
"
VBSCRIPT
"
CODEPAGE
=
"
936
"
%
>
< % Option Explicit
response.buffer = true
Response.Expires = - 1
Response.AddHeader " Pragma " , " no-cache "
Response.AddHeader " cache-ctrol " , " no-cache "
' build2004-11-20 V1.05
% >< !DOCTYPE HTML PUBLIC " -//W3C//DTD HTML 4.0 Transitional//EN " >
< HTML >
< HEAD >
< TITLE > CooSel2. 0 Access to SQLserver 数据库生迁脚本编写器 V1. 05 (V37 PaintBlue.Net 2004 Acp Code) </ TITLE >
< META NAME = " Generator " CONTENT = " EditPlus " >
< META NAME = " Author " CONTENT = " V37 " >
< META NAME = " Keywords " CONTENT = " PaintBlue.Net,PaintBlue " >
< META NAME = " Description " CONTENT = " PaintBlue.Net " >
< style >
table{ color: # 000000 ;
font - size: 9pt;
FONT - FAMILY: " Tahoma " , " MS Shell Dlg " ;
}
td { color: # 000000 ;
font - size: 9pt;
}table{ color: # 000000 ;
font - size: 9pt;
FONT - FAMILY: " Tahoma " , " MS Shell Dlg " ;
}
body { color: # 000000 ;
font - size: 9pt;
}
</ style >
</ HEAD >
< body bgCOLOR = eeeeee text = " #000000 " leftmargin = " 0 " marginwidth = " 100% " topmargin = " 0 " bottommargin = " 20 " >
< %
' 2004-11-18/
' fix exec=0 =1 type
' fix conv now() date() time() type
' fix binary ole conv 不做导入
' fix Asp代码生成
dim enMode,UniCodeMode
dim DB_Name,ExtName,FileName
dim rs,CONN,CONNstr
DB_Name = questStr( " DB_Name " )
FileName = questStr( " DB_Name " )
enMode = questStr( " enMode " )
UniCodeMode = questStr( " UniCodeMode " )
if not isnumeric (enMode) then enMode = 0
' 2004-11-18
dim databaseName,darr,errinfo
dim loginName
dim loginPassword
dim sapass
errinfo = ""
databaseName = questStr( " databaseName " )
loginName = questStr( " loginName " )
loginPassword = questStr( " loginPassword " )
sapass = questStr( " sapass " )
if not checkchar(loginName) then
errinfo = errinfo & " 要生成的SQL数据库登陆名称含不合法字符\n "
end if
if not checkchar(databaseName) then
errinfo = errinfo & " 要生成的SQL数据库名称含不合法字符\n "
end if
if errinfo <> "" then GetAlert errinfo
if databaseName = "" and DB_Name <> "" then
darr = split (DB_Name, " \ " )
databaseName = split (darr( ubound (darr)), " . " )( 0 )
end if
' --------/
if DB_Name <> "" then
enMode = clng (enMode)
if enMode = 0 then
ExtName = " .Sql "
else
ExtName = " .Asp "
end if
Call openDB(DB_Name)
Call CreateSQL(DB_Name,enMode)
else
if DB_Name = "" then DB_Name = " data/mydb.mdb "
Call Main()
end if
' 2004-11-18
Function CheckChar(testchar)
CheckChar = true
dim chars,i,j,charlen
chars = testchar
dim ichar
ichar = array ( " = " , " \ " , " ( " , " ) " , " / " , " % " , chr ( 32 ), " ? " , " & " , " $ " , " ; " , " , " , " ' " , chr ( 34 ), chr ( 9 ), chr ( 0 ), " * " , " > " , " < " , " | " , " : " , " # " )
charlen = len (chars)
for i = 0 to ubound (ichar)
if instr (chars,ichar(i)) > 0 then
CheckChar = false
exit function
end if
next
End function
SUB GetAlert(errinfo)
% >
< !DOCTYPE HTML PUBLIC " -//W3C//DTD HTML 4.0 Transitional//EN " >
< HTML >< HEAD >< TITLE > CooSel GetAlert Error </ TITLE >
< META NAME = " Generator " CONTENT = " EditPlus " >
< META NAME = " Author " CONTENT = " V37 " ></ head >
< body leftmargin = " 0 " rightmargin = " 0 " topmargin = " 0 " bgcolor = " #D4D0C8 " >
</ BODY >
</ HTML >
< SCRIPT LANGUAGE = " JavaScript " >
< ! --
alert( " <%=errinfo%> " );
window.history.back();
//-->
</ SCRIPT >< %
if isObject (CONN) then closeDB
response.end
End SUB
Sub CloseDB
CONN.close
Set CONN = nothing
End Sub
Sub MAIN()
% >
< style >
.titlebar {
FONT - WEIGHT: bold; FONT - SIZE: 12pt; FILTER : dropshadow(color = # 333333 , offx = 1 , offy = 2 ); WIDTH: 100 %; COLOR: #ffffff; FONT - FAMILY: Tahoma,Verdana, Arial, sans - serif; POSITION: relative; TOP: 1px
}
</ style >
< FORM METHOD = POST ACTION = " ?action=1 " Name = DBform >
< TABLE width = " 100% " cellspacing = 0 border = 0 >
< TR bgcolor = #D4D0C8 >
< TD align = center height = 32 >< a href = http: // www.paintblue.net / target = _blank >< img src = http: // www.paintblue.net / bbs / images / TitleLogo.gif border = 0 ></ a ></ td >< td >< span class = titlebar >< font color = #ffffff >< b > MiniAccess Editor V1. 0 P3 (Access To SQLserver 数据升迁 脚本编写器) </ b ></ font ></ span ></ TD >
< td ></ td ></ TR >
< TABLE align = center width = " 100% " cellspacing = 1 cellpadding = 3 border = 0 >
</ TABLE >
< TABLE align = center width = " 100% " cellspacing = 1 cellpadding = 3 border = 0 >
< TR bgcolor = # 667766 >< TD align = right height = 10 ></ TD >< TD ></ TD ></ TR >
< TR bgcolor = #D4D0C8 >
< TD align = right >< span id = a > 编写模式 </ span ></ TD >
< TD >
< INPUT TYPE = " radio " NAME = " enMode " value = " 0 " < % if enMode = 0 then response.write " checked " end if % > > Sql文本
< INPUT TYPE = " radio " NAME = " enMode " value = " 1 " < % if enMode = 1 then response.write " checked " end if % > > Asp代码
< ! -- < INPUT TYPE = " radio " NAME = " enMode " value = " 2 " < % if enMode = 2 then response.write " checked " end if % > > 编写完后直接运行 -->
& nbsp; & nbsp; < INPUT TYPE = " checkbox " NAME = " UniCodeMode " value = " 1 " checked > 文本和备注按Unicode导入
</ TD >
</ TR >
< TR bgcolor = #D4D0C8 >
< TD align = right width = 250 > MDB数据库路径 </ TD >
< TD >< INPUT TYPE = " text " NAME = " DB_Name " value = " <%=DB_Name%> " style = " width:70%; " > </ TD >
</ TR >
< TR bgcolor = #D4D0C8 >
< TD align = right width = 250 > SQLserver登陆帐号(sa) </ TD >
< TD >< INPUT TYPE = " password " NAME = " sapass " value = "" style = " width:30%; " > SQL数据库(sa)登陆密码,可以不用输入,生成完脚本再提供 </ TD >
</ TR >
< TR bgcolor = #D4D0D8 >
< TD align = right width = 250 > 导入SQL的后的数据库名 </ TD >
< TD >< INPUT TYPE = " text " NAME = " databasename " value = " <%= " myDatabase " %> " style = " width:30%; " > </ TD >
</ TR >
< TR bgcolor = #D4D0D8 >
< TD align = right width = 250 > 导入SQL的数据库登陆帐号 </ TD >
< TD >< INPUT TYPE = " text " NAME = " loginName " value = " <%= " my_login " %> " style = " width:30%; " > </ TD >
</ TR >
< TR bgcolor = #D4D0D8 >
< TD align = right width = 250 > 导入SQL的数据库登陆密码 </ TD >
< TD >< INPUT TYPE = " password " NAME = " loginPassword " value = " <%= " my_pass " %> " style = " width:30%; " > </ TD >
</ TR >
< TR bgcolor = # 667766 >< TD align = right height = 10 ></ TD >< TD ></ TD ></ TR >
< TR >
< TD height = 38 ></ TD >
< TD bgcolor = #D4D0C8 > & nbsp; & nbsp; < INPUT TYPE = " submit " value = " 确 定 " style = " width:80; " ></ TD >
</ TR >
< TR >
< TD height = 38 ></ TD >
< TD bgcolor = #D4D0C8 > & nbsp; & nbsp;
< li ><< 简介 >>
< li > For Access 数据库导入 SQLserver 的版本,生成的在SQL2000下执行的 SQL脚本, < br > & nbsp; & nbsp; & nbsp; & nbsp;除了还原库结构,还同时将Access的数据导入 SQLserver
< br > & nbsp; & nbsp; & nbsp; & nbsp;由于SQLserver的视图不一样,Access能自动处理同名列, < br > & nbsp; & nbsp; & nbsp; & nbsp;脚本生成对含Select * 有同名列的联合查询作了自动转换,有可能需要对照重修改一下
< li > 功能:可编写Access数据库的常用的主要对象,包括 < br > & nbsp; & nbsp; & nbsp; & nbsp; < b > 表,视图,索引,约束,包括 默认值,主键,自动编号,外键 </ b > (表关系)
< li > 编写完自动保存为原数据库名 + 相应扩展的文件
< li > Asp模式可直接生成带表单输入的可执行的Asp文件,用生成的Asp文件即可生成新的数据库
< li > Sql模式可直接生成纯Sql语句文本 </ li >< br >< br ></ TD >
</ TR >
</ Table >
</ FORM >
< %
End SUB
' ====MiniAcces Editor1.0part2 Access SQL脚本编写器(V37 PaintBlue.Net 2004 Acp Code)=========
SUB openDB(DB_Name)
if inStr (DB_Name, " :/ " ) = 0 and inStr (DB_Name, " :\ " ) = 0 then
DB_Name = server.mappath(DB_Name)
end if
Set CONN = Server.CreateObject( " ADODB.CONNection " )
on error resume next
CONN.Open " Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & DB_Name
if err.number <> 0 then
rw " 数据库打开失败,错误为: " & err.description, 0
err.clear
else
Set rs = Server.CreateObject( " adodb.recordSet " )
end if
End SUB
SUB CreateSQL(DB_Name,exec)
' 创建模式
' exec = 0 : 生成SQL语句
' exec = 1 : 生成Asp程序
dim tbls,tabsArr,ub,I,TtempStr,TtempStrHead,remchar
dim TableStr
if exec = 1 then
TtempStrHead = " < " & " % @ LANGUAGE=""VBSCRIPT""% " & " > " & vbcrlf
TtempStrHead = TtempStrHead & " < " & " %Option Explicit " & vbcrlf
TtempStrHead = TtempStrHead & " response.buffer=true " & vbcrlf & vbcrlf
TtempStrHead = TtempStrHead & " '========================================================================= " & vbcrlf & " 'Access 数据库 SQL 脚本生成 by MiniAccess Edit V1.0 P2(V37 PaintBlue.Net 2004 Asp Code) " & vbcrlf & " '========================================================================= " & vbcrlf & vbcrlf
end if
if instr (DB_Name, " :\ " ) = 0 and instr (DB_Name, " :/ " ) = 0 then
DB_Name = Server.MapPath(DB_Name)
end if
CONNstr = " Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & DB_Name
Set CONN = Server.CreateObject( " ADODB.Connection " )
CONN.Open CONNstr
' rs.open "[查询3]",CONN
' for i=0 to rs.fields.count-1
' rw rs(i).name,1
' next
' response.end
' 编写CONN对象
if exec = 1 then
TtempStr = TtempStr & " SUB CreateDB(DB_Name,NewDB_Name,loginName,loginPassword,sapass,DTS) " & vbcrlf
TtempStr = TtempStr & " DIM CONN,CONNstr " & vbcrlf
' TtempStr=TtempStr & "CONNStr=""Provider=Microsoft.Jet.OLEDB.4.0;Data Source="" & DB_Name" & vbcrlf
TtempStr = TtempStr & " CONNStr=""Provider=SQLOLEDB.1;Password='"" & sapass & ""';Persist Security InFso=true;User ID='sa';Initial Catalog='Master';Data Source='(local)';CONNect Timeout=30"" " & vbcrlf
TtempStr = TtempStr & " Set CONN=Server.CreateObject(""ADODB.Connection"") " & vbcrlf
TtempStr = TtempStr & " CONN.open CONNStr " & vbcrlf & vbcrlf
' 2004-11-18
TtempStr = TtempStr & " CONN.execute(""Create Database ["" & NewDB_Name & ""]"") " & vbcrlf
TtempStr = TtempStr & " CONN.close " & vbcrlf
TtempStr = TtempStr & " CONNStr=""Provider=SQLOLEDB.1;Password='"" & sapass & ""';Persist Security InFso=true;User ID='sa';Initial Catalog='"" & NewDB_Name & ""';Data Source='(local)';CONNect Timeout=30"" " & vbcrlf
TtempStr = TtempStr & " CONN.open CONNStr " & vbcrlf & vbcrlf
' 2004-11-18
TtempStr = TtempStr & " CONN.execute(""exec sp_addlogin '"" & loginName & ""','"" & loginPassword & ""','"" & NewDB_Name & ""'"") " & vbcrlf
TtempStr = TtempStr & " CONN.execute(""exec sp_adduser '"" & loginName & ""','"" & loginName & ""','db_owner'"") " & vbcrlf
' -----/
elseif exec = 0 then
TtempStr = TtempStr & " Create Database [ " & databaseName & " ] " & vbcrlf & " go " & vbcrlf
TtempStr = TtempStr & " use [ " & databaseName & " ] " & vbcrlf & " go " & vbcrlf & vbcrlf
' 2004-11-18
TtempStr = TtempStr & " exec sp_addlogin ' " & loginName & " ',' " & loginPassword & " ',' " & databaseName & " ' " & vbcrlf & " go " & vbcrlf
TtempStr = TtempStr & " exec sp_adduser ' " & loginName & " ',' " & loginName & " ','db_owner' " & vbcrlf & " go " & vbcrlf
' -----/
end if
' 编写表/索引对象
Set tbls = CONN.openSchema( 20 ) ' adSchemaPrimaryKeys
tbls.Filter = " TABLE_TYPE='TABLE' " ' 筛选出有默认值,但允许null的列
while Not tbls.eof
TableStr = TableStr & " | " & tbls( " TABLE_Name " )
tbls.movenext
wend
tbls.filter = 0
tbls.close
set tbls = nothing
TableStr = mid (TableStr, 2 )
if exec = 1 then
remchar = " ' "
elseif exec = 0 then
remchar = " -- "
end if
if TableStr <> "" then
tabsArr = split (TableStr, " | " )
ub = ubound (tabsArr)
for I = 0 to ub
TtempStr = TtempStr & remchar & " [ " & tabsArr(I) & " ]: " & vbcrlf
TtempStr = TtempStr & CreatTableSql(tabsArr(I),exec) & vbcrlf & vbcrlf
next
end if
' 编写数据导入
if exec = 1 then TtempStr = TtempStr & " If DTS=1 then " & vbcrlf
TtempStr = TtempStr & CreateOpenDataSource(TableStr,DB_Name,exec)
if exec = 1 then TtempStr = TtempStr & " End iF " & vbcrlf
' 编写表关系
if TableStr <> "" then TtempStr = TtempStr & CreatForeignSql(exec)
' 编写视图
TtempStr = TtempStr & CreatViewSql(exec) & vbcrlf
if exec = 1 then
TtempStr = replace (TtempStr, " > " , " "" & chr(62) & "" " )
TtempStr = replace (TtempStr, " < " , " "" & chr(60) & "" " )
TtempStr = TtempStr & " End SUB " & vbcrlf & vbcrlf
TtempStr = TtempStr & Add_aspExec()
TtempStr = TtempStrHead & TtempStr & vbcrlf & " % " & " > "
elseif exec = 0 then
TtempStr = TtempStr & " --========================================================================= " & vbcrlf & " --Access To SQL 数据库升迁脚本 by MiniAccess Edit V1.0 P2(V37 PaintBlue.Net 2004) " & vbcrlf & " --========================================================================= " & vbcrlf & vbcrlf
TtempStr = TtempStr & vbCrLf & " --连接字串:CONNstr=""Provider=SQLOLEDB.1;Persist Security InFso=true;Data Source='(local)';Initial Catalog=' " & databaseName & " ';User ID=' " & loginName & " ';Password=' " & loginPassword & " ';CONNect Timeout=30"" " & vbCrLf & vbCrLf
end if
call Ados_Write(TtempStr,DB_Name & ExtName, " gb2312 " )
rw " <br><img width=100 height=0> " & DB_Name & " 的SQL脚本编写完成 " , 1
rw " <img width=100 height=0>已经保存文件为<b><font color=blue> " & DB_Name & ExtName & " </font></b>[<a href=?>返回</a>]: " , 1
rw " <center><textarea style=""width:70%;height:500px;"" wrap=""off""> " & server.Htmlencode(TtempStr) & " </textarea></center> " , 1
End SUB
function CreatViewSql(exec)
dim cols
dim FKtable,PK_cols,FK_cols,tmpStr,tmpStr1,VIEW_DEFINITION
Set cols = CONN.openSchema( 23 )
cols.filter = 0
while not cols.eof
tmpStr1 = ""
VIEW_DEFINITION = replace (cols( " VIEW_DEFINITION " ), chr ( 13 ), "" )
VIEW_DEFINITION = replace (VIEW_DEFINITION, chr ( 10 ), " " )
VIEW_DEFINITION = left (VIEW_DEFINITION, len (VIEW_DEFINITION) - 1 )
VIEW_DEFINITION = TransView(cols( " TABLE_NAME " ),VIEW_DEFINITION)
tmpStr1 = " Create view [dbo].[ " & cols( " TABLE_NAME " ) & " ] As " & VIEW_DEFINITION & ""
if exec = 1 then tmpStr1 = " CONN.execute("" " & tmpStr1 & " "") "
tmpStr = tmpStr & vbcrlf & tmpStr1
if exec = 0 then tmpStr = tmpStr & vbcrlf & " go "
cols.movenext
wend
cols.close
set cols = nothing
CreatViewSql = tmpStr
End Function
Function TransView(viewName,Str)
dim S
S = lcase (Str)
S = replace (S, chr ( 9 ), " " )
S = replace (S, chr ( 32 ), " " )
S = replace (S, chr ( 10 ), " " )
S = replace (S, chr ( 13 ), "" )
S = replace (S, " ; " , " " )
do while instr (S, " " ) > 0
S = replace (S, " " , " " )
loop
S = replace (S, " count(*) " , " count(*) as count_x " )
if instr ( lcase (S), " * from " ) = 0 then
TransView = S
else
TransView = replace (S, " * from " ,GetviewColumnStr(viewName) & " from " )
end if
' rw GetviewColumnStr(viewName),1
' rw instr(lcase(S),"* from"),1
End Function
function GetviewColumnStr(viewName)
dim rs,i,tmpstr,arr,j,chg
chg = false
' rw "[" & viewName & "]",0
set rs = server.createobject( " adodb.recordset " )
' rw "select * from [" & tablename & "] where 1=0",1
rs.open " [ " & viewName & " ] " ,conn
dim tmp
if rs.fields.count > 0 then
tmpstr = rs( 0 ).name
for i = 1 to rs.fields.count - 1
tmpstr = tmpstr & " , " & rs(i).name
next
tmpstr = lcase (tmpstr)
arr = split (tmpstr, " , " )
for i = 0 to ubound (arr)
tmp = arr(i)
arr(i) = " [ " & arr(i) & " ] "
if instr (arr(i), " . " ) > 0 then
arr(i) = replace (arr(i), " . " , " ].[ " )
arr(i) = arr(i) & " as " & replace (tmp, " . " , " _ " )
chg = true
end if
next
if chg then
GetviewColumnStr = join (arr, " , " )
else
GetviewColumnStr = " * "
end if
else
GetviewColumnStr = ""
end if
end function
function CreatTableSql(byval tableName,exec)
dim cols
dim TmpStr,TmpStr1
Set cols = CONN.openSchema( 4 )
dim splitchar,splitchar1
if exec = 1 then
splitchar = " "" "
splitchar1 = " "" & _ "
elseif exec = 0 then
splitchar = ""
splitchar1 = ""
end if
cols.filter = " Table_name=' " & tableName & " ' "
if cols.eof then
exit function
end if
dim cat,autoclumn,n,chkPrimaryKey
n = 0
' 编写表脚本
autoclumn = GetAutoincrementCoulmnT(tableName)
tmpStr1 = " CREATE TABLE [dbo].[ " & tableName & " ] ( " & splitchar1 & vbcrlf
dim autoclumnStr,columnStr
if autoclumn <> "" then
autoclumnStr = " " & splitchar & " [ " & autoclumn & " ] integer IDENTITY (1, " & GetIncrement(tableName,autoclumn) & " ) not null "
end if
n = 0
do
n = n + 1
cols.filter = " Table_name=' " & tableName & " ' and ORDINAL_POSITION= " & n
if cols.eof then exit do
if n > 1 then tmpStr1 = tmpStr1 & " , " & splitchar1 & vbcrlf
if autoclumn = cols( " Column_name " ) then
tmpStr1 = tmpStr1 & autoclumnStr
else
tmpStr1 = tmpStr1 & " " & splitchar & " [ " & cols( " Column_name " ) & " ] " & lcase (datatypeStr(cols( " DATA_TYPE " ),cols( " CHARACTER_MAXIMUM_LENGTH " ))) & defaultStr(cols( " DATA_TYPE " ),cols( " COLUMN_DEFAULT " ),exec) & nullStr(cols( " IS_NULLABLE " ), tablename, cols( " Column_name " ))
end if
cols.movenext
loop
tmpStr1 = tmpStr1 & splitchar1 & vbcrlf & " " & splitchar & " ) ON [Primary] "
cols.close
if exec = 0 then tmpStr1 = tmpStr1 & splitchar1 & vbcrlf & "" & splitchar & " go "
if exec = 1 then
TmpStr1 = " CONN.execute("" " & TmpStr1 & " "") "
end if
tmpStr = tmpStr & vbcrlf & tmpStr1
' 编写索引脚本
dim InxArr,i,kstr,j
InxArr = split (getInxArr(tableName), " , " )
Set cols = CONN.openSchema( 12 )
for i = 0 to ubound (InxArr)
cols.filter = " Table_name=' " & tableName & " ' and index_name=' " & InxArr(i) & " ' "
kstr = ""
tmpStr1 = ""
if Not isForeignIndex(tableName,InxArr(i)) then ' 外键索引不进行编写
while not cols.eof
kstr = kstr & " ,[ " & cols( " column_name " ) & " ] " & GetInxDesc(TableName,InxArr(i),cols( " column_name " ))
cols.movenext
wend
if isPrimaryKey(TableName,InxArr(i)) then
tmpStr1 = tmpStr1 & " Alter TABLE [dbo].[ " & tableName & " ] WITH NOCHECK ADD CONSTRAINT [PK_ " & tableName & " ] Primary Key Clustered ( " & mid (kstr, 2 ) & " ) ON [Primary] "
else
tmpStr1 = tmpStr1 & " CREATE "
if isUnique(TableName,InxArr(i)) then tmpStr1 = tmpStr1 & " Unique "
tmpStr1 = tmpStr1 & " INDEX [ " & InxArr(i) & " ] on [dbo].[ " & tableName & " ]( " & mid (kstr, 2 ) & " ) ON [Primary] "
end if
if exec = 1 then tmpStr1 = " CONN.execute("" " & tmpStr1 & " "") "
if exec = 0 then tmpStr1 = tmpStr1 & vbcrlf & " go "
tmpStr = tmpStr & vbcrlf & tmpStr1
end if
next
cols.close
cols.filter = 0
CreatTableSql = TmpStr
End function
function CreatForeignSql(exec)
dim cols
dim FKtable,PK_cols,FK_cols,tmpStr,tmpStr1
Set cols = CONN.openSchema( 27 )
cols.filter = " PK_NAME<>Null "
while not cols.eof
tmpStr1 = ""
tmpStr1 = " ALTER TABLE [ " & cols( " FK_TABLE_NAME " ) & " ] " & _
" Add CONSTRAINT [ " & cols( " FK_NAME " ) & " ] " & _
" FOREIGN KEY ([ " & cols( " FK_COLUMN_NAME " ) & " ]) REFERENCES " & _
" [ " & cols( " PK_TABLE_NAME " ) & " ] ([ " & cols( " PK_COLUMN_NAME " ) & " ]) "
if cols( " UPDATE_RULE " ) = " CASCADE " then tmpStr1 = tmpStr1 & " ON UPDATE CASCADE "
if cols( " DELETE_RULE " ) = " CASCADE " then tmpStr1 = tmpStr1 & " ON DELETE CASCADE "
if exec = 1 then tmpStr1 = " CONN.execute("" " & tmpStr1 & " "") "
tmpStr = tmpStr & vbcrlf & tmpStr1
if exec = 0 then tmpStr = tmpStr & vbcrlf & " go "
cols.movenext
wend
cols.filter = 0
cols.close
set cols = nothing
CreatForeignSql = tmpStr
End Function
Function CreateOpenDataSource(TableStr,DB_Name,exec)
' SET IDENTITY_INSERT Co_admin ON
' go
' INSERT INTO dbo.Co_admin (id,username,password,MasterFlag,adduser)
' SELECT id,username,password,MasterFlag,adduser
' FROM OPENDATASOURCE('Microsoft.Jet.OLEDB.4.0','Data Source="d:\www\lfgbox\coosel2.0\data\coosel.asa"')[Co_admin]
' go
' SET IDENTITY_INSERT dbo.Co_admin OFF
' go
dim splitchar,splitchar1,columnStr,rs,i,TmpStr1,tmp,remchar
if exec = 1 then
remchar = " ' "
splitchar = " "" "
splitchar1 = " "" & _ "
elseif exec = 0 then
remchar = " -- "
splitchar = ""
splitchar1 = ""
end if
Set rs = CONN.openSchema( 20 )
rs.Filter = " TABLE_TYPE='TABLE' "
while not rs.EOF
' rw server.htmlencode(rs("TABLE_NAME")),1
columnStr = GetColumnStr(rs( " TABLE_NAME " ))
if columnStr <> "" then
' if n>0 then tmpStr1=tmpStr1 & splitchar1 & vbcrlf
TmpStr1 = TmpStr1 & remchar & " [ " & rs( " TABLE_NAME " ) & " ]: " & vbcrlf
TmpStr1 = TmpStr1 & " CONN.CommandTimeout = 600 " & vbcrlf
if GetAutoincrementCoulmnT(rs( " TABLE_NAME " )) <> "" then
tmp = " SET IDENTITY_INSERT [dbo].[ " & rs( " TABLE_NAME " ) & " ] ON "
if exec = 0 then
tmp = tmp & vbcrlf & " go " & vbcrlf
elseif exec = 1 then
tmp = " CONN.execute("" " & tmp & " "") " & vbcrlf
end if
TmpStr1 = TmpStr1 & tmp & vbcrlf
end if
tmp = " INSERT INTO [dbo].[ " & rs( " TABLE_NAME " ) & " ] ( " & columnStr & " ) " & splitchar1 & vbcrlf
tmp = tmp & " " & splitchar & " SELECT " & columnStr & " " & splitchar1 & vbcrlf
if exec = 0 then
tmp = tmp & " " & splitchar & " FROM OPENDATASOURCE('Microsoft.Jet.OLEDB.4.0','Data Source= " & splitchar & " "" " & DB_Name & " "" " & splitchar & " ')[ " & rs( " TABLE_NAME " ) & " ] "
tmp = tmp & vbcrlf & " go " & vbcrlf
elseif exec = 1 then
tmp = tmp & " " & splitchar & " FROM OPENDATASOURCE('Microsoft.Jet.OLEDB.4.0','Data Source= " & splitchar & " """" & DB_Name & """" " & splitchar & " ')[ " & rs( " TABLE_NAME " ) & " ] "
tmp = " CONN.execute("" " & tmp & " "") " & vbcrlf
end if
TmpStr1 = TmpStr1 & tmp & vbcrlf
if GetAutoincrementCoulmnT(rs( " TABLE_NAME " )) <> "" then
tmp = " SET IDENTITY_INSERT [dbo].[ " & rs( " TABLE_NAME " ) & " ] Off "
if exec = 0 then
tmp = tmp & vbcrlf & " go " & vbcrlf & vbcrlf
elseif exec = 1 then
tmp = " CONN.execute("" " & tmp & " "") " & vbcrlf & vbcrlf
end if
TmpStr1 = TmpStr1 & tmp & vbcrlf
end if
end if
RS.MoveNext
wend
TmpStr1 = TmpStr1 & " CONN.CommandTimeout = 30 " & vbcrlf
rs.filter = 0
rs.close
set rs = nothing
CreateOpenDataSource = TmpStr1
End Function
function GetColumnStr(tablename)
dim rs,i,tmpstr
set rs = server.createobject( " adodb.recordset " )
' rw "select * from [" & tablename & "] where 1=0",1
rs.open " select * from [ " & tablename & " ] where 1=0 " ,conn
if rs.fields.count > 0 then
for i = 0 to rs.fields.count - 1
' rw rs(i).name & "_" & rs(i).type & "<br>",1
if rs(i).type <> 205 then tmpstr = tmpstr & " , " & rs(i).name
next
if tmpstr <> "" then
GetColumnStr = mid (tmpstr, 2 )
else GetColumnStr = ""
end if
else
GetColumnStr = ""
end if
end function
SUB Ac2SQLStr()
dim rs
TMPstr = ""
Set rs = CONN.openSchema( 20 )
rs.Filter = " TABLE_TYPE='TABLE' "
while not rs.EOF
TMPstr = TMPstr & " SELECT * INTO [tmp_ " & rs( " TABLE_NAME " ) & " ] FROM OPENDATASOURCE('Microsoft.Jet.OLEDB.4.0','Data Source=""d:\www\lfgbox\paintblue2.0f2\pbbs\database\paintbase#.asa""')[ " & rs( " TABLE_NAME " ) & " ]<br> "
NN = NN + 1
RS.MoveNext
wend
rs.filter = 0
rs.close
set rs = nothing
End SUB
' 判断是否是外键索引
Function isForeignIndex(TableName,indexName)
dim cols
Set cols = CONN.openSchema( 27 )
cols.filter = " FK_TABLE_Name=' " & TableName & " ' and FK_NAME=' " & indexName & " ' "
if Not cols.eof then
isForeignIndex = true
else
isForeignIndex = false
end if
End Function
' 取得索引列的排序属性
function GetInxDesc(TableName,indexName,ColumnName)
dim cat
set cat = Server.CreateObject( " ADOX.Catalog " )
cat.ActiveCONNection = CONNstr
if cat.Tables( "" & TableName & "" ).Indexes( "" & indexName & "" ).Columns( "" & ColumnName & "" ).SortOrder = 2 then
GetInxDesc = " Desc "
else
GetInxDesc = ""
end if
set cat = nothing
end function
' 取得列数组
function getColumArr(tableName)
dim cols,arr(),n
redim arr( - 1 )
n = 0
redim arr(n)
set cols = CONN.openSchema( 4 )
cols.filter = " Table_Name=' " & tableName & " ' "
while not cols.eof
redim Preserve arr(n)
arr(n) = cols( " column_name " )
cols.movenext
n = n + 1
wend
cols.filter = 0
cols.close
set cols = nothing
getColumArr = arr
end function
' 取得索引数组
function getInxArr1(tableName)
dim cols,arr(),n,tmpCol
redim arr( - 1 )
n = 0
set cols = CONN.openSchema( 12 )
cols.filter = " Table_Name=' " & tableName & " ' "
while not cols.eof
if cols( " index_name " ) <> tmpCol then
redim Preserve arr(n)
arr(n) = cols( " index_name " )
n = n + 1
end if
tmpCol = cols( " index_name " )
cols.movenext
wend
cols.filter = 0
cols.close
set cols = nothing
getInxArr = arr
end function
' 取得索引数组
Function getInxArr(tablename)
Dim cols
Dim n
Dim tmpCol
Dim tmps
n = 0
Set cols = CONN.openSchema( 12 )
cols.Filter = " Table_Name=' " & tablename & " ' "
While Not cols.EOF
If cols( " index_name " ) <> tmpCol Then
tmps = tmps & " , " & cols( " index_name " )
n = n + 1
End If
tmpCol = cols( " index_name " )
cols.movenext
Wend
cols.Filter = 0
cols.Close
Set cols = Nothing
getInxArr = Mid (tmps, 2 )
End Function
function isUnique(TableName,IndexName)
dim cols
set cols = CONN.openSchema( 12 )
cols.filter = " Table_Name=' " & TableName & " ' and Index_Name=' " & IndexName & " ' and UNIQUE=True "
if not cols.eof then
isUnique = true
else
isUnique = false
end if
cols.filter = 0
cols.close
set cols = nothing
end function
function isPrimaryKey(TableName,IndexName)
dim cols
set cols = CONN.openSchema( 12 )
cols.filter = " Table_Name=' " & TableName & " ' and Index_Name=' " & IndexName & " ' and PRIMARY_KEY=True "
if not cols.eof then
isPrimaryKey = true
else
isPrimaryKey = false
end if
cols.filter = 0
cols.close
set cols = nothing
end function
function getPrimaryKey(tableName,columnName)
dim cols
Set cols = CONN.openSchema( 12 )
cols.filter = " Table_Name=' " & tableName & " ' and Column_Name=' " & columnName & " ' and PRIMARY_KEY=True "
if not cols.eof then
getPrimaryKey = cols( " INDEX_NAME " )
' isPrimaryKey=true
else
getPrimaryKey = ""
' isPrimaryKey=false
end if
cols.filter = 0
cols.close
set cols = nothing
end function
function existPrimaryKey(tableName)
dim cols
Set cols = CONN.openSchema( 12 )
cols.filter = " Table_Name=' " & tableName & " ' and PRIMARY_KEY=True "
if not cols.eof then
existPrimaryKey = true
else
existPrimaryKey = false
end if
cols.filter = 0
cols.close
set cols = nothing
end function
Function GetIncrement(tableName,columnName)
dim cat
set cat = Server.CreateObject( " ADOX.Catalog " )
cat.ActiveCONNection = CONNstr
GetIncrement = cat.Tables( "" & TableName & "" ).Columns( "" & columnName & "" ).Properties( " Increment " )
set cat = nothing
end function
Function GetSeed(tableName,columnName)
dim cat
set cat = Server.CreateObject( " ADOX.Catalog " )
cat.ActiveCONNection = CONNstr
GetSeed = cat.Tables( "" & TableName & "" ).Columns( "" & columnName & "" ).Properties( " Seed " )
set cat = nothing
end function
' 通用,内部属性取得自动编号,对SQLserver Access都可以
Function GetAutoincrementCoulmnT(TableName)
dim i
rs.open " select * from [ " & TableName & " ] where 1=0 " ,CONN, 0 , 1
for i = 0 to rs.fields.count - 1
// if rs(i).Properties( " isAutoIncrement " ) = True then
if rs(i).Properties( " isAutoIncrement " ) = True then
GetAutoincrementCoulmnT = rs(i).name
rs.close
exit function
end if
next
rs.close
End function
function datatypeStr(DATA_TYPE,CHARACTER_MAXIMUM_LENGTH)
select case DATA_TYPE
case 130
if CHARACTER_MAXIMUM_LENGTH = 0 then
if UniCodeMode = " 1 " then
datatypeStr = " ntext " ' LongText
else
datatypeStr = " text " ' LongText
end if
else
if UniCodeMode = " 1 " then
datatypeStr = " nvarchar( " & CHARACTER_MAXIMUM_LENGTH & " ) " ' 双字节必须使用 bvarchar 否则导入后截断
else
datatypeStr = " varchar( " & CHARACTER_MAXIMUM_LENGTH & " ) " ' 双字节必须使用 bvarchar 否则导入后截断
end if
end if
case 17 datatypeStr = " tinyint "
case 2 datatypeStr = " Smallint "
case 3 datatypeStr = " integer "
case 4 datatypeStr = " real " ' or /同意词 float4
case 5 datatypeStr = " float " ' or /同意词 float8
case 6 datatypeStr = " money " ' or /同意词 CURRENCY
case 7 datatypeStr = " datetime "
case 11 datatypeStr = " bit "
case 72 datatypeStr = " UNIQUEIDENTIFIER " ' or /同意词 GUID
case 131 datatypeStr = " DECIMAL " ' or /同意词 DEC
case 128 datatypeStr = " BINARY " ' or /同意词 DEC
end select ' AUTOINCREMENT
end function
function defaultStr(DATA_TYPE,COLUMN_DEFAULT,exec)
if isNull (COLUMN_DEFAULT) then
defaultStr = ""
exit function
end if
dim splitchar
if exec = 1 then
splitchar = " """" "
elseif exec = 0 then
splitchar = " "" "
end if
COLUMN_DEFAULT = defaultStrfilter(COLUMN_DEFAULT)
select case DATA_TYPE
case 130
COLUMN_DEFAULT = replace (COLUMN_DEFAULT, " "" " ,splitchar)
defaultStr = " Default (' " & COLUMN_DEFAULT & " ') "
Case 11
If LCase (COLUMN_DEFAULT) = " true " Or LCase (COLUMN_DEFAULT) = " on " Or LCase (COLUMN_DEFAULT) = " yes " Then
COLUMN_DEFAULT = 1
Else : COLUMN_DEFAULT = 0
End If
defaultStr = " Default ( " & COLUMN_DEFAULT & " ) "
case 128
defaultStr = " Default (0x " & COLUMN_DEFAULT & " ) " ' or /同意词 DEC
case 7
If LCase (COLUMN_DEFAULT) = " now() " Or _
LCase (COLUMN_DEFAULT) = " date() " Or _
LCase (COLUMN_DEFAULT) = " time() " Then COLUMN_DEFAULT = " getdate() "
if left (COLUMN_DEFAULT, 1 ) = " # " then COLUMN_DEFAULT = replace (COLUMN_DEFAULT, " # " , " ' " )
defaultStr = " Default ( " & COLUMN_DEFAULT & " ) " ' or /同意词 DEC
case else
defaultStr = " Default ( " & COLUMN_DEFAULT & " ) "
end select
end function
Function defaultStrfilter(S)
Do While Left (S, 1 ) = " "" "
S = Mid (S, 2 )
Loop
Do While Right (S, 1 ) = " "" "
S = Left (S, Len (S) - 1 )
Loop
Do While Left (S, 1 ) = " ' "
S = Mid (S, 2 )
Loop
Do While Right (S, 1 ) = " ' "
S = Left (S, Len (S) - 1 )
Loop
defaultStrfilter = S
End Function
Function nullStr(IS_NULLABLE, tablename, columnName)
If IS_NULLABLE Then
If getPrimaryKey(tablename, columnName) = "" Then
nullStr = " null "
Else
nullStr = " not null "
End If
Else
nullStr = " not null "
End If
End Function
' 断点调试 num=0 中断
Sub rw(str,num)
dim istr:istr = str
dim inum:inum = num
response.write str & " <br> "
if inum = 0 then response.end
end sub
SUB CreateMDB()
' 改配置表名和列名
dim cat,NewDB_Name
NewDB_Name = request( " DB_Name " )
if NewDB_Name <> "" then
if instr (NewDB_Name, " :\ " ) = 0 and instr (NewDB_Name, " :/ " ) = 0 then
NewDB_Name = Server.MapPath(NewDB_Name)
end if
set cat = Server.CreateObject( " ADOX.Catalog " )
cat.Create " Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & NewDB_Name
set cat = nothing
CreateDB(NewDB_Name)
response.write vbcrlf & " OK "
else
set cat = nothing
call main()
end if
End SUB
' =============================编写access sql 脚本============//
Function questStr(Str)
Str = request(Str)
Str = replace (Str, " ' " , "" )
Str = Replace (Str, Chr ( 0 ), "" )
Str = Replace (Str, " " , "" )
questStr = Str
End Function
Function Ados_Read(FileName,CharsetType)
dim adosText
Ados_Read = ""
if instr (FileName, " :\ " ) = 0 and instr (FileName, " :/ " ) = 0 then
FileName = Server.mappath(FileName)
end if
set adosText = Server.CreateObject( " ADODB.Stream " )
adosText.mode = 3
adosText.type = 2 ' textStream
adosText.charset = "" & CharsetType & ""
adosText.open
adosText.loadFromFile FileName
Ados_Read = adosText.ReadText()
adosText.close
set adosText = nothing
End Function
SUB Ados_Write(TextString,FileName,CharsetType)
dim adosText
if instr (FileName, " :\ " ) = 0 and instr (FileName, " :/ " ) = 0 then
FileName = Server.mappath(FileName)
end if
set adosText = Server.CreateObject( " ADODB.Stream " )
adosText.mode = 3
adosText.type = 2 ' textStream
adosText.charset = "" & CharsetType & ""
adosText.open
adosText.setEos
adosText.WriteText(TextString)
adosText.SaveToFile FileName, 2
adosText.close
set adosText = nothing
End SUB
Function Add_aspExec()
dim S
S = S & " call CreateSQLDB() " & vbCrlf
S = S & vbCrlf
S = S & " SUB Main() " & vbCrlf
S = S & " Response.write(""<html><head></head><body topmargin=0><br><center><FORM METHOD=POST><table border=1><tr><td><table cellspacing=0 cellpadding=2 align=center border=0 width=""""600"""" style=""""font-size:9pt"""" bgcolor=#D4D0C8>"") " & vbCrlf
S = S & " Response.write(""<tr bgcolor=#A4D0F8><td colspan=2 align=center style=""""font-size:9pt;color:#000000"""" height=30><b>Access To SQL server 导入</b>(CooSel2.0 CreateSQL脚本编写器创建 )</td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr bgcolor=#667766><td colspan=2 height=1></td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr><td align=right width=""""30%"""">Sa登陆密码:</td><td><input name=sapass type=password Value=' " & sapass & " ' style=""""width:70%;"""">(必须输入才能键库)</td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr bgcolor=#667766><td colspan=2 height=1></td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr><td align=right width=""""30%"""">要导入的Access数据库:</td><td><input name=DB_Name Value=' " & DB_Name & " ' style=""""width:70%;""""></td></tr>"") " & vbCrlf
S = S & " " & vbCrlf
S = S & " Response.write(""<tr><td align=right width=""""30%"""">新建SQL数据库名:</td><td><input name=NewDB_Name Value=' " & databasename & " ' style=""""width:70%;""""></td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr><td align=right>新建SQL数据库登陆名:</td><td><input name=loginName Value=' " & loginName & " ' style=""""width:70%;""""></td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr><td align=right>新建SQL数据库登陆密码:</td><td><input type=password name=loginPassword Value=' " & loginPassword & " ' style=""""width:70%;""""></td></tr>"") " & vbCrlf
S = S & " " & vbCrlf
S = S & " Response.write(""<tr><td align=right>是否导入MDB数据到SQL</td><td><input name=DTS type=radio Value='1' checked>是 <input name=DTS type=radio Value='0'>否 </td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr><td align=right></td><td><br><INPUT TYPE=submit name=CreateDB Value="""" 确 定 """"><br><br>注:如果有外键则只建库结构再导入数据可能会出错,要导入的数据库必须和原来的编写SQL脚本的数据库结构一致</td></tr>"") " & vbCrlf
S = S & " Response.write(""</table></td></tr></table></FORM></center><body></html>"") " & vbCrlf
S = S & " End SUB " & vbCrlf
S = S & vbCrlf
S = S & " SUB CreateSQLDB() " & vbCrlf
S = S & " dim NewDB_Name,loginName,loginpassword,sapass,DB_Name,DTS,Tstr " & vbCrlf
S = S & " NewDB_Name=questStr(""NewDB_Name"") " & vbCrlf
S = S & " loginName=questStr(""loginName"") " & vbCrlf
S = S & " loginpassword=questStr(""loginpassword"") " & vbCrlf
S = S & " sapass=questStr(""sapass"") " & vbCrlf
S = S & " DB_Name=questStr(""DB_Name"") " & vbCrlf
S = S & " DTS=questStr(""DTS"") " & vbCrlf
S = S & " if isNumeric(DTS) then " & vbCrlf
S = S & " DTS=clng(DTS) " & vbCrlf
S = S & " else DTS=0 " & vbCrlf
S = S & " end if " & vbCrlf
S = S & " if DTS=0 then " & vbCrlf
S = S & " Tstr=""创建完成"" " & vbCrlf
S = S & " else Tstr=""创建完成,数据已经导入"" " & vbCrlf
S = S & " end if " & vbCrlf
S = S & " if NewDB_Name<>"""" then " & vbCrlf
S = S & " Call CreateDB(DB_Name,NewDB_Name,loginName,loginpassword,sapass,DTS) " & vbCrlf
S = S & " response.write vbcrlf & Tstr & ""<br>连接字串:<br>CONNstr=""""Provider=SQLOLEDB.1;Persist Security InFso=true;Data Source='(local)';Initial Catalog='"" & NewDB_Name & ""';User ID='"" & loginName & ""';Password='"" & loginpassword & ""';CONNect Timeout=30""""<br>"" & vbcrlf " & vbCrlf
S = S & " else " & vbCrlf
S = S & " call main() " & vbCrlf
S = S & " end if " & vbCrlf
S = S & " End SUB " & vbCrlf
S = S & vbCrlf
S = S & " Function questStr(Str) " & vbCrlf
S = S & " Str=request(Str) " & vbCrlf
S = S & " Str=replace(Str,""'"","""") " & vbCrlf
S = S & " Str=Replace(Str,Chr(0),"""") " & vbCrlf
S = S & " Str=Replace(Str,"" "","""") " & vbCrlf
S = S & " questStr=Str " & vbCrlf
S = S & " End Function " & vbCrlf
S = S & vbCrlf
Add_aspExec = S
End Function
% >
< hr size = 1 >
< center > Create by < a href = " http://www.paintblue.net/ " > V37 PaintBlue.Net 极点视觉 </ a > 2004 - 11 - 12 </ center >
< hr size = 1 >
< br >
< br >
</ BODY >
</ HTML >
< % Option Explicit
response.buffer = true
Response.Expires = - 1
Response.AddHeader " Pragma " , " no-cache "
Response.AddHeader " cache-ctrol " , " no-cache "
' build2004-11-20 V1.05
% >< !DOCTYPE HTML PUBLIC " -//W3C//DTD HTML 4.0 Transitional//EN " >
< HTML >
< HEAD >
< TITLE > CooSel2. 0 Access to SQLserver 数据库生迁脚本编写器 V1. 05 (V37 PaintBlue.Net 2004 Acp Code) </ TITLE >
< META NAME = " Generator " CONTENT = " EditPlus " >
< META NAME = " Author " CONTENT = " V37 " >
< META NAME = " Keywords " CONTENT = " PaintBlue.Net,PaintBlue " >
< META NAME = " Description " CONTENT = " PaintBlue.Net " >
< style >
table{ color: # 000000 ;
font - size: 9pt;
FONT - FAMILY: " Tahoma " , " MS Shell Dlg " ;
}
td { color: # 000000 ;
font - size: 9pt;
}table{ color: # 000000 ;
font - size: 9pt;
FONT - FAMILY: " Tahoma " , " MS Shell Dlg " ;
}
body { color: # 000000 ;
font - size: 9pt;
}
</ style >
</ HEAD >
< body bgCOLOR = eeeeee text = " #000000 " leftmargin = " 0 " marginwidth = " 100% " topmargin = " 0 " bottommargin = " 20 " >
< %
' 2004-11-18/
' fix exec=0 =1 type
' fix conv now() date() time() type
' fix binary ole conv 不做导入
' fix Asp代码生成
dim enMode,UniCodeMode
dim DB_Name,ExtName,FileName
dim rs,CONN,CONNstr
DB_Name = questStr( " DB_Name " )
FileName = questStr( " DB_Name " )
enMode = questStr( " enMode " )
UniCodeMode = questStr( " UniCodeMode " )
if not isnumeric (enMode) then enMode = 0
' 2004-11-18
dim databaseName,darr,errinfo
dim loginName
dim loginPassword
dim sapass
errinfo = ""
databaseName = questStr( " databaseName " )
loginName = questStr( " loginName " )
loginPassword = questStr( " loginPassword " )
sapass = questStr( " sapass " )
if not checkchar(loginName) then
errinfo = errinfo & " 要生成的SQL数据库登陆名称含不合法字符\n "
end if
if not checkchar(databaseName) then
errinfo = errinfo & " 要生成的SQL数据库名称含不合法字符\n "
end if
if errinfo <> "" then GetAlert errinfo
if databaseName = "" and DB_Name <> "" then
darr = split (DB_Name, " \ " )
databaseName = split (darr( ubound (darr)), " . " )( 0 )
end if
' --------/
if DB_Name <> "" then
enMode = clng (enMode)
if enMode = 0 then
ExtName = " .Sql "
else
ExtName = " .Asp "
end if
Call openDB(DB_Name)
Call CreateSQL(DB_Name,enMode)
else
if DB_Name = "" then DB_Name = " data/mydb.mdb "
Call Main()
end if
' 2004-11-18
Function CheckChar(testchar)
CheckChar = true
dim chars,i,j,charlen
chars = testchar
dim ichar
ichar = array ( " = " , " \ " , " ( " , " ) " , " / " , " % " , chr ( 32 ), " ? " , " & " , " $ " , " ; " , " , " , " ' " , chr ( 34 ), chr ( 9 ), chr ( 0 ), " * " , " > " , " < " , " | " , " : " , " # " )
charlen = len (chars)
for i = 0 to ubound (ichar)
if instr (chars,ichar(i)) > 0 then
CheckChar = false
exit function
end if
next
End function
SUB GetAlert(errinfo)
% >
< !DOCTYPE HTML PUBLIC " -//W3C//DTD HTML 4.0 Transitional//EN " >
< HTML >< HEAD >< TITLE > CooSel GetAlert Error </ TITLE >
< META NAME = " Generator " CONTENT = " EditPlus " >
< META NAME = " Author " CONTENT = " V37 " ></ head >
< body leftmargin = " 0 " rightmargin = " 0 " topmargin = " 0 " bgcolor = " #D4D0C8 " >
</ BODY >
</ HTML >
< SCRIPT LANGUAGE = " JavaScript " >
< ! --
alert( " <%=errinfo%> " );
window.history.back();
//-->
</ SCRIPT >< %
if isObject (CONN) then closeDB
response.end
End SUB
Sub CloseDB
CONN.close
Set CONN = nothing
End Sub
Sub MAIN()
% >
< style >
.titlebar {
FONT - WEIGHT: bold; FONT - SIZE: 12pt; FILTER : dropshadow(color = # 333333 , offx = 1 , offy = 2 ); WIDTH: 100 %; COLOR: #ffffff; FONT - FAMILY: Tahoma,Verdana, Arial, sans - serif; POSITION: relative; TOP: 1px
}
</ style >
< FORM METHOD = POST ACTION = " ?action=1 " Name = DBform >
< TABLE width = " 100% " cellspacing = 0 border = 0 >
< TR bgcolor = #D4D0C8 >
< TD align = center height = 32 >< a href = http: // www.paintblue.net / target = _blank >< img src = http: // www.paintblue.net / bbs / images / TitleLogo.gif border = 0 ></ a ></ td >< td >< span class = titlebar >< font color = #ffffff >< b > MiniAccess Editor V1. 0 P3 (Access To SQLserver 数据升迁 脚本编写器) </ b ></ font ></ span ></ TD >
< td ></ td ></ TR >
< TABLE align = center width = " 100% " cellspacing = 1 cellpadding = 3 border = 0 >
</ TABLE >
< TABLE align = center width = " 100% " cellspacing = 1 cellpadding = 3 border = 0 >
< TR bgcolor = # 667766 >< TD align = right height = 10 ></ TD >< TD ></ TD ></ TR >
< TR bgcolor = #D4D0C8 >
< TD align = right >< span id = a > 编写模式 </ span ></ TD >
< TD >
< INPUT TYPE = " radio " NAME = " enMode " value = " 0 " < % if enMode = 0 then response.write " checked " end if % > > Sql文本
< INPUT TYPE = " radio " NAME = " enMode " value = " 1 " < % if enMode = 1 then response.write " checked " end if % > > Asp代码
< ! -- < INPUT TYPE = " radio " NAME = " enMode " value = " 2 " < % if enMode = 2 then response.write " checked " end if % > > 编写完后直接运行 -->
& nbsp; & nbsp; < INPUT TYPE = " checkbox " NAME = " UniCodeMode " value = " 1 " checked > 文本和备注按Unicode导入
</ TD >
</ TR >
< TR bgcolor = #D4D0C8 >
< TD align = right width = 250 > MDB数据库路径 </ TD >
< TD >< INPUT TYPE = " text " NAME = " DB_Name " value = " <%=DB_Name%> " style = " width:70%; " > </ TD >
</ TR >
< TR bgcolor = #D4D0C8 >
< TD align = right width = 250 > SQLserver登陆帐号(sa) </ TD >
< TD >< INPUT TYPE = " password " NAME = " sapass " value = "" style = " width:30%; " > SQL数据库(sa)登陆密码,可以不用输入,生成完脚本再提供 </ TD >
</ TR >
< TR bgcolor = #D4D0D8 >
< TD align = right width = 250 > 导入SQL的后的数据库名 </ TD >
< TD >< INPUT TYPE = " text " NAME = " databasename " value = " <%= " myDatabase " %> " style = " width:30%; " > </ TD >
</ TR >
< TR bgcolor = #D4D0D8 >
< TD align = right width = 250 > 导入SQL的数据库登陆帐号 </ TD >
< TD >< INPUT TYPE = " text " NAME = " loginName " value = " <%= " my_login " %> " style = " width:30%; " > </ TD >
</ TR >
< TR bgcolor = #D4D0D8 >
< TD align = right width = 250 > 导入SQL的数据库登陆密码 </ TD >
< TD >< INPUT TYPE = " password " NAME = " loginPassword " value = " <%= " my_pass " %> " style = " width:30%; " > </ TD >
</ TR >
< TR bgcolor = # 667766 >< TD align = right height = 10 ></ TD >< TD ></ TD ></ TR >
< TR >
< TD height = 38 ></ TD >
< TD bgcolor = #D4D0C8 > & nbsp; & nbsp; < INPUT TYPE = " submit " value = " 确 定 " style = " width:80; " ></ TD >
</ TR >
< TR >
< TD height = 38 ></ TD >
< TD bgcolor = #D4D0C8 > & nbsp; & nbsp;
< li ><< 简介 >>
< li > For Access 数据库导入 SQLserver 的版本,生成的在SQL2000下执行的 SQL脚本, < br > & nbsp; & nbsp; & nbsp; & nbsp;除了还原库结构,还同时将Access的数据导入 SQLserver
< br > & nbsp; & nbsp; & nbsp; & nbsp;由于SQLserver的视图不一样,Access能自动处理同名列, < br > & nbsp; & nbsp; & nbsp; & nbsp;脚本生成对含Select * 有同名列的联合查询作了自动转换,有可能需要对照重修改一下
< li > 功能:可编写Access数据库的常用的主要对象,包括 < br > & nbsp; & nbsp; & nbsp; & nbsp; < b > 表,视图,索引,约束,包括 默认值,主键,自动编号,外键 </ b > (表关系)
< li > 编写完自动保存为原数据库名 + 相应扩展的文件
< li > Asp模式可直接生成带表单输入的可执行的Asp文件,用生成的Asp文件即可生成新的数据库
< li > Sql模式可直接生成纯Sql语句文本 </ li >< br >< br ></ TD >
</ TR >
</ Table >
</ FORM >
< %
End SUB
' ====MiniAcces Editor1.0part2 Access SQL脚本编写器(V37 PaintBlue.Net 2004 Acp Code)=========
SUB openDB(DB_Name)
if inStr (DB_Name, " :/ " ) = 0 and inStr (DB_Name, " :\ " ) = 0 then
DB_Name = server.mappath(DB_Name)
end if
Set CONN = Server.CreateObject( " ADODB.CONNection " )
on error resume next
CONN.Open " Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & DB_Name
if err.number <> 0 then
rw " 数据库打开失败,错误为: " & err.description, 0
err.clear
else
Set rs = Server.CreateObject( " adodb.recordSet " )
end if
End SUB
SUB CreateSQL(DB_Name,exec)
' 创建模式
' exec = 0 : 生成SQL语句
' exec = 1 : 生成Asp程序
dim tbls,tabsArr,ub,I,TtempStr,TtempStrHead,remchar
dim TableStr
if exec = 1 then
TtempStrHead = " < " & " % @ LANGUAGE=""VBSCRIPT""% " & " > " & vbcrlf
TtempStrHead = TtempStrHead & " < " & " %Option Explicit " & vbcrlf
TtempStrHead = TtempStrHead & " response.buffer=true " & vbcrlf & vbcrlf
TtempStrHead = TtempStrHead & " '========================================================================= " & vbcrlf & " 'Access 数据库 SQL 脚本生成 by MiniAccess Edit V1.0 P2(V37 PaintBlue.Net 2004 Asp Code) " & vbcrlf & " '========================================================================= " & vbcrlf & vbcrlf
end if
if instr (DB_Name, " :\ " ) = 0 and instr (DB_Name, " :/ " ) = 0 then
DB_Name = Server.MapPath(DB_Name)
end if
CONNstr = " Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & DB_Name
Set CONN = Server.CreateObject( " ADODB.Connection " )
CONN.Open CONNstr
' rs.open "[查询3]",CONN
' for i=0 to rs.fields.count-1
' rw rs(i).name,1
' next
' response.end
' 编写CONN对象
if exec = 1 then
TtempStr = TtempStr & " SUB CreateDB(DB_Name,NewDB_Name,loginName,loginPassword,sapass,DTS) " & vbcrlf
TtempStr = TtempStr & " DIM CONN,CONNstr " & vbcrlf
' TtempStr=TtempStr & "CONNStr=""Provider=Microsoft.Jet.OLEDB.4.0;Data Source="" & DB_Name" & vbcrlf
TtempStr = TtempStr & " CONNStr=""Provider=SQLOLEDB.1;Password='"" & sapass & ""';Persist Security InFso=true;User ID='sa';Initial Catalog='Master';Data Source='(local)';CONNect Timeout=30"" " & vbcrlf
TtempStr = TtempStr & " Set CONN=Server.CreateObject(""ADODB.Connection"") " & vbcrlf
TtempStr = TtempStr & " CONN.open CONNStr " & vbcrlf & vbcrlf
' 2004-11-18
TtempStr = TtempStr & " CONN.execute(""Create Database ["" & NewDB_Name & ""]"") " & vbcrlf
TtempStr = TtempStr & " CONN.close " & vbcrlf
TtempStr = TtempStr & " CONNStr=""Provider=SQLOLEDB.1;Password='"" & sapass & ""';Persist Security InFso=true;User ID='sa';Initial Catalog='"" & NewDB_Name & ""';Data Source='(local)';CONNect Timeout=30"" " & vbcrlf
TtempStr = TtempStr & " CONN.open CONNStr " & vbcrlf & vbcrlf
' 2004-11-18
TtempStr = TtempStr & " CONN.execute(""exec sp_addlogin '"" & loginName & ""','"" & loginPassword & ""','"" & NewDB_Name & ""'"") " & vbcrlf
TtempStr = TtempStr & " CONN.execute(""exec sp_adduser '"" & loginName & ""','"" & loginName & ""','db_owner'"") " & vbcrlf
' -----/
elseif exec = 0 then
TtempStr = TtempStr & " Create Database [ " & databaseName & " ] " & vbcrlf & " go " & vbcrlf
TtempStr = TtempStr & " use [ " & databaseName & " ] " & vbcrlf & " go " & vbcrlf & vbcrlf
' 2004-11-18
TtempStr = TtempStr & " exec sp_addlogin ' " & loginName & " ',' " & loginPassword & " ',' " & databaseName & " ' " & vbcrlf & " go " & vbcrlf
TtempStr = TtempStr & " exec sp_adduser ' " & loginName & " ',' " & loginName & " ','db_owner' " & vbcrlf & " go " & vbcrlf
' -----/
end if
' 编写表/索引对象
Set tbls = CONN.openSchema( 20 ) ' adSchemaPrimaryKeys
tbls.Filter = " TABLE_TYPE='TABLE' " ' 筛选出有默认值,但允许null的列
while Not tbls.eof
TableStr = TableStr & " | " & tbls( " TABLE_Name " )
tbls.movenext
wend
tbls.filter = 0
tbls.close
set tbls = nothing
TableStr = mid (TableStr, 2 )
if exec = 1 then
remchar = " ' "
elseif exec = 0 then
remchar = " -- "
end if
if TableStr <> "" then
tabsArr = split (TableStr, " | " )
ub = ubound (tabsArr)
for I = 0 to ub
TtempStr = TtempStr & remchar & " [ " & tabsArr(I) & " ]: " & vbcrlf
TtempStr = TtempStr & CreatTableSql(tabsArr(I),exec) & vbcrlf & vbcrlf
next
end if
' 编写数据导入
if exec = 1 then TtempStr = TtempStr & " If DTS=1 then " & vbcrlf
TtempStr = TtempStr & CreateOpenDataSource(TableStr,DB_Name,exec)
if exec = 1 then TtempStr = TtempStr & " End iF " & vbcrlf
' 编写表关系
if TableStr <> "" then TtempStr = TtempStr & CreatForeignSql(exec)
' 编写视图
TtempStr = TtempStr & CreatViewSql(exec) & vbcrlf
if exec = 1 then
TtempStr = replace (TtempStr, " > " , " "" & chr(62) & "" " )
TtempStr = replace (TtempStr, " < " , " "" & chr(60) & "" " )
TtempStr = TtempStr & " End SUB " & vbcrlf & vbcrlf
TtempStr = TtempStr & Add_aspExec()
TtempStr = TtempStrHead & TtempStr & vbcrlf & " % " & " > "
elseif exec = 0 then
TtempStr = TtempStr & " --========================================================================= " & vbcrlf & " --Access To SQL 数据库升迁脚本 by MiniAccess Edit V1.0 P2(V37 PaintBlue.Net 2004) " & vbcrlf & " --========================================================================= " & vbcrlf & vbcrlf
TtempStr = TtempStr & vbCrLf & " --连接字串:CONNstr=""Provider=SQLOLEDB.1;Persist Security InFso=true;Data Source='(local)';Initial Catalog=' " & databaseName & " ';User ID=' " & loginName & " ';Password=' " & loginPassword & " ';CONNect Timeout=30"" " & vbCrLf & vbCrLf
end if
call Ados_Write(TtempStr,DB_Name & ExtName, " gb2312 " )
rw " <br><img width=100 height=0> " & DB_Name & " 的SQL脚本编写完成 " , 1
rw " <img width=100 height=0>已经保存文件为<b><font color=blue> " & DB_Name & ExtName & " </font></b>[<a href=?>返回</a>]: " , 1
rw " <center><textarea style=""width:70%;height:500px;"" wrap=""off""> " & server.Htmlencode(TtempStr) & " </textarea></center> " , 1
End SUB
function CreatViewSql(exec)
dim cols
dim FKtable,PK_cols,FK_cols,tmpStr,tmpStr1,VIEW_DEFINITION
Set cols = CONN.openSchema( 23 )
cols.filter = 0
while not cols.eof
tmpStr1 = ""
VIEW_DEFINITION = replace (cols( " VIEW_DEFINITION " ), chr ( 13 ), "" )
VIEW_DEFINITION = replace (VIEW_DEFINITION, chr ( 10 ), " " )
VIEW_DEFINITION = left (VIEW_DEFINITION, len (VIEW_DEFINITION) - 1 )
VIEW_DEFINITION = TransView(cols( " TABLE_NAME " ),VIEW_DEFINITION)
tmpStr1 = " Create view [dbo].[ " & cols( " TABLE_NAME " ) & " ] As " & VIEW_DEFINITION & ""
if exec = 1 then tmpStr1 = " CONN.execute("" " & tmpStr1 & " "") "
tmpStr = tmpStr & vbcrlf & tmpStr1
if exec = 0 then tmpStr = tmpStr & vbcrlf & " go "
cols.movenext
wend
cols.close
set cols = nothing
CreatViewSql = tmpStr
End Function
Function TransView(viewName,Str)
dim S
S = lcase (Str)
S = replace (S, chr ( 9 ), " " )
S = replace (S, chr ( 32 ), " " )
S = replace (S, chr ( 10 ), " " )
S = replace (S, chr ( 13 ), "" )
S = replace (S, " ; " , " " )
do while instr (S, " " ) > 0
S = replace (S, " " , " " )
loop
S = replace (S, " count(*) " , " count(*) as count_x " )
if instr ( lcase (S), " * from " ) = 0 then
TransView = S
else
TransView = replace (S, " * from " ,GetviewColumnStr(viewName) & " from " )
end if
' rw GetviewColumnStr(viewName),1
' rw instr(lcase(S),"* from"),1
End Function
function GetviewColumnStr(viewName)
dim rs,i,tmpstr,arr,j,chg
chg = false
' rw "[" & viewName & "]",0
set rs = server.createobject( " adodb.recordset " )
' rw "select * from [" & tablename & "] where 1=0",1
rs.open " [ " & viewName & " ] " ,conn
dim tmp
if rs.fields.count > 0 then
tmpstr = rs( 0 ).name
for i = 1 to rs.fields.count - 1
tmpstr = tmpstr & " , " & rs(i).name
next
tmpstr = lcase (tmpstr)
arr = split (tmpstr, " , " )
for i = 0 to ubound (arr)
tmp = arr(i)
arr(i) = " [ " & arr(i) & " ] "
if instr (arr(i), " . " ) > 0 then
arr(i) = replace (arr(i), " . " , " ].[ " )
arr(i) = arr(i) & " as " & replace (tmp, " . " , " _ " )
chg = true
end if
next
if chg then
GetviewColumnStr = join (arr, " , " )
else
GetviewColumnStr = " * "
end if
else
GetviewColumnStr = ""
end if
end function
function CreatTableSql(byval tableName,exec)
dim cols
dim TmpStr,TmpStr1
Set cols = CONN.openSchema( 4 )
dim splitchar,splitchar1
if exec = 1 then
splitchar = " "" "
splitchar1 = " "" & _ "
elseif exec = 0 then
splitchar = ""
splitchar1 = ""
end if
cols.filter = " Table_name=' " & tableName & " ' "
if cols.eof then
exit function
end if
dim cat,autoclumn,n,chkPrimaryKey
n = 0
' 编写表脚本
autoclumn = GetAutoincrementCoulmnT(tableName)
tmpStr1 = " CREATE TABLE [dbo].[ " & tableName & " ] ( " & splitchar1 & vbcrlf
dim autoclumnStr,columnStr
if autoclumn <> "" then
autoclumnStr = " " & splitchar & " [ " & autoclumn & " ] integer IDENTITY (1, " & GetIncrement(tableName,autoclumn) & " ) not null "
end if
n = 0
do
n = n + 1
cols.filter = " Table_name=' " & tableName & " ' and ORDINAL_POSITION= " & n
if cols.eof then exit do
if n > 1 then tmpStr1 = tmpStr1 & " , " & splitchar1 & vbcrlf
if autoclumn = cols( " Column_name " ) then
tmpStr1 = tmpStr1 & autoclumnStr
else
tmpStr1 = tmpStr1 & " " & splitchar & " [ " & cols( " Column_name " ) & " ] " & lcase (datatypeStr(cols( " DATA_TYPE " ),cols( " CHARACTER_MAXIMUM_LENGTH " ))) & defaultStr(cols( " DATA_TYPE " ),cols( " COLUMN_DEFAULT " ),exec) & nullStr(cols( " IS_NULLABLE " ), tablename, cols( " Column_name " ))
end if
cols.movenext
loop
tmpStr1 = tmpStr1 & splitchar1 & vbcrlf & " " & splitchar & " ) ON [Primary] "
cols.close
if exec = 0 then tmpStr1 = tmpStr1 & splitchar1 & vbcrlf & "" & splitchar & " go "
if exec = 1 then
TmpStr1 = " CONN.execute("" " & TmpStr1 & " "") "
end if
tmpStr = tmpStr & vbcrlf & tmpStr1
' 编写索引脚本
dim InxArr,i,kstr,j
InxArr = split (getInxArr(tableName), " , " )
Set cols = CONN.openSchema( 12 )
for i = 0 to ubound (InxArr)
cols.filter = " Table_name=' " & tableName & " ' and index_name=' " & InxArr(i) & " ' "
kstr = ""
tmpStr1 = ""
if Not isForeignIndex(tableName,InxArr(i)) then ' 外键索引不进行编写
while not cols.eof
kstr = kstr & " ,[ " & cols( " column_name " ) & " ] " & GetInxDesc(TableName,InxArr(i),cols( " column_name " ))
cols.movenext
wend
if isPrimaryKey(TableName,InxArr(i)) then
tmpStr1 = tmpStr1 & " Alter TABLE [dbo].[ " & tableName & " ] WITH NOCHECK ADD CONSTRAINT [PK_ " & tableName & " ] Primary Key Clustered ( " & mid (kstr, 2 ) & " ) ON [Primary] "
else
tmpStr1 = tmpStr1 & " CREATE "
if isUnique(TableName,InxArr(i)) then tmpStr1 = tmpStr1 & " Unique "
tmpStr1 = tmpStr1 & " INDEX [ " & InxArr(i) & " ] on [dbo].[ " & tableName & " ]( " & mid (kstr, 2 ) & " ) ON [Primary] "
end if
if exec = 1 then tmpStr1 = " CONN.execute("" " & tmpStr1 & " "") "
if exec = 0 then tmpStr1 = tmpStr1 & vbcrlf & " go "
tmpStr = tmpStr & vbcrlf & tmpStr1
end if
next
cols.close
cols.filter = 0
CreatTableSql = TmpStr
End function
function CreatForeignSql(exec)
dim cols
dim FKtable,PK_cols,FK_cols,tmpStr,tmpStr1
Set cols = CONN.openSchema( 27 )
cols.filter = " PK_NAME<>Null "
while not cols.eof
tmpStr1 = ""
tmpStr1 = " ALTER TABLE [ " & cols( " FK_TABLE_NAME " ) & " ] " & _
" Add CONSTRAINT [ " & cols( " FK_NAME " ) & " ] " & _
" FOREIGN KEY ([ " & cols( " FK_COLUMN_NAME " ) & " ]) REFERENCES " & _
" [ " & cols( " PK_TABLE_NAME " ) & " ] ([ " & cols( " PK_COLUMN_NAME " ) & " ]) "
if cols( " UPDATE_RULE " ) = " CASCADE " then tmpStr1 = tmpStr1 & " ON UPDATE CASCADE "
if cols( " DELETE_RULE " ) = " CASCADE " then tmpStr1 = tmpStr1 & " ON DELETE CASCADE "
if exec = 1 then tmpStr1 = " CONN.execute("" " & tmpStr1 & " "") "
tmpStr = tmpStr & vbcrlf & tmpStr1
if exec = 0 then tmpStr = tmpStr & vbcrlf & " go "
cols.movenext
wend
cols.filter = 0
cols.close
set cols = nothing
CreatForeignSql = tmpStr
End Function
Function CreateOpenDataSource(TableStr,DB_Name,exec)
' SET IDENTITY_INSERT Co_admin ON
' go
' INSERT INTO dbo.Co_admin (id,username,password,MasterFlag,adduser)
' SELECT id,username,password,MasterFlag,adduser
' FROM OPENDATASOURCE('Microsoft.Jet.OLEDB.4.0','Data Source="d:\www\lfgbox\coosel2.0\data\coosel.asa"')[Co_admin]
' go
' SET IDENTITY_INSERT dbo.Co_admin OFF
' go
dim splitchar,splitchar1,columnStr,rs,i,TmpStr1,tmp,remchar
if exec = 1 then
remchar = " ' "
splitchar = " "" "
splitchar1 = " "" & _ "
elseif exec = 0 then
remchar = " -- "
splitchar = ""
splitchar1 = ""
end if
Set rs = CONN.openSchema( 20 )
rs.Filter = " TABLE_TYPE='TABLE' "
while not rs.EOF
' rw server.htmlencode(rs("TABLE_NAME")),1
columnStr = GetColumnStr(rs( " TABLE_NAME " ))
if columnStr <> "" then
' if n>0 then tmpStr1=tmpStr1 & splitchar1 & vbcrlf
TmpStr1 = TmpStr1 & remchar & " [ " & rs( " TABLE_NAME " ) & " ]: " & vbcrlf
TmpStr1 = TmpStr1 & " CONN.CommandTimeout = 600 " & vbcrlf
if GetAutoincrementCoulmnT(rs( " TABLE_NAME " )) <> "" then
tmp = " SET IDENTITY_INSERT [dbo].[ " & rs( " TABLE_NAME " ) & " ] ON "
if exec = 0 then
tmp = tmp & vbcrlf & " go " & vbcrlf
elseif exec = 1 then
tmp = " CONN.execute("" " & tmp & " "") " & vbcrlf
end if
TmpStr1 = TmpStr1 & tmp & vbcrlf
end if
tmp = " INSERT INTO [dbo].[ " & rs( " TABLE_NAME " ) & " ] ( " & columnStr & " ) " & splitchar1 & vbcrlf
tmp = tmp & " " & splitchar & " SELECT " & columnStr & " " & splitchar1 & vbcrlf
if exec = 0 then
tmp = tmp & " " & splitchar & " FROM OPENDATASOURCE('Microsoft.Jet.OLEDB.4.0','Data Source= " & splitchar & " "" " & DB_Name & " "" " & splitchar & " ')[ " & rs( " TABLE_NAME " ) & " ] "
tmp = tmp & vbcrlf & " go " & vbcrlf
elseif exec = 1 then
tmp = tmp & " " & splitchar & " FROM OPENDATASOURCE('Microsoft.Jet.OLEDB.4.0','Data Source= " & splitchar & " """" & DB_Name & """" " & splitchar & " ')[ " & rs( " TABLE_NAME " ) & " ] "
tmp = " CONN.execute("" " & tmp & " "") " & vbcrlf
end if
TmpStr1 = TmpStr1 & tmp & vbcrlf
if GetAutoincrementCoulmnT(rs( " TABLE_NAME " )) <> "" then
tmp = " SET IDENTITY_INSERT [dbo].[ " & rs( " TABLE_NAME " ) & " ] Off "
if exec = 0 then
tmp = tmp & vbcrlf & " go " & vbcrlf & vbcrlf
elseif exec = 1 then
tmp = " CONN.execute("" " & tmp & " "") " & vbcrlf & vbcrlf
end if
TmpStr1 = TmpStr1 & tmp & vbcrlf
end if
end if
RS.MoveNext
wend
TmpStr1 = TmpStr1 & " CONN.CommandTimeout = 30 " & vbcrlf
rs.filter = 0
rs.close
set rs = nothing
CreateOpenDataSource = TmpStr1
End Function
function GetColumnStr(tablename)
dim rs,i,tmpstr
set rs = server.createobject( " adodb.recordset " )
' rw "select * from [" & tablename & "] where 1=0",1
rs.open " select * from [ " & tablename & " ] where 1=0 " ,conn
if rs.fields.count > 0 then
for i = 0 to rs.fields.count - 1
' rw rs(i).name & "_" & rs(i).type & "<br>",1
if rs(i).type <> 205 then tmpstr = tmpstr & " , " & rs(i).name
next
if tmpstr <> "" then
GetColumnStr = mid (tmpstr, 2 )
else GetColumnStr = ""
end if
else
GetColumnStr = ""
end if
end function
SUB Ac2SQLStr()
dim rs
TMPstr = ""
Set rs = CONN.openSchema( 20 )
rs.Filter = " TABLE_TYPE='TABLE' "
while not rs.EOF
TMPstr = TMPstr & " SELECT * INTO [tmp_ " & rs( " TABLE_NAME " ) & " ] FROM OPENDATASOURCE('Microsoft.Jet.OLEDB.4.0','Data Source=""d:\www\lfgbox\paintblue2.0f2\pbbs\database\paintbase#.asa""')[ " & rs( " TABLE_NAME " ) & " ]<br> "
NN = NN + 1
RS.MoveNext
wend
rs.filter = 0
rs.close
set rs = nothing
End SUB
' 判断是否是外键索引
Function isForeignIndex(TableName,indexName)
dim cols
Set cols = CONN.openSchema( 27 )
cols.filter = " FK_TABLE_Name=' " & TableName & " ' and FK_NAME=' " & indexName & " ' "
if Not cols.eof then
isForeignIndex = true
else
isForeignIndex = false
end if
End Function
' 取得索引列的排序属性
function GetInxDesc(TableName,indexName,ColumnName)
dim cat
set cat = Server.CreateObject( " ADOX.Catalog " )
cat.ActiveCONNection = CONNstr
if cat.Tables( "" & TableName & "" ).Indexes( "" & indexName & "" ).Columns( "" & ColumnName & "" ).SortOrder = 2 then
GetInxDesc = " Desc "
else
GetInxDesc = ""
end if
set cat = nothing
end function
' 取得列数组
function getColumArr(tableName)
dim cols,arr(),n
redim arr( - 1 )
n = 0
redim arr(n)
set cols = CONN.openSchema( 4 )
cols.filter = " Table_Name=' " & tableName & " ' "
while not cols.eof
redim Preserve arr(n)
arr(n) = cols( " column_name " )
cols.movenext
n = n + 1
wend
cols.filter = 0
cols.close
set cols = nothing
getColumArr = arr
end function
' 取得索引数组
function getInxArr1(tableName)
dim cols,arr(),n,tmpCol
redim arr( - 1 )
n = 0
set cols = CONN.openSchema( 12 )
cols.filter = " Table_Name=' " & tableName & " ' "
while not cols.eof
if cols( " index_name " ) <> tmpCol then
redim Preserve arr(n)
arr(n) = cols( " index_name " )
n = n + 1
end if
tmpCol = cols( " index_name " )
cols.movenext
wend
cols.filter = 0
cols.close
set cols = nothing
getInxArr = arr
end function
' 取得索引数组
Function getInxArr(tablename)
Dim cols
Dim n
Dim tmpCol
Dim tmps
n = 0
Set cols = CONN.openSchema( 12 )
cols.Filter = " Table_Name=' " & tablename & " ' "
While Not cols.EOF
If cols( " index_name " ) <> tmpCol Then
tmps = tmps & " , " & cols( " index_name " )
n = n + 1
End If
tmpCol = cols( " index_name " )
cols.movenext
Wend
cols.Filter = 0
cols.Close
Set cols = Nothing
getInxArr = Mid (tmps, 2 )
End Function
function isUnique(TableName,IndexName)
dim cols
set cols = CONN.openSchema( 12 )
cols.filter = " Table_Name=' " & TableName & " ' and Index_Name=' " & IndexName & " ' and UNIQUE=True "
if not cols.eof then
isUnique = true
else
isUnique = false
end if
cols.filter = 0
cols.close
set cols = nothing
end function
function isPrimaryKey(TableName,IndexName)
dim cols
set cols = CONN.openSchema( 12 )
cols.filter = " Table_Name=' " & TableName & " ' and Index_Name=' " & IndexName & " ' and PRIMARY_KEY=True "
if not cols.eof then
isPrimaryKey = true
else
isPrimaryKey = false
end if
cols.filter = 0
cols.close
set cols = nothing
end function
function getPrimaryKey(tableName,columnName)
dim cols
Set cols = CONN.openSchema( 12 )
cols.filter = " Table_Name=' " & tableName & " ' and Column_Name=' " & columnName & " ' and PRIMARY_KEY=True "
if not cols.eof then
getPrimaryKey = cols( " INDEX_NAME " )
' isPrimaryKey=true
else
getPrimaryKey = ""
' isPrimaryKey=false
end if
cols.filter = 0
cols.close
set cols = nothing
end function
function existPrimaryKey(tableName)
dim cols
Set cols = CONN.openSchema( 12 )
cols.filter = " Table_Name=' " & tableName & " ' and PRIMARY_KEY=True "
if not cols.eof then
existPrimaryKey = true
else
existPrimaryKey = false
end if
cols.filter = 0
cols.close
set cols = nothing
end function
Function GetIncrement(tableName,columnName)
dim cat
set cat = Server.CreateObject( " ADOX.Catalog " )
cat.ActiveCONNection = CONNstr
GetIncrement = cat.Tables( "" & TableName & "" ).Columns( "" & columnName & "" ).Properties( " Increment " )
set cat = nothing
end function
Function GetSeed(tableName,columnName)
dim cat
set cat = Server.CreateObject( " ADOX.Catalog " )
cat.ActiveCONNection = CONNstr
GetSeed = cat.Tables( "" & TableName & "" ).Columns( "" & columnName & "" ).Properties( " Seed " )
set cat = nothing
end function
' 通用,内部属性取得自动编号,对SQLserver Access都可以
Function GetAutoincrementCoulmnT(TableName)
dim i
rs.open " select * from [ " & TableName & " ] where 1=0 " ,CONN, 0 , 1
for i = 0 to rs.fields.count - 1
// if rs(i).Properties( " isAutoIncrement " ) = True then
if rs(i).Properties( " isAutoIncrement " ) = True then
GetAutoincrementCoulmnT = rs(i).name
rs.close
exit function
end if
next
rs.close
End function
function datatypeStr(DATA_TYPE,CHARACTER_MAXIMUM_LENGTH)
select case DATA_TYPE
case 130
if CHARACTER_MAXIMUM_LENGTH = 0 then
if UniCodeMode = " 1 " then
datatypeStr = " ntext " ' LongText
else
datatypeStr = " text " ' LongText
end if
else
if UniCodeMode = " 1 " then
datatypeStr = " nvarchar( " & CHARACTER_MAXIMUM_LENGTH & " ) " ' 双字节必须使用 bvarchar 否则导入后截断
else
datatypeStr = " varchar( " & CHARACTER_MAXIMUM_LENGTH & " ) " ' 双字节必须使用 bvarchar 否则导入后截断
end if
end if
case 17 datatypeStr = " tinyint "
case 2 datatypeStr = " Smallint "
case 3 datatypeStr = " integer "
case 4 datatypeStr = " real " ' or /同意词 float4
case 5 datatypeStr = " float " ' or /同意词 float8
case 6 datatypeStr = " money " ' or /同意词 CURRENCY
case 7 datatypeStr = " datetime "
case 11 datatypeStr = " bit "
case 72 datatypeStr = " UNIQUEIDENTIFIER " ' or /同意词 GUID
case 131 datatypeStr = " DECIMAL " ' or /同意词 DEC
case 128 datatypeStr = " BINARY " ' or /同意词 DEC
end select ' AUTOINCREMENT
end function
function defaultStr(DATA_TYPE,COLUMN_DEFAULT,exec)
if isNull (COLUMN_DEFAULT) then
defaultStr = ""
exit function
end if
dim splitchar
if exec = 1 then
splitchar = " """" "
elseif exec = 0 then
splitchar = " "" "
end if
COLUMN_DEFAULT = defaultStrfilter(COLUMN_DEFAULT)
select case DATA_TYPE
case 130
COLUMN_DEFAULT = replace (COLUMN_DEFAULT, " "" " ,splitchar)
defaultStr = " Default (' " & COLUMN_DEFAULT & " ') "
Case 11
If LCase (COLUMN_DEFAULT) = " true " Or LCase (COLUMN_DEFAULT) = " on " Or LCase (COLUMN_DEFAULT) = " yes " Then
COLUMN_DEFAULT = 1
Else : COLUMN_DEFAULT = 0
End If
defaultStr = " Default ( " & COLUMN_DEFAULT & " ) "
case 128
defaultStr = " Default (0x " & COLUMN_DEFAULT & " ) " ' or /同意词 DEC
case 7
If LCase (COLUMN_DEFAULT) = " now() " Or _
LCase (COLUMN_DEFAULT) = " date() " Or _
LCase (COLUMN_DEFAULT) = " time() " Then COLUMN_DEFAULT = " getdate() "
if left (COLUMN_DEFAULT, 1 ) = " # " then COLUMN_DEFAULT = replace (COLUMN_DEFAULT, " # " , " ' " )
defaultStr = " Default ( " & COLUMN_DEFAULT & " ) " ' or /同意词 DEC
case else
defaultStr = " Default ( " & COLUMN_DEFAULT & " ) "
end select
end function
Function defaultStrfilter(S)
Do While Left (S, 1 ) = " "" "
S = Mid (S, 2 )
Loop
Do While Right (S, 1 ) = " "" "
S = Left (S, Len (S) - 1 )
Loop
Do While Left (S, 1 ) = " ' "
S = Mid (S, 2 )
Loop
Do While Right (S, 1 ) = " ' "
S = Left (S, Len (S) - 1 )
Loop
defaultStrfilter = S
End Function
Function nullStr(IS_NULLABLE, tablename, columnName)
If IS_NULLABLE Then
If getPrimaryKey(tablename, columnName) = "" Then
nullStr = " null "
Else
nullStr = " not null "
End If
Else
nullStr = " not null "
End If
End Function
' 断点调试 num=0 中断
Sub rw(str,num)
dim istr:istr = str
dim inum:inum = num
response.write str & " <br> "
if inum = 0 then response.end
end sub
SUB CreateMDB()
' 改配置表名和列名
dim cat,NewDB_Name
NewDB_Name = request( " DB_Name " )
if NewDB_Name <> "" then
if instr (NewDB_Name, " :\ " ) = 0 and instr (NewDB_Name, " :/ " ) = 0 then
NewDB_Name = Server.MapPath(NewDB_Name)
end if
set cat = Server.CreateObject( " ADOX.Catalog " )
cat.Create " Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & NewDB_Name
set cat = nothing
CreateDB(NewDB_Name)
response.write vbcrlf & " OK "
else
set cat = nothing
call main()
end if
End SUB
' =============================编写access sql 脚本============//
Function questStr(Str)
Str = request(Str)
Str = replace (Str, " ' " , "" )
Str = Replace (Str, Chr ( 0 ), "" )
Str = Replace (Str, " " , "" )
questStr = Str
End Function
Function Ados_Read(FileName,CharsetType)
dim adosText
Ados_Read = ""
if instr (FileName, " :\ " ) = 0 and instr (FileName, " :/ " ) = 0 then
FileName = Server.mappath(FileName)
end if
set adosText = Server.CreateObject( " ADODB.Stream " )
adosText.mode = 3
adosText.type = 2 ' textStream
adosText.charset = "" & CharsetType & ""
adosText.open
adosText.loadFromFile FileName
Ados_Read = adosText.ReadText()
adosText.close
set adosText = nothing
End Function
SUB Ados_Write(TextString,FileName,CharsetType)
dim adosText
if instr (FileName, " :\ " ) = 0 and instr (FileName, " :/ " ) = 0 then
FileName = Server.mappath(FileName)
end if
set adosText = Server.CreateObject( " ADODB.Stream " )
adosText.mode = 3
adosText.type = 2 ' textStream
adosText.charset = "" & CharsetType & ""
adosText.open
adosText.setEos
adosText.WriteText(TextString)
adosText.SaveToFile FileName, 2
adosText.close
set adosText = nothing
End SUB
Function Add_aspExec()
dim S
S = S & " call CreateSQLDB() " & vbCrlf
S = S & vbCrlf
S = S & " SUB Main() " & vbCrlf
S = S & " Response.write(""<html><head></head><body topmargin=0><br><center><FORM METHOD=POST><table border=1><tr><td><table cellspacing=0 cellpadding=2 align=center border=0 width=""""600"""" style=""""font-size:9pt"""" bgcolor=#D4D0C8>"") " & vbCrlf
S = S & " Response.write(""<tr bgcolor=#A4D0F8><td colspan=2 align=center style=""""font-size:9pt;color:#000000"""" height=30><b>Access To SQL server 导入</b>(CooSel2.0 CreateSQL脚本编写器创建 )</td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr bgcolor=#667766><td colspan=2 height=1></td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr><td align=right width=""""30%"""">Sa登陆密码:</td><td><input name=sapass type=password Value=' " & sapass & " ' style=""""width:70%;"""">(必须输入才能键库)</td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr bgcolor=#667766><td colspan=2 height=1></td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr><td align=right width=""""30%"""">要导入的Access数据库:</td><td><input name=DB_Name Value=' " & DB_Name & " ' style=""""width:70%;""""></td></tr>"") " & vbCrlf
S = S & " " & vbCrlf
S = S & " Response.write(""<tr><td align=right width=""""30%"""">新建SQL数据库名:</td><td><input name=NewDB_Name Value=' " & databasename & " ' style=""""width:70%;""""></td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr><td align=right>新建SQL数据库登陆名:</td><td><input name=loginName Value=' " & loginName & " ' style=""""width:70%;""""></td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr><td align=right>新建SQL数据库登陆密码:</td><td><input type=password name=loginPassword Value=' " & loginPassword & " ' style=""""width:70%;""""></td></tr>"") " & vbCrlf
S = S & " " & vbCrlf
S = S & " Response.write(""<tr><td align=right>是否导入MDB数据到SQL</td><td><input name=DTS type=radio Value='1' checked>是 <input name=DTS type=radio Value='0'>否 </td></tr>"") " & vbCrlf
S = S & " Response.write(""<tr><td align=right></td><td><br><INPUT TYPE=submit name=CreateDB Value="""" 确 定 """"><br><br>注:如果有外键则只建库结构再导入数据可能会出错,要导入的数据库必须和原来的编写SQL脚本的数据库结构一致</td></tr>"") " & vbCrlf
S = S & " Response.write(""</table></td></tr></table></FORM></center><body></html>"") " & vbCrlf
S = S & " End SUB " & vbCrlf
S = S & vbCrlf
S = S & " SUB CreateSQLDB() " & vbCrlf
S = S & " dim NewDB_Name,loginName,loginpassword,sapass,DB_Name,DTS,Tstr " & vbCrlf
S = S & " NewDB_Name=questStr(""NewDB_Name"") " & vbCrlf
S = S & " loginName=questStr(""loginName"") " & vbCrlf
S = S & " loginpassword=questStr(""loginpassword"") " & vbCrlf
S = S & " sapass=questStr(""sapass"") " & vbCrlf
S = S & " DB_Name=questStr(""DB_Name"") " & vbCrlf
S = S & " DTS=questStr(""DTS"") " & vbCrlf
S = S & " if isNumeric(DTS) then " & vbCrlf
S = S & " DTS=clng(DTS) " & vbCrlf
S = S & " else DTS=0 " & vbCrlf
S = S & " end if " & vbCrlf
S = S & " if DTS=0 then " & vbCrlf
S = S & " Tstr=""创建完成"" " & vbCrlf
S = S & " else Tstr=""创建完成,数据已经导入"" " & vbCrlf
S = S & " end if " & vbCrlf
S = S & " if NewDB_Name<>"""" then " & vbCrlf
S = S & " Call CreateDB(DB_Name,NewDB_Name,loginName,loginpassword,sapass,DTS) " & vbCrlf
S = S & " response.write vbcrlf & Tstr & ""<br>连接字串:<br>CONNstr=""""Provider=SQLOLEDB.1;Persist Security InFso=true;Data Source='(local)';Initial Catalog='"" & NewDB_Name & ""';User ID='"" & loginName & ""';Password='"" & loginpassword & ""';CONNect Timeout=30""""<br>"" & vbcrlf " & vbCrlf
S = S & " else " & vbCrlf
S = S & " call main() " & vbCrlf
S = S & " end if " & vbCrlf
S = S & " End SUB " & vbCrlf
S = S & vbCrlf
S = S & " Function questStr(Str) " & vbCrlf
S = S & " Str=request(Str) " & vbCrlf
S = S & " Str=replace(Str,""'"","""") " & vbCrlf
S = S & " Str=Replace(Str,Chr(0),"""") " & vbCrlf
S = S & " Str=Replace(Str,"" "","""") " & vbCrlf
S = S & " questStr=Str " & vbCrlf
S = S & " End Function " & vbCrlf
S = S & vbCrlf
Add_aspExec = S
End Function
% >
< hr size = 1 >
< center > Create by < a href = " http://www.paintblue.net/ " > V37 PaintBlue.Net 极点视觉 </ a > 2004 - 11 - 12 </ center >
< hr size = 1 >
< br >
< br >
</ BODY >
</ HTML >