「AccessVBA開発」カテゴリーアーカイブ

AccessVBA 標準モジュール⑨パブリック変数定義

Option Compare Database
‘*******************************************************
‘*
‘* フォーム間、値受け渡しの為、変数をpublicで定義
‘*
‘*******************************************************
Public strGenkahyou1 As String, strGenkahyou2 As String
Public taikaiDaimoku As String, taikaiSyuppinNen As String, taikaiSyuppinTuki As String, taikaiSakuseihi As String, taikaiPageNo As String
Public zeinukiGenka As String, zeikomiGenka As String
Public ShiireBi As String, TrihikisakiCode As String, TantoushaCode As String

AccessVBA 標準モジュール⑧FSOフォルダ・ファイル操作

Option Compare Database

Function BackUpFile(FolderPath, FileName)

‘***************フォルダ検索/ファイル検索/ファイルコピー********

‘バックアップ作成場所のフォルダのパスと新規ファイル名を受け取り、
‘フォルダが存在しなければ、新規でフォルダを作成し、カレントファイルをコピー。
‘(yyyymmdd_backup.accdb)
‘***************************************************************
On Error GoTo err_FsoCopy:

Dim MyFSO As New FileSystemObject

‘カレントデータベースのファイル名を取得(コピー元のファイル名)
Dim sFileName As String
sFileName = MyFSO.GetFileName(Application.CurrentDb.Name)

‘フォルダ存在確認
‘Dim FolderPath As String
If Not MyFSO.FolderExists(FolderPath) Then
MsgBox “フォルダが存在しないため、作成します。”
MyFSO.CreateFolder Path:=FolderPath

End If

‘ファイル存在確認
‘Dim FileName As String
FileName = FolderPath & “\” & FileName
If MyFSO.FileExists(FileName) Then
If MsgBox(“同じファイル名が存在します。上書きしますか?”, vbCritical + vbOKCancel) = vbCancel Then
MsgBox “バックアップ処理を中止します。”
BackUpFile = False
Set MyFSO = Nothing
Exit Function
Else
MyFSO.DeleteFile FileSpec:=FileName
End If
End If
‘ファイルコピー
MyFSO.CopyFile Source:=CurrentProject.Path & “\” & sFileName, Destination:=FileName
MsgBox “バックアップ完了しました。”
BackUpFile = True
‘終了処理
err_Exit:
Set MyFSO = Nothing
Exit Function

‘エラー処理
err_FsoCopy:
MsgBox Err.Description
Err.Clear
Resume err_Exit:

End Function

Sub ExcelExport(FolderPath, FileName, TableName)
‘***************テーブルをエクセルでエクスポート******************
‘FolderPath:出力先のパス
‘FileName :出力後のファイルネーム(.xlsx)
‘TableName :コピー元のテーブル名
‘*******************************************************
‘On Error GoTo err_FsoExcel:

Dim MyFSO As New FileSystemObject

‘フォルダ存在確認
If Not MyFSO.FolderExists(FolderPath) Then
MsgBox “フォルダが存在しないため、作成します。”
MyFSO.CreateFolder Path:=FolderPath
End If

‘ファイル存在確認
FileName = FolderPath & “\” & FileName
If MyFSO.FileExists(FileName) Then
If MsgBox(“同じファイル名が存在します。上書きしますか?”, vbCritical + vbOKCancel) = vbCancel Then
MsgBox “エクスポートを中止します。”
Set MyFSO = Nothing
Exit Sub
Else
MyFSO.DeleteFile FileSpec:=FileName
End If
End If
‘エクスポート
DoCmd.OutputTo acOutputTable, TableName, acFormatXLSX, FileName, True
MsgBox “エクセルファイルで出力しました。”

‘終了処理
err_Exit:
Set MyFSO = Nothing
Exit Sub

‘エラー処理
err_FsoExcel:
MsgBox Err.Description
Err.Clear
Resume err_Exit:

End Sub
Sub ExcelExport2(FolderPath, FileName, TableName)
‘***************クエリをエクセルでエクスポート******************
‘FolderPath:出力先のパス
‘FileName :出力後のファイルネーム(.xlsx)
‘TableName :コピー元のテーブル名
‘*******************************************************
‘On Error GoTo err_FsoExcel:

