パスワード入力方法

If IsNull(Me.PW) Then Exit Sub

If Me.PW = "" Then Exit Sub

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

Dim a

rs.CursorLocation = adUseServer

rs.CursorType = adOpenStatic

rs.LockType = adLockOptimistic

rs.Open "SELECT * from PW ", conn, , , adCmdText

If rs.EOF Then Exit Sub

a = rs.Fields("認証")

If Me.PW = a Then

  

      DoCmd.OpenForm "サブメイン"

       

      DoCmd.Close acForm, "PW入力M"

Else

     MsgBox "パスワードが間違っています。"

Exit Sub

End If
パスワードの変更方法
 If IsNull(Me.登録) Then Exit Sub
If Me.登録 = "" Then Exit Sub
If IsNull(Me.認証) Then Exit Sub
If Me.認証 = "" Then Exit Sub
If IsNull(Me.新認証1) Then Exit Sub
If Me.新認証1 = "" Then Exit Sub
If IsNull(Me.新認証2) Then Exit Sub
If Me.新認証2 = "" Then Exit Sub

Dim cn As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim rs As New ADODB.Recordset
Dim rs2 As New ADODB.Recordset

Set cn = CurrentProject.Connection
Set cmd.ActiveConnection = cn
Dim a
Dim b
Dim c
rs.Open "SELECT * from 管理者", cn, , , adCmdText
If rs.EOF = True Then Exit Sub
a = rs.Fields("登録")
If Me.登録 <> a Then
MsgBox "管理者のパスワードが合ってません。"
Exit Sub
End If
rs2.Open "SELECT * from PW", cn, , , adCmdText
If rs2.EOF = True Then Exit Sub

' b = rs2.Fields("登録")
c = rs2.Fields("認証")

If Me.認証 <> c Then
MsgBox "現在のパスワードが合ってません。"
Exit Sub
End If

If Me.新認証1 <> Me.新認証2 Then
MsgBox "新しいのパスワードが合ってません。"
Exit Sub
End If
cn.BeginTrans
With cmd
.CommandText = "UPDATE PW SET 登録 = '" & Me.登録 & "',認証 = '" & Me.新認証2 & "'"
.CommandType = adCmdText
.Execute
End With
cn.CommitTrans
MsgBox "修正しました。"
cn.Close
 

アクセスの画面で、閉じる（X)　を　機能させない

 標準モジュールにAPI関数を作成

Public Declare Function GetSystemMenu Lib "user32" _

(ByVal hwnd As Long, ByVal bRevert As Long) As Long

Public Declare Function DeleteMenu Lib "user32" _

(ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

Public Declare Function DrawMenuBar Lib "user32" _

(ByVal hwnd As Long) As Long

Public Const MF_BYCOMMAND = &H0

Public Const SC_CLOSE = &HF060

実際のフオームのプロシジャーに作成

Private Sub Form_Load()

'フォーム読み込み時

Dim hMenu As Long

'システムメニューのハンドルを取得

hMenu = GetSystemMenu(Application.hWndAccessApp, 0)

'閉じるボタンを無効にする

DeleteMenu hMenu, SC_CLOSE, MF_BYCOMMAND

'メニューを再描画

DrawMenuBar Application.hWndAccessApp

End Sub
   

レコードセットを複数同時に使用して
動作させる時、競合、してオープン
できない場合の処理方法

Dim CN As ADODB.Connection

Dim rs As New ADODB.Recordset

Dim rs6 As New ADODB.Recordset

Dim rs7 As New ADODB.Recordset

Dim rs8 As New ADODB.Recordset

Dim cmd As New ADODB.Command

Set CN = CurrentProject.Connection

Set cmd.ActiveConnection = CNSet rs8 = New ADODB.Recordset

rs8.Open "SELECT last(ID) as ed from 一時売上 where 種類 = '" & 1 & "'", CN, , , adCmdText

I = rs8.Fields("ed")

'RS8　がオープンできない場合------ Set rs8　を入れると、解決する

Set rs8 = New ADODB.Recordset

rs8.Open "SELECT last(ID) as ed from 一時売上 where 種類 = '" & 1 & "'", CN, , , adCmdText

I = rs8.Fields("ed")

 
   

addnewを使用した登録方法

rs.CursorLocation = adUseServer

rs.CursorType = adOpenStatic

rs.LockType = adLockOptimistic

rs2.Open "SELECT 注文番号 from 受注オーダ WHERE 注文番号 = '" & a & "'", CN, , , adCmdText

If Not rs2.EOF Then

If rs2.Fields("注文番号").Value = a Then

MsgBox "登録済みです。"

Exit Sub

End If

End If

rs.Open "受注オーダ", CN, adOpenKeyset, adLockOptimistic, adCmdTableDirect

rs.AddNew

rs("注文番号") = Me![注文番号]

rs("受付日") = Me![受付日]

rs("お客様") = Me![お客様]

rs("店舗担当") = Me![店舗担当]

rs("取引先ｺｰﾄﾞ") = Me![取引先ｺｰﾄﾞ]

rs("型番") = Me![型番]

rs("部品名") = Me![部品名]

rs("オーダ数") = Me![オーダ数]

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

rs.Update

rs.Close

MsgBox "オーダ登録しました"

Me!注文番号.SetFocus

Me!注文番号.Text = ""

Me!部品名.SetFocus

Me!部品名.Text = ""		  

LIKE抽出のSQL文

rs2.Open "SELECT * from 受注オーダ WHERE (連絡 like '" & Me.連絡 & "%" & "')", CN, , , adCmdText

  

MDBで、クエリ抽出をEXCELに、
エキスポート

DoCmd.SetWarnings False

DoCmd.TransferSpreadsheet acExport, 8, "受注オーダ経理クエリ", "C:\経理データ.xls", True, ""

DoCmd.SetWarnings True

MsgBox "エクスポート完了"

  
   ADP(SQLserver接続）で、クエリ抽出をエキスポート
(ADP-専用）

DoCmd.SetWarnings False

DoCmd.OutputTo acOutputStoredProcedure, "EXEC [SP売掛オーダ抽出] '" & Me!開始日 & "','" & Me!終了日 & "'", acFormatXLS, C:

MsgBox "エクスポート完了"

（注意）　この場合、フォームに開始日と終了日のコントロールを設定し、ストアードプロシジャーにもパラメータを設定して置くこと

DoCmd.SetWarnings False

DoCmd.OutputTo acOutputServerView, "顧客データ抽出", acFormatXLS, C:

MsgBox "エクスポート完了"この場合、専用のビューを作成しておくこと

 		  
 

ＡＤＰで、ストアードプロシジャーに依頼して、
登録、更新などを実施する場合


(ADP-専用）

If IsNull(Me.伝票番号) Then Exit Sub

DoCmd.RunCommand acCmdSaveRecord

Dim conn As New ADODB.Connection

conn.ConnectionString = CurrentProject.BaseConnectionString

conn.Open

conn.BeginTrans

Dim cmd As New ADODB.Command

Set cmd.ActiveConnection = conn

With cmd

.CommandText = "update_受注オーダ_1"

.CommandType = adCmdStoredProc

.Parameters.Refresh

.Parameters(1) = Me.伝票番号

.Parameters(2) = Me.自社Ｓ

.Parameters(3) = Me.メーカＳ

.Parameters(4) = Me.運送会社2

.Parameters(5) = Me.運送伝票2

.Parameters(6) = Me.運送金額2

.Execute

End With

conn.CommitTrans

MsgBox "オーダ修正しました"

（注意）　パラメータの番号と、ストアプロシジャーのパラメータの番号が対応していること

  
 

DBがオートナンバーにしていない場合、最大値の抽出( ADP)

With cmd

.CommandText = "select MAX(子ID) from CTL子"

End With

Set rs3 = cmd.Execute("CTL子")

da = rs3.Fields(0).Value

da = da + 1

  
 

SQLserverと接続方法

(ADP-専用）

Dim con As New ADODB.Connection

Set con = New ADODB.Connection

con.ConnectionString = "Provider=SQLOLEDB;Data Source=SERVERAA;Initial Catalog=在庫;User ID=s040;Password=shop;Integrated Security = SSPI;"

con.Open

  
 

コンボボックスで、表示したくない項目を対象外にする方法----ＭＤＢ

まず、表示したくない項目の前に、％を付ける

　　例）　　担当者テーブル

　　　　　　　担当者ＩＤ(キー項目）------そのまま

　　　　　　　担当者名－－－　% 佐藤

  
 

コンボボックスで、表示したくない項目を対象外にする方法----ADP

まず、表示したくない項目の前に、*を付ける

　　例）　　担当者テーブル

　　　　　　　担当者ＩＤ(キー項目）------そのまま

　　　　　　　担当者名－－－　* 佐藤

  
 

コンボボックスのバリューリストの保存場所

Private Sub Form_Load()

Me.運送会社Ａ.RowSourceType = "Value List"

Me.運送会社Ａ.RowSource = "ヤマト運輸;佐川運輸"

End Sub

  
 

 do loop　の使用例

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

       rs.MoveFirst

   Do Until rs.EOF

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

    

    

     With cmd

       .CommandText = "UPDATE 入金元帳 SET 手形完 = '" & 2 & "' WHERE ＣＤ = " & x & ""

       .CommandType = adCmdText

       .Execute

      End With    

  

       rs.MoveNext

       Loop

    Forms!受取手形決済修正選択.Requery

  

       MsgBox "修正しました"

  
 

ダイヤログボックスを用いて、色々なフアイルを検出する

標準プロシジャーに設定

'【API宣言部】

Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

'pOpenFileName構造体(ユーザー定義型)の宣言

Type OPENFILENAME

lStructSize As Long '構造体のサイズ

hwndOwner As Long 'ダイアログを所有するウインドウハンドル

hInstance As Long 'アプリケーションインスタンス

lpstrFilter As String 'フィルタ

lpstrCustomFilter As Long 'ユーザ定義フィルタ

nMaxCustrFilter As Long 'ユーザ定義フィルタのバッファサイズ

nFilterIndex As Long 'デフォルトフィルタのインデックス

lpstrFile As String '選択されたファイル名

nMaxFile As Long 'ファイル名のバッファ

lpstrFileTitle As String '選択されたファイル名のタイトル

nMaxFileTitle As Long 'ファイル名のタイトルのバッファ

lpstrInitialDir As String '初期ディレクトリ

lpstrTitle As String 'ダイアログボックスのタイトル

Flags As Long 'オプション

nFileOffset As Integer 'ファイル名の最後の「\」までのオフセット値

nFileExtension As Integer '拡張子までのオフセット値

lpstrDefExt As String 'デフォルトの拡張子

lCustrData As Long 'OSがフック関数に渡すアプリ定義のデータ

lpfnHook As Long 'メッセージを処理するフック関数

' へのポインタ

lpTemplateName As Long

End Type

'定数宣言

'複数のファイルを選択可能に

Public Const OFN_ALLOWMULTISELECT = &H200 'ファイルが存在しなかった場合、新規作成するかどうか表示

Public Const OFN_CREATEPROMPT = &H2000 'エクスプローラ形式のダイアログを使用

Public Const OFN_EXPLORER = &H80000 '存在しないファイル名を入力不可に

Public Const OFN_FILEMUSTEXIST = &H1000

'「読み取り専用」チェックボックスを非表示

Public Const OFN_HIDEREADONLY = &H4 'カレントディレクトリをダイアログのカレントディレクトリにする

Public Const OFN_NOCHANGEDIR = &H8

Public Const OFN_NODEREFERENCELINKS = &H100000 'ネットワークコンピュータを非表示に

Public Const OFN_NONETWORKBUTTON = &H20000

Public Const OFN_NOREADONLYRETURN = &H8000

Public Const OFN_NOVALIDATE = &H100 'ファイルが存在していた場合、上書きを問い合わせる

Public Const OFN_OVERWRITEPROMPT = &H2 '有効なパス名のみを入力可能に

Public Const OFN_PATHMUSTEXIST = &H800 '「読み取り専用」チェックボックスをオンにする

Public Const OFN_READONLY = &H1 '「ヘルプ」ボタンの表示

Public Const OFN_SHOWHELP = &H10

'拡張子がデフォルトの拡張子と異なる場合に設定されるフラグ

Public Const OFN_EXTENSIONDIFFERENT = &H400

'【機能】

' コモンダイアログを表示し、選択ファイルのフルパスを取得

'【戻り値】

' 選択したファイルのフルパス文字列

Public Function GetFileName() As String

Dim pOpenfilename As OPENFILENAME

Dim lngRet As Long

'Accessアプリケーションのハンドルを取得

pOpenfilename.hwndOwner = Application.hWndAccessApp

pOpenfilename.hInstance = 0

'ファイルフィルタの設定

pOpenfilename.lpstrFilter = "全てのファイル (*.*)" & String(1, vbNullChar) & "*.*" & String(2, vbNullChar)

' pOpenfilename.lpstrFilter = "Accessファイル (*.mdb)" & String(1, vbNullChar) & "*.mdb" & String(2, vbNullChar)

pOpenfilename.lpstrCustomFilter = 0

pOpenfilename.nMaxCustrFilter = 0

pOpenfilename.nFilterIndex = 1

pOpenfilename.lpstrFile = String(511, vbNullChar)

pOpenfilename.nMaxFile = 511

pOpenfilename.lpstrFileTitle = String(512, vbNullChar)

pOpenfilename.nMaxFileTitle = 511

pOpenfilename.lpstrInitialDir = String(1, vbNullChar)

pOpenfilename.lpstrTitle = String(1, vbNullChar)

pOpenfilename.nFileOffset = 0

pOpenfilename.nFileExtension = 0

pOpenfilename.lpstrDefExt = String(1, vbNullChar)

pOpenfilename.lCustrData = 0

pOpenfilename.lpfnHook = 0

pOpenfilename.lpTemplateName = 0

pOpenfilename.lStructSize = Len(pOpenfilename)

'読取専用ファイルを隠す

pOpenfilename.Flags = OFN_HIDEREADONLY Or OFN_EXPLORER

lngRet = GetOpenFileName(pOpenfilename)

GetFileName = Left(pOpenfilename.lpstrFile, InStr(pOpenfilename.lpstrFile, vbNullChar) - 1)

End Function

フオームのボタンに書く

Private Sub コマンド2_Click()

Me.名前 = GetFileName

DoCmd.RunCommand acCmdFormView

End Sub

  
 

データ更新時アクセスから変なメッセイジがでる場合

下記のコードをプロシジャーの最初に入れておく

DoCmd.RunCommandacCmdSaveRecord

  
 

MDBと接続方法

 

Dim con As New ADODB.Connection

Set con = New ADODB.Connection

con.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=\\Serveraa\部品管理\部材管理DB.mdb"

  
 

MDBとの接続時、データソースをテーブル名より指定する場合

Dim z As String

'*********

   Dim rs5  As New ADODB.Recordset

   Dim rs6  As New ADODB.Recordset

   Dim rsx  As New ADODB.Recordset

 

   Dim cmd As New ADODB.Command

   Dim con2 As New ADODB.Connection

   Set con2 = CurrentProject.Connection

   Set cmd.ActiveConnection = con2

 

    Set rsx = New ADODB.Recordset

  

   

    rsx.Open "SELECT * from 対象 ", con2, , , adCmdText

    z = rsx.Fields("対象")

  

'*********

conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & z

conn.Open

  
 

ホルダー指定で、フアイルを検索する場合

標準プロシジャーに設定

Option Compare Database

Type BROWSEINFO

    hWndOwner As Long

    pidlRoot As Long

    pszDisplayName As String

    lpszTitle As String

    ulFlags As Long

    lpfn As Long

    lParam As Long

    iImage As Long

 End Type

Declare Function SHBrowseForFolder Lib "SHELL32" (lpbi As BROWSEINFO) As Long

Declare Function SHGetPathFromIDList Lib "SHELL32" (ByVal pIDL As Long, ByVal pszPath As String) As Long

Public Function GetBrowseFolder(strMsg As String) As String

'フォルダ参照ダイアログを表示し選択されたフォルダ名を返します。

'引数 strMsg : ダイアログに表示するメッセージ(例:"フォルダを指定して下さい")

'[キャンセル]ボタンやESCキーが押された場合は長さゼロ("")の文字列を返します。

    Dim udtBrowseInfo As BROWSEINFO

    Const cMaxPathLen = 256

    Dim strBuffer As String * cMaxPathLen

    Dim strPathBuffer As String * cMaxPathLen

    Dim strRetPath As String

    Dim lngRet As Long

 

    'BROWSEINFO構造体を定義します

    With udtBrowseInfo

        .hWndOwner = Application.hWndAccessApp

        .pidlRoot = 0

        .pszDisplayName = strBuffer

        .lpszTitle = strMsg & vbNullChar

        .ulFlags = 1

        .lpfn = 0

        .lParam = 0

        .iImage = 0

    End With

      GetBrowseFolder = ""  '返り値の初期設定を行います

    lngRet = SHBrowseForFolder(udtBrowseInfo)  'フォルダ参照ダイアログを表示します

    If lngRet <> 0 Then  'API関数の返り値をチェックします

 

        If SHGetPathFromIDList(lngRet, strPathBuffer) <> 0 Then

            '返り値にフォルダ名をセットします

            GetBrowseFolder = Left(strPathBuffer, InStr(strPathBuffer, vbNullChar) - 1)

        End If

   

    End If

End Function

  
 

ホルダー検索用のプロシジャー

Dim 保存先 As String

Me.先新 = GetBrowseFolder("保存先")

  
 

日付が入った時のupdate

  If IsNull(Me.登録日) = True Then a = "Null" Else a = "#" & Me.登録日 & "#"

  'If IsNull(Me.納品書日) = True Then f = "Null" Else f = "#" & Me.納品書日 & "#"

  If IsNull(Me.入金額) = True Then b = "0"

  If IsNull(Me.納入単価) = True Then c = "0"

  If IsNull(Me.金額) = True Then d = "0"

  If IsNull(Me.数量) = True Then e = "0"

 ' If IsNull(Me.発注日) = True Then g = "Null" Else g = "#" & Me.発注日 & "#"

  If IsNull(Me.納期) = True Then h = "Null" Else h = "#" & Me.納期 & "#"

  If IsNull(Me.支払日) = True Then j = "Null" Else j = "#" & Me.支払日 & "#"

  If IsNull(Me.締日) = True Then k = "Null" Else k = "#" & Me.締日 & "#"

  If IsNull(Me.入金日) = True Then m = "Null" Else m = "#" & Me.入金日 & "#"

  If IsNull(Me.出荷日) = True Then n = "Null" Else n = "#" & Me.出荷日 & "#"

 

     Dim strSQL1 As String

    

     strSQL1 = "UPDATE 受注 SET 製品図番 = '" & Me.製品図番 & "',品名 = '" & Me.品名 & "',納入単価 = '" & Me.納入単価 & "',"

     strSQL1 = strSQL1 & "入金額 = '" & Me.入金額 & "',備考 = '" & Me.備考 & "',依頼伝票番号 = " & Me.依頼伝票番号 & ","

     strSQL1 = strSQL1 & "出荷数 = " & Me.出荷数 & ",金額 = '" & Me.金額 & "',登録日 = " & a & ",完 = '" & Me.完 & "',出 = '" & Me.出 & "',"

     strSQL1 = strSQL1 & "大分類 = '" & Me.大分類 & "',出荷日 = " & n & ",入金日 = " & m & ",締日 = " & k & ",支払日 = " & j & ",納期 = " & h & ","

     strSQL1 = strSQL1 & "依頼伝票追番 = '" & Me.依頼伝票追番 & "',数量 = " & Me.数量 & ",売掛先ＣＤ = '" & Me.売掛先ＣＤ & "',売掛会社 = '" & Me.売掛会社 & "',依頼図番 = '" & Me.依頼図番 & "',"

     strSQL1 = strSQL1 & "区分ＣＤ = '" & Me.区分ＣＤ & "',詳細ＣＤ = '" & Me.詳細ＣＤ & "',場所 = '" & Me.場所 & "',材料ロット = '" & Me.材料ロット & "',"

     strSQL1 = strSQL1 & "内容 = '" & Me.内容 & "',表面処理 = '" & Me.表面処理 & "',材料ＣＤ = '" & Me.材料ＣＤ & "',"

     strSQL1 = strSQL1 & "材料名 = '" & Me.材料名 & "',内外 = '" & Me.内外 & "',依頼元ＣＤ = '" & Me.依頼元ＣＤ & "',搬入先ＣＤ = '" & Me.搬入先ＣＤ & "' WHERE 受注番号 = '" & Me.受注番号 & "'"

 

   cn.BeginTrans

    

      With cmd

       .CommandText = strSQL1

       .CommandType = adCmdText

       .Execute

      End With

 

   cn.CommitTrans

       MsgBox "修正しました"

  
 

リボンは隠す----メインフームのＬＯＡＤ

 'リボン非表示

    DoCmd.ShowToolbar "Ribbon", acToolbarNo

  'ナビゲーションウィンドウを非表示にする

    DoCmd.SelectObject acForm, "", True

  DoCmd.RunCommand acCmdWindowHide

この時、「Accessのオプション設定」の「カレントデータベース設定」に「リボンとツールバーのオプション」という設定があり、「組み込みツールバー」のチェックが入っていないと、このコードは効かない　（メニューバーが表示されたままになります）。

  
 

氏名で、　「姓　名」と「姓名」のダブリチエック機能

         Dim x

        Dim xx

        Dim y

        Dim yy

       

        Dim cn   As ADODB.Connection

        Dim rs   As New ADODB.Recordset

        Dim rs4   As New ADODB.Recordset

        Dim rs3   As New ADODB.Recordset

        Dim rs31   As New ADODB.Recordset

        Dim rs32   As New ADODB.Recordset

        Set cn = CurrentProject.Connection

    

       Set rs32 = New ADODB.Recordset

      rs32.Open "SELECT * from 過去帳 where 地区 = '" & Me.地区 & "'", cn, , , adCmdText

               

      If Not rs32.EOF Then

       rs32.MoveFirst

     Do Until rs32.EOF

        y = Replace(rs32.Fields("俗名"), " ", "")

        yy = Replace(Me.俗名, " ", "")

        If y = yy Then

          MsgBox "登録済です"

         Exit Sub

         End If

       rs32.MoveNext

    Loop

      

       Else

       End If

      Set rs3 = New ADODB.Recordset

      rs3.Open "SELECT * from 過去帳 where 地区 = '" & Me.地区 & "' and 俗名 = '" & Replace(Me.俗名, " ", "") & "'", cn, , , adCmdText

               

      If Not rs3.EOF Then

        x = Replace(rs3.Fields("俗名"), " ", "")

        xx = Replace(Me.俗名, " ", "")

        If x = xx Then

          MsgBox "登録済です"

         Exit Sub

         End If

       Else

       End If

      Set rs4 = New ADODB.Recordset

      rs4.Open "SELECT * from 過去帳 where 地区 = '" & Me.地区 & "' and 俗名 = '" & Me.俗名 & "'", cn, , , adCmdText

               

      If Not rs4.EOF Then

        If rs4.Fields("俗名") = Me.俗名 Then

          MsgBox "登録済です"

         Exit Sub

         End If

       Else

       End If

     

      Set rs31 = New ADODB.Recordset

      rs31.Open "SELECT * from 過去帳一時 where 地区 = '" & Me.地区 & "' and 俗名 = '" & Me.俗名 & "'", cn, , , adCmdText

               

      If Not rs31.EOF Then

        If rs31.Fields("俗名") = Me.俗名 Then

          MsgBox "入力済です"

         Exit Sub

         End If

       Else

       End If

  
 

印刷のキャンセル時

印刷のフラグを立てないようにする

  

      If rs2.EOF Then Exit Sub

         If Me.選択1 = "供養" Then

            DoCmd.OpenReport "案内書棚経", acPreview

         Else

        

            DoCmd.OpenReport "案内書", acPreview

         End If

          

          

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

        DoCmd.Close

   Else

      On Error GoTo ErrRtn

              DoCmd.RunCommand acCmdPrint

              DoCmd.Close

          Set rs31 = New ADODB.Recordset

    

        rs31.Open "SELECT * FROM 追善一時 where 確認 = yes ", cn, , , adCmdText

   

        If Not rs31.EOF Then

         rs31.MoveFirst

    

         Do Until rs31.EOF

           If rs31.Fields("印刷") = "0" Then

           B = "1"

           Else

           B = "2"

           End If

             With cmd

             .CommandText = "UPDATE 実施 SET 印刷 = '" & B & "' where 実施ID = " & rs31.Fields("実施ID") & ""

             .CommandType = adCmdText

             .Execute

              End With

             With cmd

             .CommandText = "UPDATE 追善一時 SET 印刷 = '" & B & "' where 追善ID = " & rs31.Fields("追善ID") & ""

             .CommandType = adCmdText

             .Execute

              End With

          

           rs31.MoveNext

        Loop

        Else

        End If

      Me.Form.Requery

   End If

     Me.Refresh

ErrRtn:

         DoCmd.Close acReport, "案内書棚経", acSaveNo

         DoCmd.Close acReport, "案内書", acSaveNo

  
 

ON ERROR GO TO の例

On Error GoTo ErrRtn

    DoCmd.Echo False

    DoCmd.SetWarnings False

        DoCmd.OpenQuery "3_Add(出荷テーブル)"

        DoCmd.OpenQuery "3_UpDate(受注テーブル)"

        DoCmd.OpenQuery "1_Delete(在庫)"

        DoCmd.OpenQuery "1_Add(在庫)"

    DoCmd.SetWarnings True

    DoCmd.Echo True

    MsgBox "登録しました"

    Exit Sub

ErrRtn:

    DoCmd.SetWarnings True

    DoCmd.Echo True

    MsgBox "登録できませんでした"

    Exit Sub

    Resume Next

  
 

和暦の例（Function側）

Public Function wareki(warekitosi As Variant, warekituki As Variant, warekihi As Variant) As Variant

   Dim B

     Dim c

     Dim D

     Dim x

     Dim cc

     Dim dd

     Dim y

   '  Dim warekitosi

   '  Dim warekituki

   '  Dim warekihi

    

     B = Date

     Dim cn As New ADODB.Connection

     Dim rs As ADODB.Recordset

     Set rs = New ADODB.Recordset

    

     Set cn = CurrentProject.Connection

 

      rs.CursorType = adOpenStatic

      rs.LockType = adLockOptimistic

      rs.LockType = adLockOptimistic

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

      If rs.EOF = True Then

      End If

   rs.MoveFirst

  Do Until rs.EOF

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

       c = rs.Fields("元号")

     rs.MoveNext

      If rs.EOF Then

      y = c

      Exit Do

      End If

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

       cc = rs.Fields("元号")

     If B >= D And B < dd Then

       y = c

     Exit Do

     End If

  Loop

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

    

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

   

  warekitosi = y & x & "年"

  warekituki = Format(B, "mm")

  warekihi = Format(B, "dd")

End Function

  
 

和暦の例（sub側）

Call wareki(warekitosi, warekituki, warekihi)

Call xwareki(xwarekitosi, xwarekituki, xwarekihi)

Call ywareki(ywarekitosi, ywarekituki, ywarekihi)

  Me.年.RowSourceType = "Value List"

'  D = Format(DateAdd("yyyy", -1, Date), "GGGEE年") & ";" & Format(Date, "GGGEE年") & ";" & Format(DateAdd("yyyy", 1, Date), "GGGEE年") & ";"

  D = xwarekitosi & ";" & warekitosi & ";" & ywarekitosi & ";"

  
 

 印刷プレビユー時のON ERROR GO TO の例

   Dim cnn As ADODB.Connection

   Dim rs As ADODB.Recordset

     Set cnn = CurrentProject.Connection

   Set rs = New ADODB.Recordset

   rs.Open "SELECT * from tmp_受注 where 選択 = True ", cnn, , , adCmdText

   

     If rs.EOF = True Then Exit Sub

    ARG = rs.Fields("見積番号")

 

         DoCmd.OpenReport "受注印刷再", acPreview

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

             DoCmd.Close

            Else

    On Error GoTo ErrRtn

         DoCmd.RunCommand acCmdPrint

              DoCmd.Close

   cnn.Execute "UPDATE 受注表 SET 印刷日='" & Format(Now(), "gee/mm/dd") & "' WHERE 見積番号='" & ARG & "' ;"

   cnn.Close: Set cnn = Nothing

        

   End If

ErrRtn:

         DoCmd.Close acReport, "受注印刷再", acSaveNo		  
 

リストボックスの選択対象の削除

Dim element

    For Each element In Me.一覧.ItemsSelected

        '選択解除

        Me.一覧.Selected(element) = False

    Next

  
 

時間を秒して保存

    Dim a

    Dim b

    Dim c As Long

    Dim d As Long

    Dim cc As Long

    Dim dd As Long

    Dim w As Long

    Dim x As Long

    Dim y As Long

    Dim z As Long

   

    Dim ww As Long

    Dim xx As Long

    Dim yy As Long

    Dim zz As Long

   

   

    Set cmd.ActiveConnection = cnn

    Set rs3 = New ADODB.Recordset

    Set rs2 = New ADODB.Recordset

 

   

    b = Me.一覧.Column(0)

    a = Format(Me.月度, "yyyy/mm")

   

    rs3.Open "SELECT KND_TANCOD,KND_SYUGYO,KND_KYUSYU from D_勤怠 where KND_TANCOD = " & Val(b) & "", cnn, , , adCmdText

    If rs3.EOF Then Exit Sub

   

      With cmd

       .CommandText = "DELETE * FROM 勤怠実績 WHERE 月度 = '" & Me.月度 & "' and 社員番号 = '" & b & "'"

       .CommandType = adCmdText

       .Execute

      End With

  

     rs3.MoveFirst

    

     ' Debug.Print Format(Nz(rs3.Fields("KND_SYUGYO"), 0), "h,n,s") ' "**:**:**" を　"**,**,**" に変換

   

   

    Do Until rs3.EOF

      

       Set rs4 = New ADODB.Recordset

       rs4.Open "SELECT * from 勤怠実績 where 月度 = '" & Me.月度 & "' and  社員番号 = '" & b & "'", cnn, , , adCmdText

                    

                     w = (Format(Nz(rs3.Fields("KND_SYUGYO"), 0), "h")) * 3600

                     x = (Format(Nz(rs3.Fields("KND_SYUGYO"), 0), "n")) * 60

                     y = (Format(Nz(rs3.Fields("KND_SYUGYO"), 0), "s"))

                     z = w + x + y

                     c = z

                    

                     ww = (Format(Nz(rs3.Fields("KND_KYUSYU"), 0), "h")) * 3600

                     xx = (Format(Nz(rs3.Fields("KND_KYUSYU"), 0), "n")) * 60

                     yy = (Format(Nz(rs3.Fields("KND_KYUSYU"), 0), "s"))

                     zz = ww + xx + yy

                     d = zz

      

      

       If rs4.EOF Then

       

        rs2.Open "勤怠実績", cnn, adOpenKeyset, adLockOptimistic, adCmdTableDirect

                  

        

        rs2.AddNew

        

        rs2("社員番号") = Trim(Str(rs3.Fields("KND_TANCOD")))

        rs2("月度") = Me.月度

        rs2("勤怠集計数") = c

        rs2("祭日勤怠数") = d

           rs2.Update

           rs2.Close

         Else

                  cc = c + rs4.Fields("勤怠集計数")

                  dd = d + rs4.Fields("祭日勤怠数")

                                 

                                  With cmd

                                  .CommandText = "UPDATE 勤怠実績 SET 勤怠集計数 = " & cc & ",祭日勤怠数 = " & dd & " WHERE 月度 = '" & Me.月度 & "' and 社員番号 = '" & rs4.Fields("社員番号") & "'"

                                  .CommandType = adCmdText

                                  .Execute

                                  End With

                                 

        End If

      rs3.MoveNext

    Loop

  
  秒単位の集計結果を [hh]:nn:ss 書式に変換するには

 標準モジュールに下記の関数を作成しておいて

Public Function Second2TimeStr(v As Long) As String

　　Dim t As Long

　　Second2TimeStr = Format(v Mod 60, "\:00")

　　t = v \ 60

　　Second2TimeStr = Format(t Mod 60, "\:00") & Second2TimeStr

　　t = t \ 60

　　Second2TimeStr = Format(t, "00") & Second2TimeStr

 End Function

 Second2TimeStr([集計値])

とします。

 集計値が160114秒なら、44:28:34 が返ります。

  
 

和暦より西暦へ

Ｐ側

   yss = Me.年月.Value & "01月01日"  ' 平成26年01月01日

      Call yzseireki(yss, ysa, ysb, ysc)

      y = Year(ysa & "/" & ysb & "/" & ysc)

    xss = Me.OpenArgs & "20日" ' H26年01月20日

      Call xzseireki(xss, xsa, xsb, xsc)

    yy = Year(xsa & "/" & xsb & "/" & 20)

   MM = Month(xsa & "/" & xsb & "/" & 20)

F側

Public Function xzseireki(xss As Variant, xsa As Variant, xsb As Variant, xsc As Variant) As Variant

   Dim b

     Dim c

     Dim d

     Dim x

     Dim cc

     Dim dd

     Dim y

     Dim xx As Long

     Dim yy As Long

     Dim zz As Long

    

     b = Left(xss, 1)

     zz = InStr(1, xss, "年")

    

     Dim cn As New ADODB.Connection

     Dim rs As ADODB.Recordset

     Set rs = New ADODB.Recordset

    

     Set cn = CurrentProject.Connection

 

      rs.CursorType = adOpenStatic

      rs.LockType = adLockOptimistic

      rs.LockType = adLockOptimistic

     rs.Open "SELECT * from 元号 where 略 = '" & b & "'", cn, , , adCmdText

      If Not rs.EOF = True Then

     

       d = rs.Fields("始年月日")

       c = rs.Fields("略")

    

       xx = Val(Left(d, 4))

    

     If zz = 3 Then

      yy = Val(Mid(xss, 2, 1))

      Else

      yy = Val(Mid(xss, 2, 2))

      End If

     

       x = Year(d) + yy - 1

    

   xsa = x

     If zz = 3 Then

      xsb = Mid(xss, 4, 2)

      xsc = Mid(xss, 7, 2)

    

      Else

      xsb = Mid(xss, 5, 2)

      xsc = Mid(xss, 8, 2)

     

      End If

 

 

 

 Else

 End If

End Function

Public Function yzseireki(yss As Variant, ysa As Variant, ysb As Variant, ysc As Variant) As Variant

   Dim b

     Dim c

     Dim d

     Dim x

     Dim cc

     Dim dd

     Dim y

     Dim xx As Long

     Dim yy As Long

     Dim zz As Long

    

     b = Left(yss, 2)

     zz = InStr(1, yss, "年")

    

     Dim cn As New ADODB.Connection

     Dim rs As ADODB.Recordset

     Set rs = New ADODB.Recordset

    

     Set cn = CurrentProject.Connection

 

      rs.CursorType = adOpenStatic

      rs.LockType = adLockOptimistic

      rs.LockType = adLockOptimistic

     rs.Open "SELECT * from 元号 where 元号 = '" & b & "'", cn, , , adCmdText

      If Not rs.EOF = True Then

     

       d = rs.Fields("始年月日")

       c = rs.Fields("元号")

    

       xx = Val(Left(d, 4))

    

     If zz = 4 Then

      yy = Val(Mid(yss, 3, 1))

      Else

      yy = Val(Mid(yss, 3, 2))

      End If

     

       x = Year(d) + yy - 1

    

   ysa = x

     If zz = 4 Then

      ysb = Mid(yss, 5, 2)

      ysc = Mid(yss, 8, 2)

    

      Else

      ysb = Mid(yss, 6, 2)

      ysc = Mid(yss, 9, 2)

     

      End If

 

 Else

 End If

End Function