FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

階層構造テーブル群でのレコード複製 


たいそうな標題にしましたけど・・・・
過去記事でも部品的なものは書いていたかと思います。
1レコードのコピー とか データの転送(再採番あり) など・・・・

階層構造のテーブル群でのフォーム構成・・・っていうのでは
【帳票フォーム+サブの構成】x2(ネストはどうよ その2)
というのも書いてみたりしてました。

今回は、レコード複製する部分だけを考えてみました。
「T見積」「T見積明細」「T見積内訳」の3つのテーブルがあるとします。

テーブル「T見積」の構成
フィールド名
 見積CD 主キー 
 見積日
 担当者CD
 得意先CD
 備考

テーブル「T見積明細」の構成
フィールド名
 見積明細CD 主キー 
 見積CD
 明細行番号
 大分類CD
 見積明細金額
 備考

テーブル「T見積内訳」の構成
フィールド名
 見積内訳CD 主キー 
 見積明細CD
 内訳行番号
 名称
 規格
 単位
 数量
 単価
 備考

これらテーブルのリレーションシップは以下の様になります。
kEnt164

※ **CD とか **番号 とかのデータ型は長整数

この状態の時に、「T見積」の「見積CD」が 2 のものを複製する・・・・したい・・・
 
まず、各テーブルの主キーは自分で採番するものとします。
で、処理を考えていくわけですが・・・・
・これらテーブルでの専用にする
・これらテーブルの構成を元に他でも使えるようにしておく
・等々
私の場合・・・・極力他でも使える/使い回しできるものを・・・を考えます。
ということで・・・・・

「テーブル」「採番するフィールド」「抽出する条件のフィールド」「固定的に設定するフィールド」
の4つを与える事にします。
テーブル「T見積」に対しての設定を記述してみると
Array("T見積", "見積CD", "見積CD", Null)

「T見積」では、「見積CD」を採番して(「見積CD」を条件に抽出後に)固定的に設定すのは無いよ・・・

テーブル「T見積明細」に対しての設定を記述してみると
Array("T見積明細", "見積明細CD", "見積CD", "見積CD")

「T見積明細」では、「見積明細CD」を採番して(「見積CD」を条件に抽出後に)
「見積CD」を固定的に設定してよ・・・
※ ここでは、抽出条件での「見積CD」は元の値で、固定的「見積CD」の値は新採番後のものになります。

で、3つのテーブルをまとめて記述すると
Dim vTbl As Variant

Public Sub ChainCopy(iSrc As Long)
  vTbl = Array( _
        Array("T見積", "見積CD", "見積CD", Null), _
        Array("T見積明細", "見積明細CD", "見積CD", "見積CD"), _
        Array("T見積内訳", "見積内訳CD", "見積明細CD", "見積明細CD") _
      )

  Call ChainCopySub(0, iSrc, iSrc)
End Sub

そう・・・メインで呼ぶ関数を ChainCopy としました。
見積CD = 2 を複製したい時には Call ChainCopy(2) のように・・・
で、本処理する関数を vTbl配列の 0 番目を iSrc で抽出して処理してちょうだい・・・
(ここでの3つ目の引数はダミー扱いになります)
(後の処理になりますが、「固定的に設定するフィールド」が Null なら参照しない様になってます)

本処理 ChainCopySub では
Private Sub ChainCopySub(iNum As Long, iOld As Long, iNew As Long)
  Dim rs As ADODB.Recordset
  Dim i As Long, iR As Long

  Set rs = RecOpen(iNum, iOld)
  For i = 1 To rs.RecordCount
    iR = OneCopy(rs, iNum, iNew)
    If (iNum < UBound(vTbl)) Then
      Call ChainCopySub(iNum + 1, rs(vTbl(iNum + 1)(2)), iR)
    End If
    rs.MoveNext
  Next
  rs.Close
  Set rs = Nothing
End Sub

対象のレコードを抽出して・・・
レコード数分コピーします。
コピーした時に新採番した値を覚えておいて・・・
まだ次のテーブルを処理する必要があったら・・・再帰呼び出しで・・・
つまり、親にあたるテーブルの1レコードごとに、その下にぶら下がるものを辿りながら複製していきます。

