VBAのコード のバックアップ差分(No.4)

[ トップ ]   [ 新規 | 一覧 | 単語検索 | 最終更新 | ヘルプ ]

• バックアップ一覧
• 現在との差分 を表示
• ソース を表示
• バックアップ を表示
• VBAのコード へ行く。
  • 1 (2010-08-20 (金) 10:01:59)
  • 2 (2010-08-20 (金) 10:37:14)
  • 3 (2010-09-21 (火) 12:24:15)
  • 4 (2010-09-21 (火) 16:03:14)

---

• 追加された行はこの色です。
• 削除された行はこの色です。

*目次 [#z0323312]
#contents

*趣旨 [#c8f06ba8]
何度も同じようなコードをインターネットから探しては

自分のルールに沿ってクラス化してきたが、

何度もやるのはめんどくさくなったから、

頻度の高いところをまとめる。

できるならば、クラスをそのまま貼り付ける。


*ファイル操作 [#mfe5e5c7]

**一時ファイル取得 [#g8a4f38a]
 ' 一時ファイル名取得用 API の宣言
 Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" _
    (ByVal lpszPath As String, ByVal lpPrefixString As String, _
    ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
 
 
 ' 一時ファイル名の取得
 Public Function udGetTempFileName(argPath) As String
   Dim lngRet As Long
   Dim strFileName As String * 255
 
   lngRet = GetTempFileName(argPath, "acc", 0&, strFileName)
  
   udGetTempFileName = Left(strFileName, InStr(strFileName, vbNullChar) - 1)
 End Function

*basMain [#j14dac99]
Option Compare Database
Option Explicit

'Sub main()
    'getSnap "YOSHIN", "YOSHIN3", "DSN=TKOTRIP2_DEV; UID=TKOTRIP2_DEV; PWD=TKOTRIP2_DEV;"

    'LoadData "DSN=TKOTRIP2; UID=TKOTRIP2; PWD=TKOTRIP2;", "YOSHIN", "YOSHIN3"
    'getSnap "USER_INFO", "DSN=TKOTRIP2_DEV; UID=TKOTRIP2_DEV; PWD=TKOTRIP2_DEV;"
    'p "main　終了"
'End Sub

'テーブルの構成をコピーする

'文字情報として保存する

'テーブル名の先頭には"T+タイムスタンプ+_"をつけてスキーマとの対応を保全する

'時系列で保存する

'テーブル構成のスナップを保存する
Public Sub getSnap(tablename As String, savename As String, strDSN As String)
    'テーブル作成の準備
    
    'テーブルの情報を集める
    Dim con As New clsConnection
    con.setDSN strDSN '"DSN=TKOTRIP2_DEV; UID=TKOTRIP2_DEV; PWD=TKOTRIP2_DEV;"
    
    Dim tableList As clsTableList
    Set tableList = con.getTableList
    
    'スキーマを検索
    
    'tableList.getItem(tablename).getColumnScheme.save savename & "_SCHEME"
    
    
    '主キーを調べる
    'tableList.getItem(tablename).getPKColumnRecordset.save savename & "_KEY"
    
    Dim cNotNull As clsCollection
    Set cNotNull = tableList.getItem(tablename).getNotNullList
    
    Set tableList = con.getTableList
    
    'データを格納
    tableList.getItem(tablename).toRecordset.save savename, cNotNull
    
    'PKやNOTNULLの設定
    con.addPKToMDB tablename, savename
    

    
    
End Sub


'エンティティ定義書を元にテーブル作成
Public Sub createTable(wb As Workbook, tablename As String, strDSN As String)
    Dim ws As Worksheet
    Dim con As New clsConnection
    
    Dim found As Boolean
    found = False
    
    Dim sqlCommandList As Variant
    Dim intSqlCommandListCount As Integer
    For Each ws In wb.Sheets
        
        DoEvents
        
        If ws.Cells(6, 30).value = tablename Then
            Debug.Print tablename & "テーブルを作成"
            found = True
        
            Dim strSQL As String
            strSQL = subTabelSqlOut(wb, ws.name)
             
            
            con.setDSN strDSN '"DSN=TKOTRIP2_DEV; UID=TKOTRIP2_DEV; PWD=TKOTRIP2_DEV;"
            con.adoCON.BeginTrans
            On Error GoTo ROLLBACK
            sqlCommandList = Split(strSQL, ";")
            For intSqlCommandListCount = 0 To UBound(sqlCommandList)
                
            
                            
                '1文字はコマンドではないとみなす。
                If Len(sqlCommandList(intSqlCommandListCount)) > 2 Then
                    If InStr(1, sqlCommandList(intSqlCommandListCount), "DROP ") = 0 Then
                        con.adoCON.execute sqlCommandList(intSqlCommandListCount)
                    Else
                        'DROP文はOracle側に存在しない場合も想定し無視する。
                        On Error Resume Next
                        con.adoCON.execute sqlCommandList(intSqlCommandListCount)
                        On Error GoTo ROLLBACK
                    End If
                End If
            Next
            con.adoCON.CommitTrans
            On Error GoTo 0
            Debug.Print tablename & "テーブル作成完了"
            
            Exit For
            
        End If
    Next
    
    If Not found Then
        MsgBox "定義書内に" & tablename & "は見つかりませんでした"
    End If
    
    Exit Sub
ROLLBACK:
    MsgBox "エンティティ定義書を見直してください。" & Chr(10) & wb.path & Chr(10) & strSQL & Chr(10) & Err.Description
    Debug.Print Chr(10) & wb.path & Chr(10) & strSQL & Chr(10) & Err.Description
    On Error Resume Next
    con.adoCON.RollbackTrans
    
    Dim yesno As Long
    p strSQL
    yesno = MsgBox("処理を続けますか？", vbYesNo, "確認")
    
    If yesno = vbNo Then
        End
    End If
End Sub


'メッセージを表示
Private Sub p(message As Variant)
    Debug.Print message
End Sub

Public Sub LoadData(strDSN As String, strTablename As String, strTablenameMDB As String, log As clsLog)
    'Oracleに接続
    Dim cCon As New clsConnection
    cCon.setDSN strDSN
    
    Dim cTableList As clsTableList
    Set cTableList = cCon.getTableList
    
    If Not cTableList.isExist(strTablename) Then
        MsgBox "コピー元となるテーブル:" & strTablename & "がOracle側に存在しません。処理を停止します。"
        Exit Sub
    End If
    
    
    'MDBに接続
    Dim cDB As New clsDB
    cDB.OpenDB
    
    If Not cDB.isExistTable(strTablenameMDB) Then
        'MsgBox "コピー元となるテーブル:" & strTablenameMDB & "がAccess側に存在しません。処理を停止します。"
        Exit Sub
    End If
    
    
    'MDBのデータを読み込みます。
    cDB.getTableList.getItem(strTablenameMDB).toRecordset.saveToOracle cCon, strTablename, log
    
    
End Sub


Public Sub LoadDataTimeStamp(strDSN As String, strTablename As String, strTablenameMDB As String, log As clsLog)
    'Oracleに接続
    Dim cCon As New clsConnection
    cCon.setDSN strDSN
    
    Dim cTableList As clsTableList
    Set cTableList = cCon.getTableList
    
    If Not cTableList.isExist(strTablename) Then
        'MsgBox "コピー元となるテーブル:" & strTablename & "がOracle側に存在しません。処理を停止します。"
        Exit Sub
    End If
    
    
    'MDBに接続
    Dim cDB As New clsDB
    cDB.OpenDB
    
    If Not cDB.isExistTable(strTablenameMDB) Then
        'MsgBox "コピー元となるテーブル:" & strTablenameMDB & "がAccess側に存在しません。処理を停止します。"
        Exit Sub
    End If
    
    'MDBのデータを読み込みます。
    cDB.getTableList.getItem(strTablenameMDB).toRecordset.saveToOracleTimeStamp cCon, strTablename, log
End Sub

*basReadEntity [#l9343893]
Option Compare Database
Option Explicit

'参考：

'シートごとのテーブルCreate文を作成する
Public Function subTabelSqlOut(wb As Workbook, strSheetNm As String) As String

    Dim intPk   As Integer  'プライマリーキー
    Dim intId   As Integer  'ID(カラム名)
    Dim intName As Integer  'データ項目名称
    Dim intType As Integer  'タイプ
    Dim intLen  As Integer  '長さ
    Dim intLen2 As Integer  '小数点
    Dim intNull As Integer  'Null許可
    Dim intDef  As Integer  'デフォルト値
    Dim intStart As Integer '項目開始行

    Dim strSchema As String 'スキーマ名
    Dim strTbNm As String   'テーブル名
    Dim strTbId As String   'テーブルID
    Dim strEx As String     'テーブル説明

    Dim strSQL  As String   '出力するSQL文
    Dim strSQLComment As String '出力するCommentSQL文
    Dim intCnt  As Integer  'カウンター
    
    '初期値設定（レイアウトに合わせて修正）
    intPk = 4
    intName = 6
    intId = 14
    intType = 24
    intLen = 28
    intLen2 = 30
    intNull = 32
    intDef = 34

    Dim sh As Worksheet
    Set sh = wb.Sheets(strSheetNm)
    
    'スキーマ名を取得
    On Error Resume Next
    strSchema = Trim(sh.Range("出力スキーマ"))
    On Error GoTo 0
    If strSchema <> "" Then strSchema = strSchema & "."
    
    'テーブル内容を取得
    strTbNm = sh.Cells(6, 7)
    strTbId = sh.Cells(6, 30)
    strEx = sh.Cells(7, 7)

    intStart = 12
    
    ' セル内改行除去
    strEx = Replace(strEx, Chr(10), " ", 1, -1, vbBinaryCompare)
    
    'コメント文生成
    'テーブル名称
    'strSQL = "--テーブル名称:" & strTbNm & vbNewLine
    'テーブルID
    'strSQL = strSQL & "--テーブルＩＤ:" & strTbId & vbNewLine
    '説明
    'strSQL = strSQL & "--説明        " & ":" & strEx & vbNewLine & vbNewLine

    'SQL文作成開始
    strSQL = strSQL & "DROP   TABLE " & strSchema & Trim(strTbId) & ";" & vbNewLine
    strSQL = strSQL & "CREATE TABLE " & strSchema & Trim(strTbId) & "(" & vbNewLine

    '各項目
    Dim i As Integer
    Dim j As Integer
    i = intStart
    Do While sh.Cells(i, intId) <> ""

        '2行名以降はカンマを設定
        If i <> intStart Then
            strSQL = strSQL & ","
        Else
            strSQL = strSQL & " "
        End If
        
        'ID
        strSQL = strSQL & sh.Cells(i, intId) & " "
        
        '文字位置調整（TAB文字）
        j = (27 - Len(sh.Cells(i, intId))) / 4
        If j <> Int(j) Then
            j = Int(j) + 1
        End If
        Dim h As Integer
        
        For h = 1 To j
            strSQL = strSQL & vbTab
        Next
    
        'タイプ
        strSQL = strSQL & sh.Cells(i, intType)
        
        '長さ
        Select Case sh.Cells(i, intType)
            Case "DATE", "TIMESTAMP", "CLOB"
                '長さの出力は不要
            Case Else
                strSQL = strSQL & "(" & Format(sh.Cells(i, intLen), "00")
                If sh.Cells(i, intLen2) <> "" Then
                    strSQL = strSQL & "," & sh.Cells(i, intLen2)
                End If
                strSQL = strSQL & ")"
        End Select
    
        'デフォルト値
        If sh.Cells(i, intDef) <> "" Then
            strSQL = strSQL & vbTab & vbTab & "DEFAULT " & sh.Cells(i, intDef)
        End If
        
        'NULL
        If sh.Cells(i, intNull) <> "" Then
            strSQL = strSQL & vbTab & vbTab & "NOT NULL"
        End If
        
        strSQL = strSQL & vbNewLine

        'コメント
        strSQLComment = strSQLComment & "COMMENT ON COLUMN "
        strSQLComment = strSQLComment & strSchema & strTbId
        strSQLComment = strSQLComment & "."
        strSQLComment = strSQLComment & sh.Cells(i, intId)
        strSQLComment = strSQLComment & " IS '"
        strSQLComment = strSQLComment & sh.Cells(i, intName)
        strSQLComment = strSQLComment & "';"
        strSQLComment = strSQLComment & vbCrLf
        
        '出力最終行を保持
        intCnt = i
    
        i = i + 1
    Loop

    'プライマリーキー
    i = intStart
    Dim flg As Integer
    flg = 0
    For i = intStart To intCnt
        If flg = 0 Then
            If sh.Cells(i, intPk) = "PK" Then
                strSQL = strSQL & ",CONSTRAINT " & Trim(strTbId) & "_KEY " & "PRIMARY KEY(" & sh.Cells(i, intId)
                flg = 1
            End If
        Else
            If sh.Cells(i, intPk) = "PK" Then
                strSQL = strSQL & "," & sh.Cells(i, intId)
            End If
        End If
    Next
    
    If flg = 1 Then
        strSQL = strSQL & ")" & vbNewLine
    End If

    '終了文字列
    strSQL = strSQL & ");" & vbNewLine

    '列の和名を設定
    strSQL = strSQL & strSQLComment
    strSQL = strSQL & ""
    strSQL = strSQL & "COMMENT ON TABLE "
    strSQL = strSQL & strSchema & strTbId
    strSQL = strSQL & " IS '"
    strSQL = strSQL & strTbNm
    strSQL = strSQL & "';"
    strSQL = strSQL & vbCrLf
    
    '実行文字列
    'strSQL = strSQL & "/" & vbNewLine

    'txtファイル出力
    'Dim lngFileNo As Long
    'lngFileNo = FreeFile
    'Open Excel.ActiveWorkbook.Path & "\" & Trim(strTbId) & ".sql" For Output As #lngFileNo
    '    Print #lngFileNo, strSQL
    'Close #lngFileNo
    subTabelSqlOut = strSQL
    
End Function


*clsCollection [#dac6ff07]
Option Compare Database

Public mCol As Collection

    
Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub

Public Function getStringItem(index As Variant) As String
    getStringItem = mCol.Item(index)
End Function

Public Function count() As Long
    count = mCol.count
End Function

Public Sub addByCommmaString(strCommaString As String)
    Dim ary() As String
    ary = Split(strCommaString, ",")
    
    Dim i As Integer
    For i = 0 To UBound(ary)
        mCol.Add ary(i)
    Next
    
End Sub

Public Function getItem(index As Variant) As String
    getItem = mCol.Item(index)
End Function

Public Function getReduceList(pattern As String) As clsCollection
    Dim reg As New RegExp
    Dim ret As New clsCollection
    reg.pattern = pattern
    reg.Multiline = False
    
    Dim i As Integer
    For i = 1 To count
        If Not reg.test(getItem(i)) Then
            ret.addItem getItem(i)
        End If
    Next
    Set getReduceList = ret
End Function

'同じ要素を含む配列を返す
Public Function matchAnd(list As clsCollection) As clsCollection
    Dim uniqList As clsCollection
    Set uniqList = list.uniq
    
    Dim ret As New clsCollection
    Dim i As Integer
    For i = 1 To count
        If uniqList.isExist(getItem(i)) Then
            ret.addItem (getItem(i))
        End If
    Next
    
    Set matchAnd = ret
End Function


Public Sub addItem(value As String)
    mCol.Add value
End Sub


Public Function uniq() As clsCollection
    Dim ret As New clsCollection
    Dim i As Integer
    On Error Resume Next
    For i = 1 To count
        ret.mCol.Add getItem(i), getItem(i)
    Next
    Set uniq = ret
End Function

Public Function isExist(index As Variant) As Boolean
    On Error GoTo noHave
    Dim dummy As String
    dummy = getItem(index)
    isExist = True
    Exit Function
noHave:
    isExist = False
End Function


Public Sub p()
    Dim i As Integer
    For i = 1 To count
        Debug.Print getItem(i)
    Next
End Sub




Public Sub clearAll()
    Dim i As Integer
    For i = count To 1 Step -1
        mCol.Remove i
    Next
End Sub






Private Sub test()
    Idx = MsCombSortI(A)
End Sub


'コムソート
'参考：http://hp.vector.co.jp/authors/VA033788/kowaza.html#0046
Public Function sort() As clsCollection
    
    '昇順インデックスを返す
    '配列引数mColは１次元限定
    Dim Idx() As Long
    'Dim L As Long .. 1
    'Dim U As Long .. mCol.count
    Dim i As Long
    Dim gap As Long
    Dim Temp As Long
    Dim F As Boolean
    
    'U = UBound(mCol)
    
    'インデックス初期設定
    ReDim Idx(mCol.count)
    For i = 1 To mCol.count
        Idx(i) = i
    Next
    
    gap = mCol.count - 1
    F = True
    Dim intConpareResult As Integer
    
    '並べ替え
    Do While gap > 1 Or F = True
        gap = Int(gap / 1.3)
        If gap = 9 Or gap = 10 Then
            gap = 11
        ElseIf gap < 1 Then
            gap = 1
        End If
        F = False
        For i = 1 To mCol.count - gap
            intConpareResult = compare(mCol(Idx(i)), mCol(Idx(i + gap))) ' -1..0..1
            If intConpareResult = 1 Then  '降順時は <
                Temp = Idx(i)
                Idx(i) = Idx(i + gap)
                Idx(i + gap) = Temp
                F = True
            ElseIf intConpareResult = 0 Then
                If Idx(i) > Idx(i + gap) Then   '昇順降順変更しても変更の必要なし
                    Temp = Idx(i)
                    Idx(i) = Idx(i + gap)
                    Idx(i + gap) = Temp
                    F = True
                End If
            End If
        Next
    Loop
    
    '順番を元にソート
    Dim ret As New clsCollection
    
    For i = 1 To mCol.count
        ret.addItem getItem(Idx(i))
    Next
    
    Set sort = ret
End Function

Private Function compare(str1 As String, str2 As String)
    compare = StrComp(str1, str2, vbTextCompare)
End Function


Private Sub セル範囲並べ替え()
    Const 列 As Integer = 1
    Dim A As Variant
    Dim B As Variant
    Dim C As Variant
    Dim myRange As Range
    Dim Idx As Variant
    Dim L As Long
    Dim U As Long
    Dim L2 As Long
    Dim U2 As Long
    Dim i As Long
    Dim j As Long
    
    Set myRange = ActiveCell.CurrentRegion
    A = myRange.value
    
    L = LBound(A)
    U = UBound(A)
    L2 = LBound(A, 2)
    U2 = UBound(A, 2)
    
    '２次元⇒１次元
    ReDim B(L To U)
    For i = L To U
        B(i) = A(i, 列)
    Next
    
    '並べ替えインデックスを得る
    Idx = MsCombSortI(B)
    
    '配列内で並べ替え
    ReDim C(L To U, L2 To U2)
    For i = L To U
        For j = L2 To U2
            C(i, j) = A(Idx(i), j)
        Next
    Next
    
    'セルに書き戻し
    myRange.value = C
    
    Set myRange = Nothing
End Sub


Public Function toUpperCase() As clsCollection
    Dim ret As New clsCollection
    Dim i As Integer
    For i = 1 To count
        ret.addItem (UCase(getItem(i)))
    Next
    Set toUpperCase = ret
End Function



Public Function toLowerCase() As clsCollection
    Dim ret As New clsCollection
    Dim i As Integer
    For i = 1 To count
        ret.addItem (LCase(getItem(i)))
    Next
    Set toLowerCase = ret
End Function

Public Function join(delimiter As String) As String
    Dim i As Integer
    Dim ret As String
    For i = 1 To count
        If i <> 1 Then
            ret = ret & delimiter
        End If
        ret = ret & getItem(i)
    Next
    join = ret
End Function

Public Function addWithKey(key As String, value As String)
    mCol.Add value, key
End Function

Public Sub prin()
    Dim i As Integer
    For i = 0 To count
        Debug.Print getItem(i)
    Next
End Sub


*clsColumn [#x6db0b3c]
Option Compare Database
Option Explicit

Public mColumn As ADOX.column

Const TYPE_adBigInt = "adBigInt"
Const TYPE_adBinary = "adBinary"
Const TYPE_adBoolean = "adBoolean"
Const TYPE_adBSTR = "adBSTR"
Const TYPE_adChapter = "adChapter"
Const TYPE_adChar = "adChar"
Const TYPE_adCurrency = "adCurrency"
Const TYPE_adDate = "adDate"
Const TYPE_adDBTime = "adDBTime"
Const TYPE_adDBTimeStamp = "adDBTimeStamp"
Const TYPE_adDecimal = "adDecimal"
Const TYPE_adDouble = "adDouble"
Const TYPE_adEmpty = "adEmpty"
Const TYPE_adError = "adError"
Const TYPE_adFileTime = "adFileTime"
Const TYPE_adGUID = "adGUID"
Const TYPE_adIDispatch = "adIDispatch"
Const TYPE_adInteger = "adInteger"
Const TYPE_adIUnknown = "adIUnknown"
Const TYPE_adLongVarBinary = "adLongVarBinary"
Const TYPE_adLongVarChar = "adLongVarChar"
Const TYPE_adLongVarWChar = "adLongVarWChar"
Const TYPE_adNumeric = "adNumeric"
Const TYPE_adPropVariant = "adPropVariant"
Const TYPE_adSingle = "adSingle"
Const TYPE_adSmallInt = "adSmallInt"
Const TYPE_adTinyInt = "adTinyInt"
Const TYPE_adUnsignedBigInt = "adUnsignedBigInt"
Const TYPE_adUnsignedInt = "adUnsignedInt"
Const TYPE_adUnsignedSmallInt = "adUnsignedSmallInt"
Const TYPE_adUnsignedTinyInt = "adUnsignedTinyInt"
Const TYPE_adUserDefined = "adUserDefined"
Const TYPE_adVarBinary = "adVarBinary"
Const TYPE_adVarChar = "adVarChar"
Const TYPE_adVariant = "adVariant"
Const TYPE_adVarNumeric = "adVarNumeric"
Const TYPE_adWChar = "adWChar"

Const DEFAULT_FORMAT = "@"

Public mDataType As String
Public mNullable As String

Public Function setColumn(column As ADOX.column) As column
    Set mColumn = column
    
End Function

Public Function getTypeName() As String

    Select Case mColumn.Type
        Case adBigInt
            getTypeName = TYPE_adBigInt
        Case adBinary
            getTypeName = TYPE_adBinary
        Case adBoolean
            getTypeName = TYPE_adBoolean
        Case adBSTR
            getTypeName = TYPE_adBSTR
        Case adChapter
            getTypeName = TYPE_adChapter
        Case adChar
            getTypeName = TYPE_adChar
        Case adCurrency
            getTypeName = TYPE_adCurrency
        Case adDate
            getTypeName = TYPE_adDate
        Case adDBTime
            getTypeName = TYPE_adDBTime
        Case adDBTimeStamp
            getTypeName = TYPE_adDBTimeStamp
        Case adDecimal
            getTypeName = TYPE_adDecimal
        Case adDouble
            getTypeName = TYPE_adDouble
        Case adEmpty
            getTypeName = TYPE_adEmpty
        Case adError
            getTypeName = TYPE_adError
        Case adFileTime
            getTypeName = TYPE_adFileTime
        Case adGUID
            getTypeName = TYPE_adGUID
        Case adIDispatch
            getTypeName = TYPE_adIDispatch
        Case adInteger
            getTypeName = TYPE_adInteger
        Case adIUnknown
            getTypeName = TYPE_adIUnknown
        Case adLongVarBinary
            getTypeName = TYPE_adLongVarBinary
        Case adLongVarChar
            getTypeName = TYPE_adLongVarChar
        Case adLongVarWChar
            getTypeName = TYPE_adLongVarWChar
        Case adNumeric
            getTypeName = TYPE_adNumeric
        Case adPropVariant
            getTypeName = TYPE_adPropVariant
        Case adSingle
            getTypeName = TYPE_adSingle
        Case adSmallInt
            getTypeName = TYPE_adSmallInt
        Case adTinyInt
            getTypeName = TYPE_adTinyInt
        Case adUnsignedBigInt
            getTypeName = TYPE_adUnsignedBigInt
        Case adUnsignedInt
            getTypeName = TYPE_adUnsignedInt
        Case adUnsignedSmallInt
            getTypeName = TYPE_adUnsignedSmallInt
        Case adUnsignedTinyInt
            getTypeName = TYPE_adUnsignedTinyInt
        Case adUserDefined
            getTypeName = TYPE_adUserDefined
        Case adVarBinary
            getTypeName = TYPE_adVarBinary
        Case adVarChar
            getTypeName = TYPE_adVarChar
        Case adVariant
            getTypeName = TYPE_adVariant
        Case adVarNumeric
            getTypeName = TYPE_adVarNumeric
        Case adWChar
            getTypeName = TYPE_adWChar
        Case Else
            p "error_at_getTypeName :" & mColumn.Type
    End Select
End Function


Public Function getNumberFormatLocal() As String
    Select Case mColumn.Type
        Case adBigInt
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adBinary
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adBoolean
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adBSTR
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adChapter
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adChar
            getNumberFormatLocal = "@"
        Case adCurrency
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adDate
            getNumberFormatLocal = "yyyy/m/d"
        Case adDBTime
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adDBTimeStamp
            If mDataType = "DATE" Then
                getNumberFormatLocal = "yyyy/m/d"
            Else
                getNumberFormatLocal = "yyyy/mm/dd hh:mm:ss.000"
            End If
        Case adDecimal
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adDouble
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adEmpty
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adError
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adFileTime
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adGUID
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adIDispatch
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adInteger
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adIUnknown
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adLongVarBinary
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adLongVarChar
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adLongVarWChar
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adNumeric
            If mColumn.NumericScale <> 0 Then
              getNumberFormatLocal = "0." & Left("0000000000000000000000000", mColumn.NumericScale) & "_ " '"0.000000_ "
            Else
              getNumberFormatLocal = "0_ "
            End If
        Case adPropVariant
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adSingle
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adSmallInt
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adTinyInt
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adUnsignedBigInt
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adUnsignedInt
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adUnsignedSmallInt
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adUnsignedTinyInt
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adUserDefined
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adVarBinary
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adVarChar
            getNumberFormatLocal = "@"
        Case adVariant
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adVarNumeric
            getNumberFormatLocal = DEFAULT_FORMAT
        Case adWChar
            getNumberFormatLocal = DEFAULT_FORMAT
        Case Else
            p "error_at_getNumberFormatLocal :" & mColumn.Type
    End Select
End Function


Sub p(message As String)
    Debug.Print message
End Sub

'ADOXで認識できなかった型を補う
Public Sub setDataType(datatype As String)
    mDataType = datatype
End Sub

'nullable
Public Sub setNullable(nullable As String)
    mNullable = nullable
End Sub

*clsColumnList [#vbfd177a]
Option Explicit

Public mCol As Collection
Public mTable As ADOX.table
Public mColFormat As Collection


'初期化
Public Sub setTable(table As ADOX.table)
    Set mTable = table
    
    Dim oracleColList As clsRecordset
    Dim oraclsColNameList As clsCollection
    
    Dim col As ADOX.column
    Dim cCol As clsColumn
    Dim i As Integer
    If TypeName(oracleColList) = "Nothing" Then
        For i = 0 To mTable.Columns.count - 1
            Set col = mTable.Columns.Item(i)
            Set cCol = New clsColumn
            cCol.setColumn col
            addItem cCol
        Next
    Else
        Set oraclsColNameList = oracleColList.getFieldList("COLUMN_NAME")
        'オラクルのカラム情報を元に列の順序をそろえる
        For i = 1 To oraclsColNameList.count
            Set col = mTable.Columns.Item(oraclsColNameList.getItem(i))
            Set cCol = New clsColumn
            cCol.setColumn col
            addItem cCol
        Next
    End If
 
    On Error GoTo notOracle
    Dim cRecordset As clsRecordset
    Set cRecordset = getOracleColumnInfoRecordset(mTable)
    
    'ADOXで取得したカラム一覧情報にさらに詳しい情報を付加します。

    Do Until cRecordset.mRecordset.EOF
         Set cCol = getItem(cRecordset.mRecordset!COLUMN_NAME)
         cCol.setDataType cRecordset.mRecordset!DATA_TYPE
         cCol.setNullable cRecordset.mRecordset!nullable
         
         cRecordset.mRecordset.MoveNext
    Loop
    On Error GoTo 0
    
    Exit Sub
notOracle:

End Sub

Private Function getOracleColumnInfoRecordset(table As ADOX.table) As clsRecordset
    On Error GoTo notOracle
    'スキーマ取得用 ADOXではOracleのTIMESTAMPもDATEも区別していなかったためスキーマ取得クエリーを発行する。
    Dim strSchema As String
    strSchema = "SELECT C.* FROM USER_TAB_COLUMNS C WHERE C.TABLE_NAME = '$TABLENAME$'"
    strSchema = Replace(strSchema, "$TABLENAME$", table.name)
    
    '検索処理
    Dim con As Connection
    Set con = table.ParentCatalog.ActiveConnection
    Dim rs As recordset
    Set rs = con.execute(strSchema)
    Dim cRecordset As clsRecordset
    Set cRecordset = New clsRecordset
    cRecordset.setRecordset rs
    Set getOracleColumnInfoRecordset = cRecordset
    
    Exit Function
notOracle:
    Set getOracleColumnInfoRecordset = Nothing
End Function




Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub


Public Function count() As Long
    count = mCol.count
End Function


Public Sub addItem(column As clsColumn)
    If Not isExist(column.mColumn.name) Then
        mCol.Add column, column.mColumn.name
    End If
End Sub


Public Function getItem(index As Variant) As clsColumn
    Set getItem = mCol.Item(index)
End Function


Public Function isExist(name As String) As Boolean
    On Error GoTo notExist
    Dim dummy As clsColumn
    Set dummy = getItem(name)
    isExist = True
    Exit Function
notExist:
    isExist = False
End Function

Public Function getNameList() As clsCollection
    Dim ret As clsCollection
    Set ret = New clsCollection
    Dim i As Integer
    For i = 1 To count
        ret.mCol.Add getItem(i).mColumn.name
    Next
    Set getNameList = ret
End Function

Public Function getTimeStampColumnList() As clsColumnList
    Dim ret As clsColumnList
    Set ret = New clsColumnList
    
    Dim i As Integer
    For i = 1 To count
        If InStr(1, getItem(i).mDataType, "TIMESTAMP") <> 0 Then
            ret.addItem getItem(i)
        End If
    Next
    
    Set getTimeStampColumnList = ret
End Function

*clsConnection [#l3a7b91f]
Option Explicit

'クラスの説明
' 自動クローズコネクションクラス

Const MDB_CONNECT = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
Const ORA_CONNECT = "Provider=MSDAORA;Data Source="

Public adoCON As Connection
Public cat  As New Catalog

Public Sub setDSN(strDSN As String)
    'On Error GoTo show_error
    'ADOを使いデータソースをオープンします
    adoCON.Open strDSN '"DSN=TKOTRIP2_DAO; UID=TKOTRIP2_DAO; PWD=TKOTRIP2_DAO;"
    cat.ActiveConnection = adoCON
    
    p "DBをオープン:" & strDSN
    Exit Sub
show_error:
    p strDSN
    MsgBox "DSNが存在していないかUIDが存在していません"
    End
End Sub

Sub p(message As String)
    Debug.Print message
End Sub

Private Sub Class_Initialize()
    Set adoCON = New Connection
End Sub

Private Sub Class_Terminate()
    On Error GoTo close_error
    adoCON.Close
    'データベースの自動クローズ
    p "DBをClose:" & adoCON.ConnectionString
    Exit Sub
close_error:
    p "コネクションは閉じられていました。"
End Sub

Public Function getTableList() As clsTableList
    Dim ret As clsTableList
    Set ret = New clsTableList
    ret.setConnection adoCON, cat
    
    Set getTableList = ret
End Function

Public Sub setConnection(con As Connection)
    Set adoCON = con
    cat.ActiveConnection = con
End Sub

Public Sub openMDB(Optional strFileName As String = "")
   If strFileName <> "" And strFileName <> CurrentProject.path & "\" & CurrentProject.name Then
         Dim dbCon As ADODB.Connection
         Set dbCon = New ADODB.Connection
         dbCon.Open MDB_CONNECT & strFileName
         Set adoCON = dbCon
    Else
        Set adoCON = CurrentProject.Connection
    End If
    cat.ActiveConnection = adoCON
End Sub

Public Sub OpenOracle(strServerName As String, strUID As String, strPWD As String)
   
    Dim dbCon As ADODB.Connection
    Set dbCon = New ADODB.Connection
    dbCon.Open ORA_CONNECT & strServerName & ";User ID=" & strUID & "; Password=" & strPWD & ";"

    Set adoCON = dbCon
    
    cat.ActiveConnection = adoCON
End Sub

Public Function getUserTableList() As clsCollection
    Dim cRecordset As New clsRecordset
    Set cRecordset = execute("SELECT * FROM USER_TABLES")
    Set getUserTableList = cRecordset.getList("TABLE_NAME")
End Function

Public Function execute(strSQL As String) As clsRecordset
    Dim ret As New clsRecordset
    Dim rs As recordset
    Set rs = adoCON.execute(strSQL)
    ret.setRecordset rs
    Set execute = ret
End Function

'mdbに格納してあるテーブルにPKの情報を追加する。
Public Function addPKToMDB(tablename As String, savename As String)
    
    
    Dim cDB As clsDB
    Set cDB = New clsDB
    cDB.OpenDB
    
    Dim cTable As clsTable
    Set cTable = cDB.getTableList.getItem(savename)
    
    'PK追加
    Dim cPKList As clsColumnList
    Set cPKList = getTableList.getItem(tablename).getPKColumns
    cTable.addPK cPKList
    
    'レコードセット追加
    Dim cConstraintList As clsRecordset
    Set cConstraintList = getTableList.getItem(tablename).getConstraintColumnRecordset
    cTable.addConstraint cConstraintList
    
    
End Function

*clsDB [#t3d15c78]
Option Compare Database
Option Explicit

Public mDB As database
Public mConnection As clsConnection

Public Sub setDB(database As database)
    Set mDB = database
End Sub


Private Sub Class_Terminate()
    On Error Resume Next
    mDB.Close
    Set mDB = Nothing
End Sub

'データベースを開く
Public Sub OpenDB(Optional name As String = "")
    If name = "" Then
        name = CurrentDb.name
        
        Set mConnection = New clsConnection
        mConnection.setConnection CurrentProject.Connection
        Set mDB = CurrentDb
            
    Else
        Set mDB = OpenDatabase(name)
    End If

End Sub


'コネクションクラスを返します。
Public Function getConnection() As clsConnection
    If TypeName(mConnection) = "Nothing" Then
        Set mConnection = New clsConnection
        On Error GoTo con_err
        mConnection.setConnection mDB.Connection
        On Error GoTo 0
    ElseIf IsNull(mConnection.cat) Then
        Set mConnection = New clsConnection
        mConnection.setConnection mDB.Connection
    End If
    On Error Resume Next
    mConnection.adoCON.BeginTrans
    On Error Resume Next
    mConnection.adoCON.RollbackTrans
    
    On Error GoTo 0
    Set getConnection = mConnection
    Exit Function
con_err:
    Debug.Print "コネクションエラー"
End Function

Public Function CreateTableDef(name As String) As clsTableDef
    Dim cTabledef As clsTableDef
    Set cTabledef = New clsTableDef
    cTabledef.setTableDef mDB.CreateTableDef(name), mDB
    
    Set CreateTableDef = cTabledef
End Function

Public Function getTableList() As clsTableList
    Set getTableList = getConnection.getTableList
End Function


Public Function isExistTable(name As String) As Boolean
    isExistTable = getTableList.isExist(name)
End Function

Public Sub dropTable(name As String)
    getConnection.cat.Tables.Delete name
End Sub

*clsDSN [#c4c7861e]
Option Compare Database
Option Explicit

Private Const ODBC_ADD_SYS_DSN = 4       'Add data source
Private Const ODBC_CONFIG_SYS_DSN = 5    'Configure (edit) data source
Private Const ODBC_REMOVE_SYS_DSN = 6    'Remove data source

Private Const vbAPINull As Long = 0& ' NULL Pointer

Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal _
   hwndParent As Long, ByVal fRequest As Long, ByVal _
   lpszDriver As String, ByVal lpszAttributes As String) As Long
                    

'Function Build_SystemDSN(DSN_NAME As String, Db_Path As String)
'
'   Dim ret%, Driver$, Attributes$
'
'   Driver = "Microsoft Access Driver (*.MDB)" & Chr(0)
'   Attributes = "DSN=" & DSN_NAME & Chr(0)
'   Attributes = Attributes & "Uid=Admin" & Chr(0) & "pwd=" & Chr(0)
'   Attributes = Attributes & "DBQ=" & Db_Path & Chr(0)
'
'   ret = SQLConfigDataSource(0, ODBC_ADD_SYS_DSN, Driver, Attributes)
'
'
'   'ret is equal to 1 on success and 0 if there is an error
'   If ret <> 1 Then
'       MsgBox "DSN Creation Failed"
'   End If
'
'End Function

'使用例
'イミディエイト ウィンドウに次の行を入力し Enter キーを押します。
'Print Build_SystemDSN("My SampleDSN", "c:\Northwind.mdb")



Public Sub addOracleDSN(strDSName As String, strUID As String, strPWD As String, strServerName As String)
    
'    strDriver = "Oracle ODBC Driver"
'    'DSN文字列
'    strDSN = "DSN=dsn_name" & vbNullChar
'    strDSN = strDSN & "Description=TEST" & vbNullChar
'    strDSN = strDSN & "UserID=user_name" & vbNullChar
'    strDSN = strDSN & "ServerName=service_name" & vbNullChar & vbNullChar
    
    Dim lngRequest As Long
    Dim strDriver As String                 'ドライバ名
    'Dim strDSN As String                    'DSN文字列
    
    'ドライバ名 ドライバ名が正しくない場合は自分で設定してみてください。
    strDriver = "Oracle in OraClient10g_home1"
    
    'DSN文字列
    Dim cDSN As New clsCollection
    'cDSN.addItem "DRIVER=Oracle in OraClient10g_home1"
    'cDSN.addItem "uid = " & strUID
    'cDSN.addItem "TLO = O"
    'cDSN.addItem "FBS = 60000"
    'cDSN.addItem "FWC = F"
    'cDSN.addItem "CSR = F"
    'cDSN.addItem "MDI = Me"
    'cDSN.addItem "MTS = T"
    'cDSN.addItem "DPM = F"
    'cDSN.addItem "NUM = NLS"
    'cDSN.addItem "BAM = IfAllSuccessful"
    'cDSN.addItem "BTD = F"
    'cDSN.addItem "rst = T"
    'cDSN.addItem "LOB = T"
    'cDSN.addItem "FDL = 10"
    'cDSN.addItem "FRC = 10"
    'cDSN.addItem "QTO = T"
    'cDSN.addItem "FEN = T"
    'cDSN.addItem "XSM = Default"
    'cDSN.addItem "EXC = F"
    'cDSN.addItem "APA = T"
    'cDSN.addItem "DBA = W"
    'cDSN.addItem "DBQ = " & strPWD
    'cDSN.addItem "SERVER = " & strServerName
    
    cDSN.addItem "DSN=" & strDSName
    cDSN.addItem "PWD=" & strPWD
    cDSN.addItem "Server=" & strServerName
    cDSN.addItem "UID=" & strUID
    cDSN.addItem "DESCRIPTION=AUTO_GENERATED"
    
    'cDSN.addItem "DSN=TKOTRIP2" ' & strDSN
    'cDSN.addItem "PWD=TKOTRIP2" ' & strPWD
    'cDSN.addItem "Server=TKOTRIP2" ' & strServerName
    'cDSN.addItem "UID=TKOTRIP2" ' & strUID
    'cDSN.addItem "DESCRIPTION=GEN"
    
    'cDSN.addItem "DATABASE=TKOTRIP2"
    cDSN.addItem ""
    
    lngRequest = SQLConfigDataSource(vbAPINull, ODBC_ADD_SYS_DSN, strDriver, cDSN.join(vbNullChar))
    
    'If lngRequest = 0 Then
    '    MsgBox "ODBCの登録に失敗しました！", vbCritical, "ODBC登録エラー"
    'End If

End Sub

*clsExcel [#s9c32d58]
Option Compare Database

Public xls As Excel.Application

Private Sub Class_Initialize()
    Set xls = New Excel.Application
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    xls.Quit
    Set xls = Nothing
End Sub

*clsField [#l7d1ad0c]
Option Compare Database
Option Explicit

Public mField As field

Public name As String

Public AllowZeroLength As Boolean


Public Sub setField(fld As field)
    Set mField = fld
    name = fld.name
End Sub

'DAOフィールドにパラメータを追加
Public Function cloneParam(fld As DAO.field) As DAO.field
    'fld.AllowZeroLength
    fld.DefaultValue = mField.OriginalValue
'    fld.Size = mField.DefinedSize
'    fld.Attributes = mField.Attributes
'    fld.DataFormat = mField.DataFormat
'    fld.DefinedSize = mField.DefinedSize
'    fld.name = mField.name
'    fld.NumericScale = mField.NumericScale
'    fld.OriginalValue = mField.OriginalValue
'    fld.Precision = mField.Precision
'    fld.Properties = mField.Properties
'    fld.Status = mField.Status
'    fld.Type = mField.Type
'    fld.UnderlyingValue = mField.UnderlyingValue
'    fld.Value = mField.Value
    Set cloneParam = fld
    
End Function


'オラクルの検索結果などをアクセスに格納できる型に変換
Public Function getMDBType()
    '参考:http://www.ruriplus.com/msaccess/Exp/exp0142.htm
    'dbText 'テキスト型
    'dbMemo 'メモ型
    'dbByte 'バイト型
    'dbInteger '整数型
    'dbLong '長整数型
    'dbSingle '単精度浮動小数点型
    'dbDouble '倍精度浮動小数点型
    'dbDate '日付/時刻型
    'dbCurrency '通貨型
    'dbLong 'Attributes : dbAutoIncrField 'オートナンバー型
    'dbBoolean 'Yes/No型
    'dbLongBinary 'OLE オブジェクト型
    'dbMemo 'Attributes : dbHyperLink 'ハイパーリンク型
    
    Select Case mField.Type
        Case adBigInt
            getMDBType = dbLong
        Case adBinary
            getMDBType = dbLongBinary
        Case adBoolean
            getMDBType = dbBoolean
        Case adBSTR
            getMDBType = dbMemo
        Case adChapter
            getMDBType = dbMemo
        Case adChar
            getMDBType = dbText
        Case adCurrency
            getMDBType = dbCurrency
        Case adDate
            getMDBType = dbDate
        Case adDBTime
            getMDBType = dbDate
        Case adDBTimeStamp
            getMDBType = dbDate
        Case adDecimal
            getMDBType = dbCurrency
        Case adDouble
            getMDBType = dbDouble
        Case adEmpty
            getMDBType = dbMemo
        Case adError
            getMDBType = dbMemo
        Case adFileTime
            getMDBType = dbDate
        Case adGUID
            getMDBType = dbMemo
        Case adIDispatch
            getMDBType = dbMemo
        Case adInteger
            getMDBType = dbInteger
        Case adIUnknown
            getMDBType = dbMemo
        Case adLongVarBinary
            getMDBType = dbLongBinary
        Case adLongVarChar
            getMDBType = dbMemo
        Case adLongVarWChar
            getMDBType = dbMemo
        Case adNumeric
            getMDBType = dbDouble
        Case adPropVariant
            getMDBType = dbMemo
        Case adSingle
            getMDBType = dbSingle
        Case adSmallInt
            getMDBType = dbInteger
        Case adTinyInt
            getMDBType = dbInteger
        Case adUnsignedBigInt
            getMDBType = dbLong
        Case adUnsignedInt
            getMDBType = dbLong
        Case adUnsignedSmallInt
            getMDBType = dbLong
        Case adUnsignedTinyInt
            getMDBType = dbLong
        Case adUserDefined
            getMDBType = dbMemo
        Case adVarBinary
            getMDBType = dbLongBinary
        Case adVarChar
            getMDBType = dbMemo
        Case adVariant
            getMDBType = dbMemo
        Case adVarNumeric
            getMDBType = dbMemo
        Case adWChar
            getMDBType = dbMemo
        Case Else
            getMDBType = mField.Type
    End Select
End Function


Private Sub Class_Initialize()
    AllowZeroLength = True
End Sub

*clsFieldList [#t5d1f71a]
Option Compare Database
Option Explicit

Public mCol As Collection


Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub



Public Sub addItem(cField As clsField)
    mCol.Add cField, cField.name
End Sub


Public Function count() As Integer
    count = mCol.count
End Function


Public Function getItem(index As Variant) As clsField
   Set getItem = mCol.Item(index)
End Function

*clsLog [#g46ded57]
Option Compare Database

Option Explicit

Public fso As New FileSystemObject
Public st As TextStream
Public history As New clsCollection

Public Sub openLogFile(strLogFilePath As String)
    If fso.FileExists(strLogFilePath) Then
        Set st = fso.OpenTextFile(strLogFilePath, ForAppending)
    Else
        Set st = fso.CreateTextFile(strLogFilePath, True)
    End If
End Sub

Public Sub log(message As String)
    Dim strMessage As String
    If UBound(Split(message)) > 0 Then
        strMessage = Now & ":" & vbCrLf & message
        st.WriteLine Now & ":" & vbCrLf & message
        p strMessage
        history.addItem message
    Else
        strMessage = Now & ":" & message
        st.WriteLine Now & ":" & message
        p strMessage
        history.addItem message
    End If
End Sub


Public Sub p(message As Variant)
    Debug.Print message
End Sub

Public Function msgboxWithLog(Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String = "snapSchema") As VbMsgBoxResult
    log Replace(Prompt, Chr(10), vbCrLf)
    msgboxWithLog = MsgBox(Prompt, Buttons, Title)
End Function

Private Sub Class_Initialize()

End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    st.Close
End Sub

*clsRecordset [#ue3ca92f]
Option Explicit

Public mRecordset As New recordset

Public mNotNullSetting As New clsCollection

Public Sub setRecordset(recordset As recordset)
    Set mRecordset = recordset
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    mRecordset.Close
    Set mRecordset = Nothing
End Sub

'レコードセットの中身をDBに保存する
Public Sub createTable(tablename As String, Optional dbname As String = "")
    'DBをオープン
    Dim cDB As clsDB
    Set cDB = New clsDB
    cDB.OpenDB dbname
    
    'TableDefの作成
    Dim cTabledef As clsTableDef
    Set cTabledef = cDB.CreateTableDef(tablename)
    
    'フィールドを追加
    cTabledef.addFieldByFieldList getFieldList

    '反映
    cTabledef.Refresh
End Sub

Public Function getFieldList() As clsFieldList
    Dim ret As clsFieldList
    Set ret = New clsFieldList
    
    Dim i As Integer
    Dim newField As clsField
    For i = 0 To mRecordset.Fields.count - 1
        Set newField = New clsField
        newField.setField mRecordset.Fields.Item(i)
        If mNotNullSetting.isExist(mRecordset.Fields.Item(i).name) Then
            newField.AllowZeroLength = False
        End If
        ret.addItem newField
    Next
    Set getFieldList = ret
End Function

'savetablename保存先のテーブル名
Public Sub save(savetablename As String, Optional notNullList As clsCollection = Nothing)
    If TypeName(notNullList) = "Nothing" Then
        Set notNullList = New clsCollection
    End If


    'テーブル作成準備
    Dim conMDB As clsConnection
    Set conMDB = New clsConnection
    conMDB.openMDB

    'すでに存在していればドロップ
    Dim tableListMDB As clsTableList
    Set tableListMDB = conMDB.getTableList
    tableListMDB.drop savetablename
    
    '再度テーブル一覧を取得
    Dim con As clsConnection
    Set con = New clsConnection
    con.openMDB
    Set tableListMDB = con.getTableList
    
    Dim cRecordset As New clsRecordset
    cRecordset.setRecordset mRecordset
    
    'NotNull格納
    Set cRecordset.mNotNullSetting = notNullList
    
    
    'レコード元にテーブルが作成される
    tableListMDB.setDataByRecordset savetablename, cRecordset
    
    
End Sub


'カラム定義の情報を元にオラクル側のテーブルに保存します。
Public Sub saveToOracle(cCon As clsConnection, strTablename As String, log As clsLog)
    'mdbのレコードセットの情報
    Dim cFieldList As clsFieldList
    Set cFieldList = getFieldList

    '-----Oracle側の情報収集
    Dim cTableList As clsTableList
    Set cTableList = cCon.getTableList
    
    Dim cTable As clsTable
    Set cTable = cTableList.getItem(strTablename)

    Dim cColumnList As clsColumnList
    Set cColumnList = cTable.getColumnList

    
    Dim rst As New clsRecordset
    
    On Error Resume Next
    cCon.adoCON.BeginTrans
    rst.mRecordset.Open "select * from " & strTablename, cCon.adoCON, adOpenDynamic, adLockOptimistic, adCmdText

    Dim cAndList As clsCollection
    Set cAndList = cColumnList.getNameList.toUpperCase.matchAnd(rst.getFieldNameList.toUpperCase).matchAnd(getFieldNameList.toUpperCase)
    
    
    Dim i As Integer
    Dim strDate As String
    Dim colName As String
    On Error GoTo error_handle
    Dim counter As Long
    counter = 0
    
    If cAndList.count <> 0 Then
    
    
        Do Until mRecordset.EOF
            counter = counter + 1
            DoEvents
            rst.mRecordset.AddNew
            For i = 1 To cAndList.count
                colName = cAndList.getItem(i)
                
                On Error GoTo no_fieldname
                '一致するフィールドがあるかどうか見る。
                If rst.mRecordset.Fields(colName).Type = adDBTimeStamp And mRecordset.Fields(colName).Type = adLongVarWChar Then
                    On Error GoTo error_handle
                    '文字列→タイムスタンプパターン
                    strDate = mRecordset.Fields(colName).value
                    'とりあえずミリ秒を丸めて格納し、後ほどSQLで再度入れる
                    rst.mRecordset.Fields(colName).value = CDate(Left(strDate, 19))
                Else
                    '通常のフィールド代入
                    'If colName = "AAAA" Then Stop
                    On Error GoTo error_handle
                    rst.mRecordset.Fields(colName).value = mRecordset.Fields(colName).value
                End If
                
            
            Next
            rst.mRecordset.Update
            mRecordset.MoveNext
        Loop
         cCon.adoCON.CommitTrans
    Else
         cCon.adoCON.RollbackTrans
    End If
    
   
    Exit Sub
error_handle:
    If (IsNull(mRecordset.Fields(colName).value)) Then
        log.msgboxWithLog "　テーブル名:" & strTablename & Chr(10) & "  カラム名:" & colName & Chr(10) & _
            "  値:" & mRecordset.Fields(colName).value & Chr(10) & _
            "　行番号:" & counter & Chr(10) & _
            "データを見直してください。" & Chr(10) & _
            "非NULL項目にNULLを格納しようとしていないかどうか確認をお願いします。:" & Chr(10) & _
            "　テーブル名:" & strTablename & Chr(10) & _
            "  カラム名:" & colName & Chr(10) & _
            "  ErrorDescription:" & Err.Description _
            , vbCritical, "Access⇒Oracle 変換中にエラー: "
        
    Else
        log.msgboxWithLog "　テーブル名:" & strTablename & Chr(10) & "  カラム名:" & colName & Chr(10) & _
            "  値:" & mRecordset.Fields(colName).value & Chr(10) & _
            "　行番号:" & counter, vbCritical, "Access⇒Oracle 変換中にエラー: " & Chr(10) & _
            "  ErrorDescription:" & Err.Description & _
            "データを見直してください。"
    End If
        
    cCon.adoCON.RollbackTrans
    Dim yesno As Long
    yesno = MsgBox("テーブル:" & strTablename & "の処理をスキップしますか。" & Chr(10) & _
        "  ErrorDescription:" & Err.Description & Chr(10) & _
        "[再試行] -> デバックモードにした後エラー表示を行い再試行可能にする" & Chr(10) & _
        "[中止] -> デバック状態にして停止しますので、コードの解析が必要ない場合は終了してください。" & Chr(10) & _
        "[無視] -> このテーブルについてなにもしない (次のテーブルの処理があれば、次のテーブルを処理する)", vbAbortRetryIgnore)
    If yesno = vbRetry Then
        Stop
        Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    ElseIf yesno = vbIgnore Then
        Exit Sub
    ElseIf yesno = vbAbort Then
        Stop
    End If
    Exit Sub
no_fieldname:
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Public Function getFieldNameList() As Object
    Dim res As New clsCollection
    Dim fld As field
    For Each fld In mRecordset.Fields
        res.addItem fld.name
    Next
    Set getFieldNameList = res
End Function


Private Function hasField(rs1 As recordset, name As String) As Boolean
    On Error GoTo HaveNot
    Dim dummy As String
    
    dummy = rs1.Fields(name).name
    hasField = True
    Exit Function
HaveNot:
    hasField = False
End Function

Private Sub p(message As String)
    Debug.Print message
End Sub


'タイムスタンプのミリ秒形式でADOを使って格納できなかったため、カラム定義の情報を元にオラクル側のテーブルに保存します。
Public Sub saveToOracleTimeStamp(cCon As clsConnection, strTablename As String, log As clsLog)
    'mdbのレコードセットの情報
    Dim cFieldList As clsFieldList
    Set cFieldList = getFieldList

    '-----Oracle側の情報収集
    Dim cTableList As clsTableList
    Set cTableList = cCon.getTableList
    
    Dim cTable As clsTable
    Set cTable = cTableList.getItem(strTablename)

    Dim cColumnList As clsColumnList
    Set cColumnList = cTable.getColumnList
    
    'オラクルのカラムリストよりタイムスタンプのカラムを抽出
    Dim cTimeStampColumnList As clsColumnList
    Set cTimeStampColumnList = cColumnList.getTimeStampColumnList
    
    'タイムスタンプがない場合は何もしない
    If cTimeStampColumnList.count = 0 Then Exit Sub
    
    
    '主キーを抽出
    Dim cPKColumnList As clsColumnList
    Set cPKColumnList = cTable.getPKColumns
    
    'プライマリキーがない場合は何もしない
    If cPKColumnList.count = 0 Then Exit Sub
    
    
    Dim i As Integer
    Dim j As Integer
    Dim strSQL As String
    
    cCon.adoCON.BeginTrans
    Do Until mRecordset.EOF
        DoEvents
        'SQL代入文を生成
        strSQL = "UPDATE " & strTablename & " SET "
        
        For i = 1 To cTimeStampColumnList.count
            If i <> 1 Then
                strSQL = strSQL + ","
            End If
            
            strSQL = strSQL & cTimeStampColumnList.getItem(i).mColumn.name & "='" & mRecordset.Fields(cTimeStampColumnList.getItem(i).mColumn.name).value & "'"
        Next
        
        strSQL = strSQL + " WHERE "
        
        'プライマリキーで絞り込む
        For i = 1 To cPKColumnList.count
            If i <> 1 Then
                strSQL = strSQL + " AND "
            End If
            
            strSQL = strSQL & cPKColumnList.getItem(i).mColumn.name & "='" & mRecordset.Fields(cPKColumnList.getItem(i).mColumn.name).value & "'"
        Next
        
        'SQL実行
        cCon.adoCON.execute strSQL
        mRecordset.MoveNext
    Loop
    cCon.adoCON.CommitTrans
End Sub


Function getList(colName As String) As clsCollection
    Dim ret As New clsCollection
    mRecordset.MoveFirst
    Do Until mRecordset.EOF
        DoEvents
        ret.addItem mRecordset.Fields(colName).value
        
        mRecordset.MoveNext
    Loop
    Set getList = ret
End Function


*clsTable [#qc50cc58]
Option Explicit

Public mTable As ADOX.table
Public name As String

Public Sub setTable(table As ADOX.table)
    Set mTable = table
    name = Trim(table.name)
End Sub

Public Function getColumnList() As clsColumnList
    Dim ret As clsColumnList
    Set ret = New clsColumnList
    ret.setTable mTable
    Set getColumnList = ret
End Function



Public Sub p(message As Variant)
    Debug.Print message
End Sub

Public Function getColumnScheme() As clsRecordset
    'スキーマ取得用 ADOXではOracleのTIMESTAMPもDATEも区別していなかったためスキーマ取得クエリーを発行する。
    Dim strSchema As String
    strSchema = "SELECT C.* FROM USER_TAB_COLUMNS C WHERE C.TABLE_NAME = '$TABLENAME$'"
    strSchema = Replace(strSchema, "$TABLENAME$", name)
    
    '検索処理
    Dim con As Connection
    Set con = mTable.ParentCatalog.ActiveConnection
    Dim rs As recordset
    Set rs = con.execute(strSchema)
    Dim cRecordset As clsRecordset
    Set cRecordset = New clsRecordset
    cRecordset.setRecordset rs
    Set getColumnScheme = cRecordset
End Function


'
Public Function getPKColumnRecordset() As clsRecordset
    Dim ret As clsRecordset
    Set ret = New clsRecordset
    
    Dim strSchema As String
    strSchema = "SELECT B.CONSTRAINT_NAME,A.INDEX_NAME,A.COLUMN_NAME " & _
                " FROM USER_IND_COLUMNS A,USER_CONSTRAINTS B" & _
                " WHERE A.INDEX_NAME = B.INDEX_NAME" & _
                " AND CONSTRAINT_TYPE='P'" & _
                " AND A.TABLE_NAME = '$TABLENAME$'" & _
                " ORDER BY B.CONSTRAINT_NAME,A.INDEX_NAME,A.COLUMN_POSITION;"
    
    
    strSchema = Replace(strSchema, "$TABLENAME$", name)
    
    '検索処理
    Dim con As Connection
    Set con = mTable.ParentCatalog.ActiveConnection
    Dim rs As recordset
    Set rs = con.execute(strSchema)
    
    ret.setRecordset rs
    Set getPKColumnRecordset = ret

End Function


Public Function getConstraintColumnRecordset() As clsRecordset
    Dim ret As clsRecordset
    Set ret = New clsRecordset
    
    Dim strSchema As String
    strSchema = "SELECT" & _
                "     A.COLUMN_NAME AS NAME , B.SEARCH_CONDITION AS COND " & _
                " FROM " & _
                "     USER_CONSTRAINTS B,USER_CONS_COLUMNS A " & _
                " WHERE " & _
                "     B.TABLE_NAME = '$TABLENAME$' " & _
                " AND " & _
                "     B.CONSTRAINT_NAME = A.CONSTRAINT_NAME " & _
                " AND " & _
                "     B.CONSTRAINT_TYPE = 'C'" & _
                " ORDER BY" & _
                "     A.COLUMN_NAME;"
    
    
    strSchema = Replace(strSchema, "$TABLENAME$", name)
    
    '検索処理
    Dim con As Connection
    Set con = mTable.ParentCatalog.ActiveConnection
    Dim rs As recordset
    Set rs = con.execute(strSchema)
    
    ret.setRecordset rs
    Set getConstraintColumnRecordset = ret

End Function



Public Sub drop()
    mTable.ParentCatalog.Tables.Delete mTable.name
End Sub


Public Sub setDataByRecordset(rs As clsRecordset)

    

    
    Dim rst As DAO.recordset
    Dim db As clsDB
    Set db = New clsDB
    db.OpenDB
    
    Dim cColumnNameList As clsCollection
    Set cColumnNameList = getColumnList.getNameList
    
    Set rst = db.mDB.OpenRecordset(name, dbOpenTable, dbAppendOnly)
    Dim i As Integer
    Dim strFieldName As String
    Do Until rs.mRecordset.EOF
        DoEvents
        rst.AddNew
        For i = 1 To cColumnNameList.count
            strFieldName = cColumnNameList.getStringItem(i)
            rst.Fields(strFieldName).value = rs.mRecordset.Fields(strFieldName).value
        Next
        rst.Update
        rs.mRecordset.MoveNext
    Loop
    rst.Close
End Sub

'全件取得
Public Function toRecordset() As clsRecordset
    Dim con As Connection
    Set con = mTable.ParentCatalog.ActiveConnection
    
    Dim rs As recordset
    Set rs = con.execute(getSQLAllSelect & mTable.name)
    
    Dim ret As clsRecordset
    Set ret = New clsRecordset
    ret.setRecordset rs
    
    Set toRecordset = ret
End Function

Public Function getSQLAllSelect() As String
    Dim ret As String
    
    On Error GoTo mdbSQL
    
    'タイムスタンプ型をもっていないかどうか確認する。
    Dim cRecordset As clsRecordset
    Set cRecordset = getColumnScheme
    
    On Error GoTo 0
    
    Dim cFieldList As Fields
    
    Dim i As Integer
    ret = "SELECT "
    i = 1
    Do Until cRecordset.mRecordset.EOF
        DoEvents
        
        If i <> 1 Then
            ret = ret & ","
        End If
        
        Set cFieldList = cRecordset.mRecordset.Fields
        If InStr(1, cFieldList.Item("DATA_TYPE").value, "TIMESTAMP") = 0 Then
            ret = ret & cFieldList.Item("COLUMN_NAME").value
        Else
            ret = ret & "TO_CHAR(" & cFieldList.Item("COLUMN_NAME").value & ",'YYYY/MM/DD HH24:MI:SS.FF') AS " & cFieldList.Item("COLUMN_NAME").value
        End If
            
    
        i = i + 1
        cRecordset.mRecordset.MoveNext
    Loop
    
    getSQLAllSelect = ret & " FROM "
    
    Exit Function
    
mdbSQL:
    ret = "SELECT * FROM "
    getSQLAllSelect = ret
End Function



Public Function getPKColumns() As clsColumnList
    Dim ret As New clsColumnList
    
    Dim cPKList As clsRecordset
    Set cPKList = getPKColumnRecordset
    
    Dim cColList As clsColumnList
    Set cColList = getColumnList
    
    Do Until cPKList.mRecordset.EOF
        ret.addItem cColList.getItem(cPKList.mRecordset.Fields("COLUMN_NAME").value)
        
        cPKList.mRecordset.MoveNext
    Loop
    
    Set getPKColumns = ret
End Function

Public Function addPK(pkList As clsColumnList)
    '検索処理
    If pkList.count <> 0 Then
        Dim con As Connection
        Set con = mTable.ParentCatalog.ActiveConnection
        
        con.execute "ALTER TABLE " + name + " ADD CONSTRAINT PrimaryKey PRIMARY KEY (" + pkList.getNameList.join(",") + ");"
    End If
End Function


Public Function addConstraint(constraintList As clsRecordset)
    '検索処理
    Dim con As Connection
    Set con = mTable.ParentCatalog.ActiveConnection
    
    Dim strCond As String
    Dim strName As String
    
    Do Until constraintList.mRecordset.EOF
        DoEvents
        strName = constraintList.mRecordset.Fields(0)
        strCond = constraintList.mRecordset.Fields(1)
        
        If InStr(1, strCond, "NOT NULL") <> 0 Then
            'con.execute "ALTER TABLE " & name & " ALTER COLUMN " & strName & " " & getColType(strName) & " NOT NULL;"
        End If
        constraintList.mRecordset.MoveNext
    Loop
    
'    Dim i As Integer
'    Dim ColumnsNameList As clsCollection
'    Set ColumnsNameList = constraintList.getFieldNameList("COLUMN_NAME")
'
'    Dim constraintTypeList As clsCollection
'    Set constraintTypeList = constraintList.getFieldNameList("SEARCH_CONDITION")
'
'
'    For i = 1 To ColumnsNameList.count
'        If InStr(1, constraintTypeList.getItem(i), "NOT NULL") Then
'            con.execute "ALTER TABLE " + name + " ADD CONSTRAINT NOT NULL (" + ColumnsNameList.getItem(i) + ");"
'        End If
'    Next

End Function



Public Function getNotNullList() As clsCollection
    
    Dim ret As New clsCollection
    Dim rs As clsRecordset
    Set rs = getConstraintColumnRecordset
    
    rs.mRecordset.MoveFirst
    Do Until rs.mRecordset.EOF
        DoEvents
        p rs.mRecordset.Fields(0)
        'p rs.mRecordset.Fields(1)
        
        'If InStr(1, castNull(rs.mRecordset.Fields("COND")), "NOT NULL") <> 0 Then
            ret.addWithKey rs.mRecordset.Fields("Name"), "TRUE"
        'End If
        rs.mRecordset.MoveNext
    Loop
    Set getNotNullList = ret
End Function

Private Function castNull(value As Variant) As String
    If IsNull(value) Then
        castNull = ""
    Else
        castNull = CStr(value)
    End If
End Function


*clsTableDef [#r43199b4]
Option Compare Database
Option Explicit

Public mTableDef As DAO.tabledef
Public mDB As DAO.database


Public Sub setTableDef(tabledef As tabledef, db As database)
    Set mTableDef = tabledef
    Set mDB = db
End Sub


Public Sub Refresh()
    mDB.TableDefs.Append mTableDef
    mDB.TableDefs.Refresh
End Sub

Public Sub addField(cField As clsField)
    Dim fld As DAO.field
    Set fld = mTableDef.CreateField(cField.name, cField.getMDBType())
    On Error Resume Next
    If cField.AllowZeroLength Then
        fld.Required = False
        fld.AllowZeroLength = True
    Else
        fld.Required = True
        fld.AllowZeroLength = False
    End If
    
    On Error GoTo 0
    mTableDef.Fields.Append fld
End Sub


Public Sub addFieldByFieldList(list As clsFieldList)
    Dim i As Integer
    On Error GoTo err_handle
    For i = 1 To list.count
        Dim newItem As clsField
        Set newItem = list.getItem(i)
        Debug.Print newItem.name
        addField newItem
        
    Next
    Exit Sub
err_handle:
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub


'メッセージを表示
Private Sub p(message As Variant)
    Debug.Print message
End Sub


*clsTableList [#y7153e9e]
Option Explicit

Private mCol As Collection
Private mCon As ADODB.Connection

Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub

Public Function getItem(name As Variant) As clsTable
    If IsNumeric(name) Then
        Set getItem = mCol.Item(name)
    Else
        Set getItem = mCol.Item(Trim(name))
    End If

End Function


Public Sub setConnection(con As ADODB.Connection, cat As ADOX.Catalog)
    Set mCon = con
    
    Dim TB As ADOX.table
    Dim cTable As clsTable
    
    clearAll
    For Each TB In cat.Tables
        If (TB.Type = "TABLE") And (InStr(1, TB.name, "$") = 0) Then
            Set cTable = New clsTable
            cTable.setTable TB
            On Error Resume Next
            'On Error GoTo error_handler
            addItem cTable
            On Error GoTo 0
            
        ElseIf TB.Type <> "SYNONYM" Then
            'p TB.Type & ":" & TB.name
        End If
    Next TB
    
    
    Exit Sub
error_handler:
    p TB.name & "は追加済み"
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Public Sub clearAll()
    Dim i As Integer
    For i = count To 1 Step -1
        mCol.Remove i
    Next
End Sub


Public Sub addItem(cTable As clsTable)
    mCol.Add cTable, Trim(cTable.mTable.name)
End Sub

Public Function count() As Integer
    count = mCol.count
End Function

'指定したカラムがどのテーブルで使用されているか
Public Function findColumn(name As String) As clsTableList
    Dim ret As clsTableList
    Set ret = New clsTableList
    
    Dim i As Integer
    For i = 1 To count
        DoEvents
        If getItem(i).getColumnList.isExist(Trim(name)) Then
            ret.addItem getItem(i)
        End If
    Next
    Set findColumn = ret
End Function

'テーブル一覧表示
Public Sub showTableList()
    Dim i As Integer
    For i = 1 To count
        p getItem(i).mTable.name
    Next
End Sub

Public Function getTableNameList() As clsCollection
    Dim ret As New clsCollection
    Dim i As Integer
    For i = 1 To count
        ret.mCol.Add getItem(i).mTable.name
    Next
    Set getTableNameList = ret.getReduceList("MGMT_.*").getReduceList("SYS_.*").getReduceList(".*_TAB").getReduceList("ORD_.*").getReduceList("SDO_.*").getReduceList("OGIS_.*").getReduceList(".*PARTITION.*").getReduceList("LBAC_AUDIT_ACTIONS").getReduceList("SESSINFO")
End Function


Sub p(message As String)
    Debug.Print message
End Sub


Public Function isExist(tablename As String) As Boolean
    Dim dummy As Object
    On Error GoTo empt
    Set dummy = getItem(tablename)
    isExist = True
    Exit Function
empt:
    isExist = False
End Function


Public Sub drop(tablename As String)
    If isExist(tablename) Then
        getItem(tablename).drop
    End If
End Sub

Public Sub setDataByRecordset(tablename As String, rs As clsRecordset)
    If Not isExist(tablename) Then

    
        'テーブル作成
        rs.createTable tablename
        Dim cTable As clsTable
        Set cTable = New clsTable
        
        Dim cat As New Catalog
        Set cat.ActiveConnection = mCon
        
        cTable.setTable cat.Tables.Item(tablename)
        addItem cTable
        
    End If
    getItem(tablename).setDataByRecordset rs
End Sub

*clsWorkbook [#g88400dc]
Option Compare Database

Option Explicit

Public alreadyOpened As Boolean

Public mWorkbook As Workbook

Public Sub OpenWorkbook(xls As Excel.Application, wbpath As String, Optional flgReadOnly As Boolean = True)
    On Error GoTo NEWOPEN


    Dim wb As Workbook
    Dim fso As New FileSystemObject
    
    Dim wbname As String
    wbname = fso.GetFile(wbpath).name

    Set mWorkbook = xls.Workbooks.Item(wbname)
    alreadyOpened = True
    Exit Sub
NEWOPEN:
    On Error GoTo 0
    alreadyOpened = False
    Set mWorkbook = xls.Workbooks.Open(wbpath, , flgReadOnly)
End Sub

Private Sub Class_Initialize()
    alreadyOpened = False
End Sub

Private Sub Class_Terminate()
    If (Not alreadyOpened) Then
        On Error Resume Next
        mWorkbook.Close
        mWorkbook.Quit
    End If
End Sub


Public Function getTableList() As clsCollection
    Dim ret As New clsCollection

    Dim tablename As String

    Dim ws As Worksheet
    Set ws = mWorkbook.Sheets("ﾃｰﾌﾞﾙ一覧")
   
    Dim i As Integer
    Dim cel As Range
    i = 0
    
    Set cel = ws.Cells(7 + i, 17) 'R列 ... 17
    While cel.value <> ""
        DoEvents
        ret.addItem cel.value
        i = i + 1
        Set cel = ws.Cells(7 + i, 17) 'R列 ... 17
    Wend
    
    Set getTableList = ret
    
    Exit Function
End Function


*clsUTF8File [#h9441720]
Option Explicit

Public ados As New ADODB.Stream

Public path As String
'Public tmpPath As String


Public Sub load(path As String) ', tmpPath As String)
    
    ados.LoadFromFile path
End Sub

Public Sub save(Optional strPath As String = "") ', tmpPath As String)
    ' バイナリモードにするためにPositionを一度0に戻す
    ' Readするためにはバイナリタイプでないといけない
    ados.Position = 0
    ados.Type = adTypeBinary
    ' Positionを3にしてから読み込むことで最初の3バイトをスキップする
    ' つまりBOMをスキップします
    ados.Position = 3
    Dim bin: bin = ados.Read
    ados.Close
     
    ' 読み込んだバイナリデータをバイナリデータとしてファイルに出力する
    ' ここは一般的な書き方なので説明を省略
    Dim stm As ADODB.Stream
    Set stm = New ADODB.Stream
    stm.Type = adTypeBinary
    stm.Open
    stm.Write bin
    

    If strPath = "" Then
        stm.SaveToFile path, adSaveCreateOverWrite ' force overwrite
    Else
        stm.SaveToFile strPath, adSaveCreateOverWrite ' force overwrite
    End If
    
    stm.Close
    
End Sub


Public Sub close_()
    ados.Close
End Sub




Private Sub Class_Initialize()
    ados.Type = adTypeText
    ados.Charset = "UTF-8"
    ados.Open
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    ados.Close
    Set ados = Nothing
End Sub

Public Function EOF()
    EOF = ados.EOS
End Function

Public Function readLine() As String
    readLine = ados.ReadText(adReadLine)
End Function

Public Sub writeLine(line As String)
   ados.WriteText line, adWriteLine
End Sub

     

Web Master: hayashi_kuniyuki

PukiWiki 1.4.7 Copyright © 2001-2006 PukiWiki Developers Team. License is GPL.
Based on "PukiWiki" 1.3 by yu-ji. Powered by PHP 5.3.29. HTML convert time: 0.018 sec. skin apricot by hirokasa