今天要转一个access数据库到sqlserver，找到一个asp文件生成脚本，写的很不错，以后都可以用这个东西

<% @ 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>

<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>

'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

End function

SUB GetAlert(errinfo)

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">

<HTML><HEAD><TITLE>CooSel GetAlert Error</TITLE>

</BODY>

</HTML>

<!--

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>

<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>

</TABLE>

<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="checkbox" NAME="UniCodeMode" value="1" checked> 文本和备注按Unicode导入

</TD>

</TR>

<TD align=right width=250>MDB数据库路径</TD>

<TD><INPUT TYPE="text" NAME="DB_Name" value="<%=DB_Name%>" style="70%;"> </TD>

</TR>

<TD align=right width=250>SQLserver登陆帐号(sa)</TD>

<TD><INPUT TYPE="password" NAME="sapass" value="" style="30%;"> SQL数据库(sa)登陆密码,可以不用输入,生成完脚本再提供</TD>

</TR>

<TD align=right width=250>导入SQL的后的数据库名</TD>

<TD><INPUT TYPE="text" NAME="databasename" value="<%="myDatabase"%>" style="30%;"> </TD>

</TR>

<TD align=right width=250>导入SQL的数据库登陆帐号</TD>

<TD><INPUT TYPE="text" NAME="loginName" value="<%="my_login"%>" style="30%;"> </TD>

</TR>

<TD align=right width=250>导入SQL的数据库登陆密码</TD>

<TD><INPUT TYPE="password" NAME="loginPassword" value="<%="my_pass"%>" style="30%;"> </TD>

</TR>

<TR >

</TR>

<TR >

<li>For Access 数据库导入 SQLserver 的版本，生成的在SQL2000下执行的 SQL脚本，<br>        除了还原库结构，还同时将Access的数据导入 SQLserver

<br>        由于SQLserver的视图不一样，Access能自动处理同名列，<br>        脚本生成对含Select *有同名列的联合查询作了自动转换，有可能需要对照重修改一下

<li>功能:可编写Access数据库的常用的主要对象,包括 <br>        <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

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=""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

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

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

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

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

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

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

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

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=""""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=""""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=""""70%;""""></td></tr>"")" & vbCrlf

S = S & " Response.write(""<tr><td align=right>新建SQL数据库登陆名:</td><td><input name=loginName Value='" & loginName & "' style=""""70%;""""></td></tr>"")" & vbCrlf

S = S & " Response.write(""<tr><td align=right>新建SQL数据库登陆密码:</td><td><input type=password name=loginPassword Value='" & loginPassword & "' style=""""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

<center>Create by <a href="http://www.paintblue.net/">V37 PaintBlue.Net 极点视觉</a> 2004-11-12</center>

<br>

</BODY>

</HTML>