VBAのコード

[ トップ ] [ 編集 | 凍結 | 差分 | バックアップ | 添付 | リロード ] [ 新規 | 一覧 | 単語検索 | 最終更新 | ヘルプ ]

目次 †

↑

趣旨 †

何度も同じようなコードをインターネットから探しては

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

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

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

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

↑

ファイル操作 †

↑

一時ファイル取得 †

' 一時ファイル名取得用 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 †

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

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 †

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 †

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

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 †

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 †

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 †

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 †

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 †

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

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 †

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 †

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 †

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

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

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 †

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 †

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

Last-modified: 2010-10-02 (土) 21:18:47 (4948d)

最新の30件

目次 †

趣旨 †

ファイル操作 †

一時ファイル取得 †

basMain †

basReadEntity? †

clsCollection †

clsColumn †

clsColumnList? †

clsConnection †

clsDB †

clsDSN †

clsExcel †

clsField †

clsFieldList? †

clsLog †

clsRecordset †

clsTable †

clsTableDef? †

clsTableList? †

clsWorkbook †

clsUTF8File †