20日締、末締

x = Date

'締日 = "15日;20日;25日;末日"

'支払日 = "翌10日;翌20日;翌25日;翌末日;翌々5日;翌々10日"

Me.売掛先ＣＤ.SetFocus

aa = 売掛先ＣＤ.Value

rs6.CursorLocation = adUseServer

rs6.CursorType = adOpenStatic

rs6.LockType = adLockOptimistic

rs6.Open "SELECT * from 売掛先Ｍ WHERE 売掛先ＣＤ = '" & aa & "' ", CN, , , adCmdText

If rs6.EOF Then Exit Sub

y = rs6.Fields("締日").Value

z = rs6.Fields("支払日").Value

'****************************

If y = "末日" Then yy = DateAdd("d", -1, DateSerial(Year(x), Month(x) + 1, 1))

If y = "20日" Then

If Day(x) > 20 Then

yy = DateSerial(Year(x), Month(x) - CInt(20 = 0) + 1, 20)

Else

yy = DateSerial(Year(x), Month(x) - CInt(20 = 0) + 0, 20)

End If

End If

If y = "15日" Then

If Day(x) > 15 Then

yy = DateSerial(Year(x), Month(x) - CInt(15 = 0) + 1, 15)

Else

yy = DateSerial(Year(x), Month(x) - CInt(15 = 0) + 0, 15)

End If

End If

If y = "25日" Then

If Day(x) > 25 Then

yy = DateSerial(Year(x), Month(x) - CInt(25 = 0) + 1, 25)

Else

yy = DateSerial(Year(x), Month(x) - CInt(25 = 0) + 0, 25)

End If

End If

'******************************

If z = "翌末日" Then zz = DateAdd("d", -1, DateSerial(Year(x), Month(x) + 2, 1))

If z = "翌20日" Then

If Day(x) > 20 Then

zz = DateSerial(Year(x), Month(x) - CInt(20 = 0) + 2, 20)

Else

zz = DateSerial(Year(x), Month(x) - CInt(20 = 0) + 1, 20)

End If

End If

インポ－ト処理

DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "仮", Me.名前.Value, True

30　インポ－ト処理（注意）---これは、もとデータがＥＸＣＥＬのフアイルをインポート処理する

オプションボタン使用時の例

If IsNull(Me.検索) Then Exit Sub

Me.検索.SetFocus

B = Me.検索.Value

x = Me.選択.Value

Select Case x

Case 1

rs.Open "SELECT * from 受注 WHERE お客様 like '" & "%" & B & "%" & "'", conn, , , adCmdText

Case 2

rs.Open "SELECT * from 受注 WHERE メールアドレス like '" & "%" & B & "%" & "'", conn, , , adCmdText

End Select

If rs.EOF = True Then Exit Sub

Ｂ----入力する項目

ｘ-----オプショングループの名前

コンボボックスを２個連動して使用する場合　　２個目のデータが必ず　最初の内容の変化に対応できるようにしる

Private Sub 商品ＣＤ_Enter()

Me.Refresh

End Sub

SELECT文で抽出したデータをINSERT文で登録する

With cmd

    .CommandText = "INSERT INTO PC修理管理表 (伝票番号,お客様名,メーカ名,商品名,型番,SN,障害内容,バーコード,登録日,発行者,家電かPCか,登録番号1,登録番号2) (SELECT 伝票番号,お客様名,メーカ名,商品名,型番,SN,コメント,バーコード,'" & b & "','" & c & "'," & d & ",'" & Format(e, "00000000") & "','" & Format(f, "0000") & "' from 修理管理表 WHERE 伝票番号 = '" & a & "')"

    .CommandType = adCmdText

    .Execute

  End With

SQL文を複数行で作成し、実行時