ここで、レコード数分・・・・ For i = 1 To rs.RecordCount でループする様にしています。
通常であれば While (Not rs.EOF) 等で処理すると思いますが・・・・
コピーの仕方・・・・これが影響します。
コピーの方法として、現 rs の Clone を作成し、そこに AddNew します。
これは rs の最後に1レコード追加され・・・レコード数は、その分増えます。
つまり、rs.EOF 判別では・・・増えた分も順に・・・順に・・で、無限ループに陥ります。
初期に抽出した分・・・・これだけを処理したいので For を使うように・・・
で、For では rs.RecordCount が必要なので、rs.Open 時 adOpenForwardOnly は使えない・・・
また、Clone を使いたいので adOpenForwardOnly は使えない・・・・
で、で、rs.Open 時には adOpenStatic を指定することに・・・・・・
Private Function RecOpen(iNum As Long, iOld As Long) As ADODB.Recordset
  Dim rs As ADODB.Recordset
  Dim sSql As String
  Const sSqlBase As String = "SELECT * FROM {%1} WHERE {%2} = {%3} ORDER BY {%4};"

  Set rs = New ADODB.Recordset
  sSql = sSqlBase
  sSql = Replace(sSql, "{%1}", vTbl(iNum)(0))
  sSql = Replace(sSql, "{%2}", vTbl(iNum)(2))
  sSql = Replace(sSql, "{%3}", iOld)
  sSql = Replace(sSql, "{%4}", vTbl(iNum)(1))
  rs.Source = sSql
  rs.Open , CurrentProject.Connection, adOpenStatic, adLockOptimistic
  Set RecOpen = rs
End Function

1レコードをコピーする部分は、フィールド名・・・とか、順・・・とか・・・
面倒くさいので、Clone を作って、添え字で単純ループする様に・・・
(今回 Clone 部分を With 記述してみた)
Private Function OneCopy(rs As ADODB.Recordset, iNum As Long, _
              iFixVal As Long) As Long
  Dim iM As Long, i As Long

  If (rs.EOF) Then Exit Function
  iM = Nz(DMax(vTbl(iNum)(1), vTbl(iNum)(0)), 0) + 1
  With rs.Clone
    .AddNew
    For i = 0 To rs.Fields.Count - 1
      .Fields(i) = rs(i)
    Next
    .Fields(vTbl(iNum)(1)) = iM
    If (Not IsNull(vTbl(iNum)(3))) Then .Fields(vTbl(iNum)(3)) = iFixVal
    .Update
    .Close
  End With
  OneCopy = iM
End Function

これらは、標準モジュール「Module1」に記述してます。
全記述は以下
Dim vTbl As Variant

Private Function OneCopy(rs As ADODB.Recordset, iNum As Long, _
              iFixVal As Long) As Long
  Dim iM As Long, i As Long

  If (rs.EOF) Then Exit Function
  iM = Nz(DMax(vTbl(iNum)(1), vTbl(iNum)(0)), 0) + 1
  With rs.Clone
    .AddNew
    For i = 0 To rs.Fields.Count - 1
      .Fields(i) = rs(i)
    Next
    .Fields(vTbl(iNum)(1)) = iM
    If (Not IsNull(vTbl(iNum)(3))) Then .Fields(vTbl(iNum)(3)) = iFixVal
    .Update
    .Close
  End With
  OneCopy = iM
End Function

Private Function RecOpen(iNum As Long, iOld As Long) As ADODB.Recordset
  Dim rs As ADODB.Recordset
  Dim sSql As String
  Const sSqlBase As String = "SELECT * FROM {%1} WHERE {%2} = {%3} ORDER BY {%4};"

  Set rs = New ADODB.Recordset
  sSql = sSqlBase
  sSql = Replace(sSql, "{%1}", vTbl(iNum)(0))
  sSql = Replace(sSql, "{%2}", vTbl(iNum)(2))
  sSql = Replace(sSql, "{%3}", iOld)
  sSql = Replace(sSql, "{%4}", vTbl(iNum)(1))
  rs.Source = sSql
  rs.Open , CurrentProject.Connection, adOpenStatic, adLockOptimistic
  Set RecOpen = rs
End Function

Private Sub ChainCopySub(iNum As Long, iOld As Long, iNew As Long)
  Dim rs As ADODB.Recordset
  Dim i As Long, iR As Long

  Set rs = RecOpen(iNum, iOld)
  For i = 1 To rs.RecordCount
    iR = OneCopy(rs, iNum, iNew)
    If (iNum < UBound(vTbl)) Then
      Call ChainCopySub(iNum + 1, rs(vTbl(iNum + 1)(2)), iR)
    End If
    rs.MoveNext
  Next
  rs.Close
  Set rs = Nothing
