レコードセットから INSERT SQL を自動生成するサンプル。
Option Explicit
Const g_strPROVIDER = "SQLOLEDB"
Const g_strSERVER = "(local)"
Const g_strDATABASE = "Northwind"
Const g_strUID = "sa"
Const g_strPWD = "********" ' Please input password
Const g_strTable = "Employees"
' DataTypeEnum
Const adEmpty = 0
Const adSmallInt = 2
Const adInteger = 3
Const adSingle = 4
Const adDouble = 5
Const adCurrency = 6
Const adDate = 7
Const adBSTR = 8
Const adIDispatch = 9
Const adError = 10
Const adBoolean = 11
Const adVariant = 12
Const adIUnknown = 13
Const adDecimal = 14
Const adTinyInt = 16
Const adUnsignedTinyInt = 17
Const adUnsignedSmallInt = 18
Const adUnsignedInt = 19
Const adBigInt = 20
Const adUnsignedBigInt = 21
Const adFileTime = 64
Const adGUID = 72
Const adBinary = 128
Const adChar = 129
Const adWChar = 130
Const adNumeric = 131
Const adUserDefined = 132
Const adDBDate = 133
Const adDBTime = 134
Const adDBTimeStamp = 135
Const adChapter = 136
Const adPropVariant = 138
Const adVarNumeric = 139
Const adVarChar = 200
Const adLongVarChar = 201
Const adVarWChar = 202
Const adLongVarWChar = 203
Const adVarBinary = 204
Const adLongVarBinary = 205
' FieldAttributeEnum
Const adFldCacheDeferred = &h1000
Const adFldFixed = &h10
Const adFldIsChapter = &h2000
Const adFldIsCollection = &h40000
Const adFldIsDefaultStream = &h20000
Const adFldIsNullable = &h20
Const adFldIsRowURL = &h10000
Const adFldLong = &h80
Const adFldMayBeNull = &h40
Const adFldMayDefer = &h2
Const adFldNegativeScale = &h4000
Const adFldRowID = &h100
Const adFldRowVersion = &h200
Const adFldUnknownUpdatable = &h8
Const adFldUnspecified = &hFFFFFFFF
Const adFldUpdatable = &h4
Main
Sub Main()
Dim cn
Dim rs
Set cn = CreateObject("ADODB.Connection")
Dim strConnection
strConnection = "PROVIDER=" & g_strPROVIDER _
& ";SERVER=" & g_strSERVER _
& ";DATABASE=" & g_strDATABASE _
& ";UID=" & g_strUID _
& ";PWD=" & g_strPWD
cn.Open strConnection
Dim strTableName
Dim strSQL
strTableName = g_strTable
strSQL = "select * from " & strTableName
Set rs = cn.Execute( strSQL )
Dim fld
Dim i
Dim nFields
Dim strInsertSQL
Dim strFields
Dim strValues
nFields = rs.Fields.Count
For i = 0 To nFields - 1
If i < nFields - 1 Then
strFields = strFields & rs.Fields(i).Name & "," & vbCrLf
Else
strFields = strFields & rs.Fields(i).Name
End If
Next
While Not rs.Bof And Not rs.Eof
For i = 0 To nFields - 1
If i < nFields - 1 Then
strValues = strValues & GetRecordItem(rs(i)) & "," & vbCrLf
Else
strValues = strValues & GetRecordItem(rs(i))
End If
Next
strInsertSQL = "INSERT INTO " & strTableName & vbCrLf _
& "(" & vbCrLf _
& strFields & vbCrLf _
& ")" & vbCrLf _
& "VALUES" & vbCrLf _
& "( " & vbCrLf _
& strValues & vbCrLf _
& ")"
WScript.Echo strInsertSQL
strInsertSQL = ""
strValues = ""
rs.MoveNext
Wend
End Sub
Function GetRecordItem( ByVal fld )
Dim strQuotation
Dim strItem
strQuotation = ""
Select Case fld.Type
' Numeric
Case _
adSmallInt, adInteger, adSingle, adDouble, adCurrency, _
adBoolean, adTinyInt, adUnsignedTinyInt, adUnsignedSmallInt, _
adUnsignedInt, adBigInt, adUnsignedBigInt, adNumeric
strQuotation = ""
' String
Case _
adBSTR, adVariant, adChar, adWChar, adVarChar, _
adLongVarChar, adVarWChar, adLongVarWChar
strQuotation = "'"
' Empty
Case _
adEmpty
strQuotation = ""
' Other
Case Else
strQuotation = "'"
End Select
If fld.Type = Empty Then
strItem = fld.Value
ElseIf fld.Type = adLongVarBinary Then
strItem = "NULL"
Else
strItem = strQuotation & fld.Value & strQuotation
End If
GetRecordItem = strItem
End Function![[CX's MEMO]](image/cx_memo.jpg "[CX's MEMO]")