Dim strSQL1 As String

     strSQL1 = "UPDATE 実績表 SET 工事 = '" & Me.工事 & "',名称 = '" & Me.名称 & "',単価 = '" & Me.単価 & "',"

     strSQL1 = strSQL1 & "単位 = '" & Me.単位 & "',数量 = " & Me.数量 & ",小計 = '" & Me.小計 & "',"

     strSQL1 = strSQL1 & "備考 = '" & Me.備考 & "'"

     strSQL1 = strSQL1 & " WHERE 請求番号 = '" & Me.請求番号 & "' and 追番 = " & Me.追番 & ""

      With cmd

       .CommandText = strSQL1

       .CommandType = adCmdText

       .Execute

      End With

MDBで、オートカウンタ最大値の取り方

Dim a As Long

rs6.Open "SELECT last(ID) as ed from 製造不良一時", CN, , , adCmdText

If rs6.EOF Then Exit Sub

a = rs6.Fields("ed")

With cmd

.CommandText = "DELETE * FROM 製造不良一時 where ID = " & a & " and 製造番号 = '" & Me.製造番号 & "'"

.CommandType = adCmdText

.Execute

End With

配列の例

Dim rec(99)

 ' 100項目データがセットできる

  Set cur2 = CurrentDb

  Set soc2 = cur2.OpenRecordset("SELECT * FROM 仮 Where 伝票番号 <> Null Order By 伝票番号 Asc;", dbOpenDynaset)

 If soc2.EOF Then Exit Function  ' 5月12日追加

    soc2.MoveFirst

   Do Until soc2.EOF

  b = soc2.Fields("伝票番号").Value

    Set con = New ADODB.Connection

  con.ConnectionString = "Provider=SQLOLEDB;Data Source=SERVERWCC;Initial Catalog=kansc;User ID=O3791;Password=P#m8i4;Integrated Security = SSPI;"

    Set rst = New ADODB.Recordset

    'If Not soc2.EOF Then

    con.Open

    Set cmd.ActiveConnection = con

   con.BeginTrans

    rst.Open "Select 伝票番号 From 受注オーダ Where 伝票番号 = '" & b & "';", con, adOpenKeyset, adLockOptimistic

       'rs2.CursorLocation = adUseServer

       'rs2.CursorType = adOpenStatic

      ' rs2.LockType = adLockOptimistic

    ' con.BeginTrans

    ' c = rst.Fields("伝票番号").Value

            rec(0) = soc2.Fields("伝票番号").Value

            rec(1) = soc2.Fields("先").Value

            rec(2) = soc2.Fields("区分").Value

            rec(3) = soc2.Fields("代行先").Value

            rec(4) = soc2.Fields("店舗コード").Value

            rec(5) = soc2.Fields("店舗担当").Value

  '        　　　　　　途中は省略

            rec(97) = soc2.Fields("CL工料込").Value

            rec(98) = soc2.Fields("CL出張代込").Value

            rec(99) = soc2.Fields("CL合計込").Value

条件付きで、例えば、現品カードなどを同一紙に複数印刷する場合の例

レポートにプロシジャーをセットする

Option Explicit

Dim P_COUNT As Long, SUURYO As Double

Private Sub Report_NoData(Cancel As Integer)

Cancel = True

End Sub

Private Sub Report_Open(Cancel As Integer)

P_COUNT = 1: SUURYO = 0

End Sub

Private Sub 詳細_Format(Cancel As Integer, FormatCount As Integer)

    If P_COUNT < Me!枚数 Then

        Me.MoveLayout = True

        Me.NextRecord = False

        Me.PrintSection = True

    End If

End Sub

Private Sub 詳細_Print(Cancel As Integer, PrintCount As Integer)

On Error GoTo ERR

Me!枚数S = P_COUNT

If P_COUNT = 1 Then SUURYO = Me!数量

If P_COUNT < Me!枚数 Then

    Me!SNP1 = Me!SNP

    SUURYO = SUURYO - Me!SNP

    P_COUNT = P_COUNT + 1

Else

    Me!SNP1 = SUURYO

    SUURYO = 0

    P_COUNT = 1

End If

Exit Sub

ERR:

    MsgBox ERR.Description

Exit Sub

On Error GoTo 0

End Sub

レポートの書式設定

レポートのページ設定

　　　　　　　列数-------------------2

　　　　　　　印刷方向---------------上から下へ