Dim MyFSO As New FileSystemObject

‘フォルダ存在確認
If Not MyFSO.FolderExists(FolderPath) Then
MsgBox “フォルダが存在しないため、作成します。”
MyFSO.CreateFolder Path:=FolderPath
End If

‘ファイル存在確認
FileName = FolderPath & “\” & FileName
If MyFSO.FileExists(FileName) Then
If MsgBox(“同じファイル名が存在します。上書きしますか?”, vbCritical + vbOKCancel) = vbCancel Then
MsgBox “エクスポートを中止します。”
Set MyFSO = Nothing
Exit Sub
Else
MyFSO.DeleteFile FileSpec:=FileName
End If
End If
‘エクスポート
DoCmd.OutputTo acOutputQuery, TableName, acFormatXLSX, FileName, True
MsgBox “エクセルファイルで出力しました。”

‘終了処理
err_Exit:
Set MyFSO = Nothing
Exit Sub

‘エラー処理
err_FsoExcel:
MsgBox Err.Description
Err.Clear
Resume err_Exit:

End Sub

AccessVBA 標準モジュール⑦画面設定

Option Compare Database
Sub リボン非表示()
‘リボン非表示
DoCmd.ShowToolbar “Ribbon”, acToolbarNo

‘ナビゲーションウィンドウを非表示にする
DoCmd.SelectObject acForm, “”, True
DoCmd.RunCommand acCmdWindowHide

End Sub

Sub リボン表示()
‘リボン表示
DoCmd.ShowToolbar “Ribbon”, acToolbarYes

‘ナビゲーションウィンドウを表示する
DoCmd.SelectObject acForm, “”, True
End Sub

AccessVBA 標準モジュール⑥外部ファイルを操作

Option Compare Database

Sub XLSExport(TableName, FilePath)
‘************************************************
‘エクセルファイルをエクスポートする
‘  TableName: エクスポート元のソースのテーブル
‘ FilePath :エクスポート先のエクセルファイルのパス+ファイル名

‘************************************************

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, TableName, FilePath
End Sub
Sub XLSInport(TableName, FilePath)
‘************************************************
‘エクセルファイルをインポートする
‘  TableName :インポート先のテーブル
‘ FilePath :インポート元のエクセルファイルのパス+ファイル名(先頭のワークシートを読み込む)
‘ True   :1行目をフィールド名とする
‘************************************************
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, TableName, FilePath, True
End Sub

AccessVBA 標準モジュール④フォーム成型

Option Compare Database
Sub FormSizeStandard()
DoCmd.MoveSize 1000, 500, 12000, 9000
End Sub

Sub FormSizeWide()
DoCmd.MoveSize 1000, 500, 20000, 9000
End Sub

Sub FormSizeSquare()
DoCmd.MoveSize 1000, 200, 12000, 12000
End Sub

Sub FormSizeWide2()
DoCmd.MoveSize 1000, 500, 14000, 10000
End Sub
Sub FormSizeSquare2()
DoCmd.MoveSize 1000, 200, 14000, 12000
End Sub
Sub FormSizeWide3()
DoCmd.MoveSize 1000, 200, 18000, 12000
End Sub
Sub FormSizeWide4()
DoCmd.MoveSize 1000, 200, 15000, 12000
End Sub
Sub FormSizeSmall1()
DoCmd.MoveSize 1000, 500, 5000, 9000
End Sub
Sub FormSizeSmall2()
DoCmd.MoveSize 1000, 500, 7000, 9000
End Sub
Sub FormSizeSmall3()
DoCmd.MoveSize 1000, 500, 7000, 11000
End Sub

AccessVBA 標準モジュール③テーブルデータ操作

Option Compare Database