End Sub

Public Sub ChainCopy(iSrc As Long)
  vTbl = Array( _
        Array("T見積", "見積CD", "見積CD", Null), _
        Array("T見積明細", "見積明細CD", "見積CD", "見積CD"), _
        Array("T見積内訳", "見積内訳CD", "見積明細CD", "見積明細CD") _
      )

  Call ChainCopySub(0, iSrc, iSrc)
End Sub

Public Sub test()
  Call ChainCopy(2)
End Sub

 
ここで、確認用の test を実行してみると以下の様な感じで表示され、複製はうまくいったようです。
kEnt164_1


ここまでで、一応想定したテーブル群での複製はできるようになりました。

ただ最近の質問にあったのは、テーブル「T見積内訳」の構成に ★ 部分が存在していました。
フィールド名
 見積内訳CD 主キー 
 見積CD ★
 見積明細CD
 内訳行番号
 名称
 規格
 単位
 数量
 単価
 備考

「T見積」「T見積明細」「T見積内訳」を「T見積Z」「T見積明細Z」「T見積内訳Z」名でコピーし、
「T見積内訳Z」を同じになるように修正します。
そこで、標準モジュール「Module1」のものを「Module2」にコピーして修正を掛けます。
Dim vTbl As Variant

Private Function OneCopy(rs As ADODB.Recordset, iNum As Long, _
              vFixVal As Variant) As Long
  Dim iM As Long, i As Long, j As Long
  Dim v As Variant

  If (rs.EOF) Then Exit Function
  iM = Nz(DMax(vTbl(iNum)(1), vTbl(iNum)(0)), 0) + 1
  With rs.Clone
    .AddNew
    For i = 0 To rs.Fields.Count - 1
      .Fields(i) = rs(i)
    Next
    .Fields(vTbl(iNum)(1)) = iM
    v = vTbl(iNum)(3)
    If (IsArray(v)) Then
      For j = 0 To UBound(v)
        .Fields(v(j)) = vFixVal(j)
      Next
    End If

    .Update
    .Close
  End With
  OneCopy = iM
End Function

Private Function RecOpen(iNum As Long, iOld As Long) As ADODB.Recordset
  Dim rs As ADODB.Recordset
  Dim sSql As String
  Const sSqlBase As String = "SELECT * FROM {%1} WHERE {%2} = {%3} ORDER BY {%4};"

  Set rs = New ADODB.Recordset
  sSql = sSqlBase
  sSql = Replace(sSql, "{%1}", vTbl(iNum)(0))
  sSql = Replace(sSql, "{%2}", vTbl(iNum)(2))
  sSql = Replace(sSql, "{%3}", iOld)
  sSql = Replace(sSql, "{%4}", vTbl(iNum)(1))
  rs.Source = sSql
  rs.Open , CurrentProject.Connection, adOpenStatic, adLockOptimistic
  Set RecOpen = rs
End Function

Private Sub ChainCopySub(iNum As Long, iOld As Long, vNew As Variant)
  Dim rs As ADODB.Recordset
  Dim i As Long, j As Long, iR As Long
  Dim v As Variant, vPrm As Variant

  Set rs = RecOpen(iNum, iOld)
  For i = 1 To rs.RecordCount
    iR = OneCopy(rs, iNum, vNew)
    If (iNum < UBound(vTbl)) Then
      v = vTbl(iNum + 1)(3)
      If (IsArray(v)) Then
        ReDim vPrm(UBound(v))
        With rs.Clone
          .MoveLast ' コピーした最新のものは最後にあるはず・・・そこから値を入手
          For j = 0 To UBound(v)
            vPrm(j) = .Fields(v(j))
          Next
          .Close
        End With
      End If

      Call ChainCopySub(iNum + 1, rs(vTbl(iNum + 1)(2)), vPrm)
    End If
    rs.MoveNext
  Next
  rs.Close
  Set rs = Nothing
End Sub

Public Sub ChainCopy(iSrc As Long)
  vTbl = Array( _
        Array("T見積Z", "見積CD", "見積CD", _
          Null), _
        Array("T見積明細Z", "見積明細CD", "見積CD", _
          Array("見積CD")), _
        Array("T見積内訳Z", "見積内訳CD", "見積明細CD", _
          Array("見積CD", "見積明細CD")) _
      )

  Call ChainCopySub(0, iSrc, Null)