WHERE にＳＥＬＥＣＴ文で抽出したものを使用

     With cmd

    .CommandText = "update 受注オーダ set 印済 = '" & a & "',出荷日 = #" & b & "# where 伝票番号 in (select 伝票番号 from 印刷対象)"

    .CommandType = adCmdText

    .Execute

      End With

この場合、伝票番号は実際のデータと合っていること

SQL文で抽出したデータをいきなりデータの更新は不可能で主キーをWHEREにあてがう

   rs.Open "SELECT * from 入金元帳 WHERE 手形番号 = '" & Me.手形番号 & "'", conn, , , adCmdText

       rs.MoveFirst

   Do Until rs.EOF

        x = rs.Fields("ＣＤ").Value

     With cmd

       .CommandText = "UPDATE 入金元帳 SET 手形決済金額 = '" & Me.決済金額 & "',手形補正 = '" & Me.補正 & "',手形補正内容 = '" & Me.補正内訳 & "',手形完 = '" & 2 & "' WHERE ＣＤ = " & x & ""

       .CommandType = adCmdText

       .Execute

      End With

       rs.MoveNext

       Loop

ADPで、別フオームのサブフオームのRequeryする場合
(ADP-専用）

Set Forms!入力!入力子.Form.Recordset = rs

         Forms!入力.入力子.Requery

金額及び数字のＮＵＬＬ対策

Dim a As Currency

Me.入金明細子.Form.入金小計.SetFocus

On Error Resume Next

a = Nz(Me.入金明細子.Form.入金小計.Value, 0)

入金額 = a

エラー発生後のスルー

On Error Resume Next

      rs.Open "SELECT * from 図番Ｍ where 製品ＣＤ like '" & Me.検索 & "%" & "'", cn, , , adCmdText

           If rs.EOF = True Then Exit Sub

       Me.図番子.[製品ＣＤ].ControlSource = "製品ＣＤ"

        Me.図番子.[製品図番].ControlSource = "製品図番"

        Me.図番子.[品名].ControlSource = "品名"

      Set Recordset = rs

      Me.図番子.Requery

クエリーで、データベースのアクションをする場合

    DoCmd.SetWarnings False

    'バックアップデータ削除

    DoCmd.RunSQL "DELETE * FROM BTD_日報番号データ"

    DoCmd.RunSQL "DELETE * FROM BTD_入金ヘッダー"

    DoCmd.RunSQL "DELETE * FROM BTD_入金明細"

日付をテキスト形式でテーブルに格納する場合

例えば

　　　　　H21/08/28のような形式で

　　　b = Date

　　　bb = Format(b, "gee/mm/dd")-------　bb が　H21/08/28

　　通常の形式にもどす場合

      cc = Format(bb, "yyyy/mm/dd")-------ccが　2009/08/28

 日付をテキスト形式でテーブルで保存すると　更新などはやりやすいが

 日付計算はしにくい

  If Day(cc) > 20 Then

                  yy = DateSerial(Year(cc), Month(cc) - CInt(20 = 0) + 1, 20)

            Else

                   yy = DateSerial(Year(cc), Month(cc) - CInt(20 = 0) + 0, 20)

データのラストデータを検出して対象のデータを削除

rs6.Open "SELECT last(番号) as ed from 宛先表", cnn, adOpenKeyset, adLockOptimistic

  If rs6.EOF Then Exit Sub

  a = Nz(rs6.Fields("ed"), 0)

  cnn.Execute "DELETE FROM 宛先表 where 番号 = " & a & ""

入力を指定する方法の例

Ｉf Me.科目上 = "収益" Then

   Me.買掛Ｒ.Visible = False

   Me.買掛先CD.Visible = False

   Me.買掛先名.Visible = False

   Me.売掛Ｒ.Visible = True

   Me.売掛先ＣＤ.Visible = True

   Me.売掛先名.Visible = True

   Else

   Me.売掛Ｒ.Visible = False

   Me.売掛先ＣＤ.Visible = False

   Me.売掛先名.Visible = False

   Me.買掛Ｒ.Visible = True

   Me.買掛先CD.Visible = True

   Me.買掛先名.Visible = True  

   End If

EXCEL出力の例

Dim myXLS As Excel.Application

Dim myWKB As Excel.Workbook

Dim myWKS As Excel.Worksheet

Dim conn As New ADODB.Connection

Dim rs  As New ADODB.Recordset

Dim rs2  As New ADODB.Recordset

Dim rs3  As New ADODB.Recordset

 Set conn = CurrentProject.Connection

Dim cmd As New ADODB.Command

Set cmd.ActiveConnection = conn

rs.Open "SELECT * FROM 入金 INNER JOIN 仕訳項目 ON (入金.小分類 = 仕訳項目.小分類) AND (入金.中分類 = 仕訳項目.中分類) AND (入金.大分類 = 仕訳項目.大分類) WHERE 入金日 Between #" & Me.開始日 & "# And #" & Me.終了日 & "# AND 入金.計 = '" & 1 & "' ORDER BY 入金.大分類, 仕訳項目.CD", conn, , , adCmdText

If rs.EOF Then Exit Sub

 Set myXLS = New Excel.Application

  myXLS.Visible = True           '--------------------------Workbookを開く

  Set myWKB = myXLS.Workbooks.Add

  Set myWKS = myWKB.Worksheets("sheet1")

  Dim g As Long

  myXLS.Cells(2, 2).Value = "期間 " & FormatDateTime(Me.開始日.Value) & "～" & FormatDateTime(Me.終了日.Value)

        myXLS.Cells(4, 2).Value = "中分類"

        myXLS.Cells(4, 3).Value = "小分類"

        myXLS.Cells(4, 4).Value = "摘要"

        myXLS.Cells(4, 5).Value = "金額"

        myXLS.Cells(4, 6).Value = "入金日"

        myXLS.Cells(4, 7).Value = "対象"

        myXLS.Cells(4, 8).Value = "備考"

   g = 4

rs.MoveFirst

Do Until rs.EOF

             g = g + 1    

        myXLS.Cells(g, 2).Value = rs.Fields(2)  ' ------テーブルの項目は0　よりカウントする

        myXLS.Cells(g, 3).Value = rs.Fields(3)

        myXLS.Cells(g, 4).Value = rs.Fields(4)

        myXLS.Cells(g, 5).Value = rs.Fields(8)

        myXLS.Cells(g, 6).Value = FormatDateTime(rs.Fields(9))

        myXLS.Cells(g, 7).Value = rs.Fields(12)

        myXLS.Cells(g, 8).Value = rs.Fields(11)

rs.MoveNext

 Loop

遅延バインデバイデングによるEXCELの開き方(Excel2013対応も）

 Dim myXLS As Object

 Dim myWKB As Object

 Dim myWKS As Object

Dim conn As New ADODB.Connection

Dim rs  As New ADODB.Recordset

Dim cmd As New ADODB.Command

Set conn = CurrentProject.Connection

Set cmd.ActiveConnection = conn

      On Error Resume Next

    Set myXLS = CreateObject("Excel.Application.15")

    Set myXLS = CreateObject("Excel.Application")

   Set myWKB = myXLS.Workbooks.Add

    Set myWKS = myWKB.Worksheets("sheet1")

    myWKS.Application.Visible = True

    myXLS.Visible = True   '--------------------------Workbookを開く

日付の設定

当月初日

DateSerial(Year(Forms![フォーム名]![年月日]),Month(Forms![フォーム名]![年月日]),1)

当月月末

DateSerial(Year(Forms![フォーム名]![年月日]),Month(Forms![フォーム名]![年月日])+1,0)

ですね。

（当月の月末日） DateSerial(Year(Date()),Month(Date())+1,0)

（翌月の２０日） DateSerial(Year(Date()),Month(Date())+1,20)

（翌々月１日） DateSerial(Year(Date()),Month(Date())+2,1)

（翌日から数えて30日後） DateSerial(Year(Date()),Month(Date()),Day(Date())+30)

テキストデータのインポート例

Dim cur As Database

 Dim soc As Recordset

  Err.Clear

  On Error GoTo 0

    DoCmd.TransferText acImportDelim, , "仮", Me.取込.Value, True

  Err.Clear

  On Error Resume Next

  Set cur = CurrentDb

  Set soc = cur.OpenRecordset("SELECT COUNT(*) FROM " & Me.取込 & "_インポート　エラー ;", dbOpenDynaset)

  If Err.Number = 0 Then

  If soc.Fields(0).Value > 0 Then MsgBox "解釈できないレコードがあります。"

  End If

  soc.Close

  Set soc = Nothing

  Set cur = Nothing

  On Error GoTo 0

 登録時のチエック例

    a = Me.CD

     b = Len(a)

     If b <> 5 Then Exit Sub

     rs4.Open "SELECT * from 仕訳項目 WHERE CD = '" & a & "'", cn, , , adCmdText

     If Not rs4.EOF Then

           If rs4.Fields("CD").Value = a Then

             MsgBox "コードが登録済みです。"

             Exit Sub

          End If

       End If

       rs2.Open "SELECT * from 仕訳項目 WHERE 大分類 = '" & Me.大分類 & "' and 中分類 = '" & Me.中分類 & "' and 小分類 = '" & Me.小分類 & "'", cn, , , adCmdText

       If Not rs2.EOF Then

           If rs2.Fields("大分類").Value = Me.大分類 And rs2.Fields("中分類").Value = Me.中分類 And rs2.Fields("小分類").Value = Me.小分類 Then

             MsgBox "登録済みです。"

             Exit Sub

          End If

       Else

        rs.Open "仕訳項目", cn, adOpenKeyset, adLockOptimistic, adCmdTableDirect

        rs.AddNew

        rs("大分類") = Me.大分類

        rs("中分類") = Me.中分類

        rs("更新日") = Date

        rs("小分類") = Me![小分類]

        rs("備考") = Me![備考]

         rs("計") = "1"

    '     rs("計") = Me![計]

         rs("CD") = Me![CD]

        rs.Update

         End If

        rs.Close

        Set rs = Nothing

        cn.Close

BeginTransとCommitTransの例

   CN.BeginTrans

      With cmd

       .CommandText = "DELETE * FROM 科目Ｍ WHERE 科目CD = '" & Me.科目CD & "'"

       .CommandType = adCmdText

       .Execute

      End With

    CN.CommitTrans

テキストデータのインポート

    DoCmd.TransferText acImportDelim, "IMP", "受信一時", Me.名前.Value, False

　　　　　　ＩＭＰ------インポートするフアイルの定義　　　外部にiniに出すことも可能

　　　　　　受信一時---インポート後のテーブル

　　　　　　名前-------インポートするフアイルがあるパス名

　　　　　　False-------最初の行が項目名の場合は　True

定義体の場所

　　　システムテーブル（ツール→オプション→システムオブジェクトにチェックしないと見えません）、

　　　　　　　　　　　　　　「MSysIMEXColumns」

　　　　　　　　　　　　　　「MSysIMEXSpecs」

定義体の修正など

　　　　対象のテーブルを開き、手動で、インポートをすると、ウイザードが出てくる

　　　　　「定義(P)...」「設定(V)...」ボタンをクリックする

下記内容は、　クライアントに、ADPを使用し、DBは、SQLserver接続した場合のT-SQLの内容です

(ADP-専用）

 日付による抽出クエリー

ALTER PROCEDURE dbo.[SP入金データ抽出]

(@開始日 nvarchar(50),

@終了日 nvarchar(50))

AS SELECT dbo.入金.*, dbo.店舗Ｍ.店舗名, CONVERT(datetime, CONVERT(nvarchar,

dbo.入金.取引日, 111), 120) AS 月日

FROM dbo.入金 INNER JOIN

dbo.店舗Ｍ ON dbo.入金.[店舗コード] = dbo.店舗Ｍ.[店舗コード]

WHERE (CONVERT(datetime, CONVERT(nvarchar, dbo.入金.取引日, 111), 120) BETWEEN @開始日 AND @終了日)

（説明）フオームに、開始日、終了日のコントロールを設定

　　　　　取引日は、年月日時間分秒

　　　　　変数の月日は、年月日--------convert 2回で、変換

　　　　　where は、変数の月日を　betweeen　で、開始日、終了日　に対応する　　　　例）　当日の月日に変換方法

　　　select convert (datetime,convert (nvarchar,getdate() ,111),120)（参考）　

SELECT CONVERT(VARCHAR(30),@GetDate(),110) --02-11-2007

SELECT CONVERT(VARCHAR(30),@GetDate(),111) --2007/02/11

SELECT CONVERT(VARCHAR(30),@GetDate(),112) --20070211

SELECT CONVERT(VARCHAR(30),@GetDate(),113) --11 02 2007 12:34:56:790

SELECT CONVERT(VARCHAR(30),@GetDate(),120) --2007-02-11 12:34:56

update文の例


(ADP-専用）

ALTER PROCEDURE [update_受注オーダ_1]

(@伝票番号_1 [char](20),

@自社Ｓ_2 [datetime],

@メーカＳ_3 [datetime],

@運送会社2_4 [char](20),

@運送伝票2_5 [char](30),

@運送金額2_6 [money])

AS UPDATE [syuri].[dbo].[受注オーダ]

SET [伝票番号] = @伝票番号_1,

[自社Ｓ] = @自社Ｓ_2,

[メーカＳ] = @メーカＳ_3,

[運送会社2] = @運送会社2_4,

[運送伝票2] = @運送伝票2_5,

[運送金額2] = @運送金額2_6

WHERE

( [伝票番号] = @伝票番号_1)

---クエリの自動作成時、キー項目の[char](20)の　部分が作成されない場合があるので、注意

（注意）　@の付くパラメータの番号は、

　　　　　　対応するプロシジャーの　番号と対応していること

insert文の例


(ADP-専用）

ALTER PROCEDURE dbo.insert_CTL子_1

(@子ID_1 [bigint],

@親ID_2 [bigint],

@受付日_3 [datetime],

@問合せ_4 [nvarchar](1000))

AS INSERT INTO dbo.CTL子

(子ID, 親ID, 受付日,問合せ)

VALUES (@子ID_1, @親ID_2, @受付日_3, @問合せ_4)

（注意）　@の付くパラメータの番号は、

　　　　　　対応するプロシジャーの　番号と対応していること

delete文の例

(ADP-専用）

ALTER PROCEDURE [delete_仮オーダ_1]

AS DELETE [syuri].[dbo].[仮オーダ]

       rs3.Open "SELECT * from 組合登録一時 where 選択 = true", cn, , , adCmdText

       If Not rs3.EOF Then

      rs3.MoveFirst

   Do Until rs3.EOF

      Set rs21 = New ADODB.Recordset

       rs21.Open "SELECT * from 人員登録発行 where ID = " & rs3.Fields("ID") & "", cn, , , adCmdText

       If Not rs21.EOF Then

       With cmd

      .CommandText = "UPDATE 人員登録発行 SET 選択 = " & rs3.Fields("選択") & ",更新日 = #" & Date & "# WHERE CD = " & rs21.Fields("CD") & ""

      .CommandType = adCmdText

      .Execute

       End With

     rs3.MoveNext

     Else

     End If

   Loop

Else

End If

ADOXによるテーブル作成

Dim a

 Dim z

 Dim y

 Dim x

Dim zzz

Dim k

Dim b

Dim e

a = "A"

    y = CDate(Me.月1)

    zzz = DateAdd("m", 1, y)

 Dim CAT As ADOX.Catalog

 Dim TB As ADOX.Table

          Set CAT = New ADOX.Catalog

          CAT.ActiveConnection = CurrentProject.Connection

          'テーブルを作成

          Set TB = New ADOX.Table

          TB.Name = "予定"

    Do Until y = zzz

          'フィールド定義

         b = "1"

       For k = 1 To 5

              x = a & b

              z = y & x

          TB.Columns.Append z, adVarWChar, 10

    '      TB.Columns.Append "氏前", adVarWChar, 30

       c = Val(b)

        c = c + 1

        b = Str(c)

       a = "A"

       Next k

      y = DateAdd("d", 1, y)

   Loop

         Dim cn As New ADODB.Connection

    Dim cmd As New ADODB.Command

     Dim rs As ADODB.Recordset

    Dim ss

     Set cn = CurrentProject.Connection

     Set rs = New ADODB.Recordset

     Set cmd.ActiveConnection = cn

      rs.CursorType = adOpenStatic

      rs.LockType = adLockOptimistic

      rs.Open "SELECT * from 予約日", cn, , , adCmdText

       If Not rs.EOF = True Then

          rs.MoveFirst

          Do Until rs.EOF

            ss = rs.Fields("名前")

              TB.Columns.Append ss, adVarWChar, 20

            rs.MoveNext

          Loop

       Else

       End If

          'データベースに登録

          CAT.Tables.Append TB

          Set CAT = Nothing

          Application.RefreshDatabaseWindow 'データベースを表示

　     Dim cat As ADOX.Catalog

　　　Dim tbl As ADOX.Table

　　　Dim col As ADOX.Column

　　　Set cat = New ADOX.Catalog

　　　cat.ActiveConnection = CurrentProject.Connection

　　　Set tbl = cat.Tables(Item:="テーブル名")

　　　Set col = New ADOX.Column

　　　With col

　　　　.ParentCatalog = cat

　　　　.Name = "新規フィールド名"

　　　　.Type = adInteger

　　　　.Properties("AutoIncrement") = True

　　　End With

　　　tbl.Columns.Append Item:=col

　　　Set cat = Nothing

　　　Set tbl = Nothing

　　　Set col = Nothing

insert into　文の例

      With cmd

      .CommandText = "insert into 仮オーダ(注文番号,店舗コード,お客様,型番,出荷日,ネバ番号) VALUES( '" & aa & "','" & ab & "','" & ac & "','" & ad & "','" & aj & "','" & ak & "')"

      .CommandType = adCmdText

      .Execute

       End With

西暦、和暦変換テーブルを用いた、西暦より和暦に変換するコードの一部

rs.CursorLocation = adUseServer

rs.CursorType = adOpenStatic

rs.LockType = adLockOptimistic

 rs.Open "SELECT * from 追善一時 ", cn, , , adCmdText

If rs.EOF Then Exit Sub

rs.MoveFirst

Do Until rs.EOF

      bb = rs.Fields("仮設定日")

     Set rs6 = New ADODB.Recordset

        rs6.Open "SELECT * from 元号 order by 始年月日", cn, , , adCmdText

        If rs6.EOF = True Then

         End If

        rs6.MoveFirst

      Do Until rs6.EOF

           D = rs6.Fields("始年月日")

           c = rs6.Fields("元号")

           rs6.MoveNext

           If rs6.EOF Then

           y = c

           Exit Do

           End If

           dd = rs6.Fields("始年月日")

           cc = rs6.Fields("元号")

           If bb >= D And bb < dd Then

            y = c

            Exit Do

            End If

      Loop

          x = Year(bb) - Year(D) + 1

         If x = "1" Then x = "元"

         r = y & x

         S = Format(bb, "mm")

         t = r & "年" & S & "月"

          A = Format(bb, "yyyy" & "/" & "mm")

  If IsNull(Me.行事ID) Then Exit Sub

    DoCmd.RunCommand acCmdSaveRecord

     Dim cn As New ADODB.Connection

     Dim cmd As New ADODB.Command

     Set cn = CurrentProject.Connection

     Set cmd.ActiveConnection = cn

     If MsgBox("削除してもよいですか", vbYesNo) = vbNo Then

         DoCmd.Close

     Else

    '  CN.BeginTrans

      With cmd

       .CommandText = "DELETE * FROM 行事Ｍ WHERE 行事ID = " & Me.行事ID & ""

       .CommandType = adCmdText

       .Execute

      End With

    ' CN.CommitTrans

      MsgBox "削除しました"

    End If