‘/**********************************************************
‘/*
‘/*      テーブルデータ操作
‘/*
‘/**********************************************************

‘////////////////////////////////////////////テーブルのレコード追加
Sub AddNewRec(TableName)

‘データベース定義
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

Set cn = CurrentProject.Connection
Set rs = New ADODB.Recordset
‘レコードセットを開く
rs.Open TableName, cn, adOpenKeyset, adLockOptimistic

‘新規レコードに移動
DoCmd.GoToRecord acActiveDataObject, , acNewRec

End Sub

‘////////////////////////////////////////////テーブルの全データ消去
Sub TableClear(TableName)

On Error GoTo Err_TableClear
‘データベース、警告文の定義
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim Strmsg As String

Set cn = CurrentProject.Connection
Set rs = New ADODB.Recordset

rs.Open TableName, cn, adOpenKeyset, adLockOptimistic
Strmsg = rs.RecordCount & “件のレコードを削除します。”

‘テーブルのデータ全消去
If MsgBox(Strmsg, vbCritical + vbOKCancel) = vbOK Then
If rs.RecordCount > 0 Then
Do Until rs.EOF
rs.Delete
rs.MoveNext
Loop
MsgBox comMsg0002
End If
Else
MsgBox comMsg0013
End If
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing

Exit_TableClear:
Exit Sub
Err_TableClear:
MsgBox Err.Description
Resume Exit_TableClear
End Sub
‘////////////////////////////////////////////テーブルの特定データ消去(The Specific Data Erasure by the Table)
Sub SDET(TableName, Field, No)

On Error GoTo Err_SDET
‘データベース、警告文の定義
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

Set cn = CurrentProject.Connection
Set rs = New ADODB.Recordset

rs.Open TableName, cn, adOpenKeyset, adLockOptimistic

‘消去
If MsgBox(comMsg0005, vbCritical + vbOKCancel) = vbOK Then
If tbl.RecordCount > 0 Then
rs.MoveLast
rs.MoveFirst
Do
rs.Find “” & [Field] & ” ='” & No & “‘”
If Not rs.EOF Then
rs.Delete
rs.MoveNext
Else
Exit Do
End If
Loop
MsgBox comMsg0002
End If
Else
MsgBox comMsg0013
End If
rs.Close: Set rs = Nothing
cn.Close: Set sn = Nothing

Exit_SDET:
Exit Sub
Err_SDET:
MsgBox Err.Description
Resume Exit_SDET
End Sub

Sub TbCreate(TableName, FieldsSet)
‘///////////////////////新規テーブル作成(空のテーブル)///////////////////////////////////////
‘//
‘//  引数として、以下受け取る
‘//    ・「テーブル名」
‘//    ・「フィールド名1 データ型1,フィールド名2 データ型2,フィールド名3 データ型3,」
‘// 作成場所は、カレントデータベースとする
‘//
‘/////////////////////////////////////////////////////////////////////////////////////////////

‘ On Error GoTo エラー

‘ Dim db As DAO.Database
‘ Dim strSQL As String
‘ Set db = CurrentDb

‘ strSQL = “CREATE TABLE ” & TableName & ” (” & FieldsSet & “);”
‘ Debug.Print strSQL
‘ db.Execute strSQL

‘ db.Close: Set db = Nothing

‘ Exit Sub

‘エラー:
‘ MsgBox Err.Number & ” : ” & Err.Description
End Sub

AccessVBA 標準モジュール②参照ダイアログボックス表示

Option Compare Database

Public Function FDFolderPicker()
‘*********************************************
‘*  [参照] ダイアログ ボックス(フォルダ参照)
‘*********************************************
‘[参照] ダイアログ ボックスの FileDialog オブジェクトを作成します。
Dim fd As FileDialog

Set fd = Application.FileDialog(msoFileDialogFolderPicker)
‘選択した各アイテムのパスを保存す変数を宣言します。
Dim vrtSelectedItem As Variant

‘プロパティの設定
With fd
.Title = “フォルダ参照ダイアログ”

.InitialView = msoFileDialogViewDetails
.InitialFileName = “C:\”

‘[参照] ダイアログ ボックスを表示します。
If .Show = -1 Then
‘ユーザーがアクション ボタンをクリックした場合
For Each vrtSelectedItem In .SelectedItems
FDFolderPicker = vrtSelectedItem
Next vrtSelectedItem
Else
‘ユーザーが [キャンセル] をクリックした場合
End If
End With

‘オブジェクトの変数に Nothing を設定します。
Set fd = Nothing

End Function
Public Function FDFilePicker()
‘*********************************************
‘*  [参照] ダイアログ ボックス(ファイル参照)
‘*********************************************
‘[参照] ダイアログ ボックスの FileDialog オブジェクトを作成します。
Dim fd As FileDialog

Set fd = Application.FileDialog(msoFileDialogFilePicker)
‘選択した各アイテムのパスを保存す変数を宣言します。
Dim vrtSelectedItem As Variant

‘プロパティの設定
With fd
.Title = “サンプルダイアログ(ファイル参照)”
‘フィルターの設定
.Filters.Clear
.Filters.Add “テキスト”, “*.txt; *.csv”
.Filters.Add “エクセル”, “*.xls”
.Filters.Add “Access”, “*.mdb”
.Filters.Add “イメージ”, “*.gif; *.jpg; *.jpeg”
.Filters.Add “すべてのファイル”, “*.*”
.FilterIndex = 3

.InitialView = msoFileDialogViewDetails
.InitialFileName = CurrentProject.Path
.AllowMultiSelect = False

‘[参照] ダイアログ ボックスを表示します。
If .Show = -1 Then
‘ユーザーがアクション ボタンをクリックした場合
For Each vrtSelectedItem In .SelectedItems
FDFilePicker = vrtSelectedItem
Next vrtSelectedItem
Else
‘ユーザーが [キャンセル] をクリックした場合
End If
End With

‘オブジェクトの変数に Nothing を設定します。
Set fd = Nothing

End Function

AccessVBA 標準モジュール①共通メッセージ

Option Compare Database

‘/**********************************************************
‘/*
‘/*           共通メッセージ
‘/*
‘/**********************************************************
Public Const comMsg0001 As String = “登録しました。”
Public Const comMsg0002 As String = “削除しました。”
Public Const comMsg0003 As String = “内容が変更されています。閉じる前に登録しますか?”
Public Const comMsg0004 As String = “マスタを削除するとあらゆる処理で障害が発生しますが、よろしいですか?”
Public Const comMsg0005 As String = “削除してよろしいですか?”
Public Const comMsg0006 As String = “出力該当データはありません。”
Public Const comMsg0007 As String = “これ以前のコードはありません。”
Public Const comMsg0008 As String = “これ以後のコードはありません。”
Public Const comMsg0009 As String = “内容が変更されています。印刷前に登録しますか?”
Public Const comMsg0010 As String = “内容が変更されています。新規データに移動する前に登録しますか?”
Public Const comMsg0011 As String = “内容が変更されています。前データに移動する前に登録しますか?”
Public Const comMsg0012 As String = “内容が変更されています。後データに移動する前に登録しますか”
Public Const comMsg0013 As String = “処理を中止しました。”
Public Const comMsg0014 As String = “エラー発生処理は完了しておりません。”
Public Const comMsg0015 As String = “障害発生データは登録できませんでした。”
Public Const comMsg0016 As String = “障害発生データは削除できませんでした。”
Public Const comMsg0017 As String = “エクスポートを完了しました。”

‘/*共通メッセージ補助
Public Const cmdMsgtittle1 As String = “確認”
Public Const cmdMsgtittle2 As String = “エラー”

‘/*パスワード
‘管理者用(adomin)
Public Const adominPW As String = “password”
‘ユーザー用(user)
Public Const userPW As String = “user”

‘背景画像のファイルのパスを指定
Public Const BgImageDataPath As String = “c:\背景08.jpg”

ORDER BYで複数条件指定

「ORDER BY」で複数条件指定が可能

例1)

SELECT id, 会社名, 郵便番号, 住所,電話番号,メールアドレス FROM tb住所録 ORDER BY 氏名, 郵便番号

⇒先に氏名でソートされ、次に郵便番号でソートされる

例2)

SELECT id, 会社名, 郵便番号, 住所,電話番号,メールアドレス FROM tb住所録 ORDER BY 氏名 desc, 郵便番号

⇒個別にDESCやASCの指定も可能