End Sub

Public Sub test()
  Call ChainCopy(2)
End Sub

 
※ テーブル名が変わった・・・・云々・・・
 vTbl に設定する部分を変更するだけですね・・・・(固定値が複数になったところを除けば)


それはそうと・・・XX 番の 見積CD を複製したら、YY番・・・これ、知りたい/通知したい・・・かな?
ということで・・・・標準モジュール「Module2」のものを「Module3」にコピーして修正を掛けます。
Dim vTbl As Variant

Private Function OneCopy(rs As ADODB.Recordset, iNum As Long, _
              vFixVal As Variant) As Long
  Dim iM As Long, i As Long, j As Long
  Dim v As Variant

  If (rs.EOF) Then Exit Function
  iM = Nz(DMax(vTbl(iNum)(1), vTbl(iNum)(0)), 0) + 1
  With rs.Clone
    .AddNew
    For i = 0 To rs.Fields.Count - 1
      .Fields(i) = rs(i)
    Next
    .Fields(vTbl(iNum)(1)) = iM
    v = vTbl(iNum)(3)
    If (IsArray(v)) Then
      For j = 0 To UBound(v)
        .Fields(v(j)) = vFixVal(j)
      Next
    End If
    .Update
    .Close
  End With
  OneCopy = iM
End Function

Private Function RecOpen(iNum As Long, iOld As Long) As ADODB.Recordset
  Dim rs As ADODB.Recordset
  Dim sSql As String
  Const sSqlBase As String = "SELECT * FROM {%1} WHERE {%2} = {%3} ORDER BY {%4};"

  Set rs = New ADODB.Recordset
  sSql = sSqlBase
  sSql = Replace(sSql, "{%1}", vTbl(iNum)(0))
  sSql = Replace(sSql, "{%2}", vTbl(iNum)(2))
  sSql = Replace(sSql, "{%3}", iOld)
  sSql = Replace(sSql, "{%4}", vTbl(iNum)(1))
  rs.Source = sSql
  rs.Open , CurrentProject.Connection, adOpenStatic, adLockOptimistic
  Set RecOpen = rs
End Function

Private Function ChainCopySub(iNum As Long, iOld As Long, vNew As Variant) As Long
  Dim rs As ADODB.Recordset
  Dim i As Long, j As Long, iR As Long
  Dim v As Variant, vPrm As Variant

  Set rs = RecOpen(iNum, iOld)
  For i = 1 To rs.RecordCount
    iR = OneCopy(rs, iNum, vNew)
    If (iNum < UBound(vTbl)) Then
      v = vTbl(iNum + 1)(3)
      If (IsArray(v)) Then
        ReDim vPrm(UBound(v))
        With rs.Clone
          .MoveLast
          For j = 0 To UBound(v)
            vPrm(j) = .Fields(v(j))
          Next
          .Close
        End With
      End If
      Call ChainCopySub(iNum + 1, rs(vTbl(iNum + 1)(2)), vPrm)
    End If
    rs.MoveNext
  Next
  rs.Close
  Set rs = Nothing
  ChainCopySub = iR
End Function

Public Function ChainCopy(iSrc As Long) As Long
  vTbl = Array( _
        Array("T見積Z", "見積CD", "見積CD", _
          Null), _
        Array("T見積明細Z", "見積明細CD", "見積CD", _
          Array("見積CD")), _
        Array("T見積内訳Z", "見積内訳CD", "見積明細CD", _
          Array("見積CD", "見積明細CD")) _
      )

  ChainCopy = ChainCopySub(0, iSrc, Null)
End Function

Public Sub test()
  Debug.Print ChainCopy(2)
End Sub

 

言い忘れていましたが・・・・各テーブル間で値を引き継ぐもののフィールド名は親/子とも同じ・・・・
これが前提であります。
例えば「見積CD」というフィールド名は、どのテーブルでも同じ・・・・


※※ エラー処理は入れてません

※※ エラー処理も含め、こうした方が・・・こう考えた方が・・・・教えてください


なお、サンプルファイルはいらないのかと思いましたが・・・・
データは、数件適当に入れてます。
いろいろといじってみてください。

サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt164_2000.zipkEnt164_2003.zipkEnt164_2007.zip
 サイズ 31,70931,85834,848
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

関連記事

2013/06/09

Category: サンプルかな

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。