DoEvents

’シートの全てをチェックして該当のシートがあるかチェックする

blnSuccess = False
For Each varCheckSheet In ThisWorkbook.Worksheets
'全てのシートを読み取る
If varCheckSheet.Name = strSelectSheet Then
'MsgBox (valCheckSheet.Name)
blnSuccess = True
End If
Next

’最終行チェック
lngEndrow0 = Worksheets(cnsTMASSETSHEETNAME).Cells(Rows.Count, "B").End(xlUp).Row '最終行調査

lngEndCol = ThisWorkbook.Worksheets(cnsLOTSHEETNAME).Cells(lngRow0, Columns.Count).End(xlToLeft).Column '最終列調査

’文字置換
a=Replace(varDEMC, " ", "")

'マッチシステム
lngRow = fncMatchRow(wkbBook, cnsDBSHEETNAME, strKey, "I:I") 'DBの行を検索



'マッチ
lngMatchRow = WorksheetFunction.Match(strKey, .Range(strRanges), 0)
'最大値
lngMax= WorksheetFunction.Max(.Range("A:A"))???

’データクリア
Sheets(strSheet).Select
Range("A4:G20000").Select
Selection.ClearContents

’エリアを選択してクリア (アドレス文字分解)
Set rngRange = Worksheets(strSheet).Range(strSheet & "!" & strAreaName) '名前のレンジ取り出し
strAddres = rngRange.EntireRow.Address '名前の列アドレス取り出し
varRow = Split(strAddres, ":") '行アドレスの分解
Sheets(strSheet).Select
Range(strCol & varRow(0) & ":" & strCol & varRow(1)).Select '指定列で名前行で範囲選択
Selection.ClearContents
'クリア
Cells.ClearContents '全クリア
’文字分解
verYouso = Split(strLot, "-")
If UBound(verYouso) > 0 Then

'コメントクリア
Selection.ClearComments

’塗り色調査
varColor = .Cells(i, j).Interior.Color

'塗りクリア
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With

’塗りグレー
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(200, 200, 200) 'グレー色
.TintAndShade = 0
.PatternTintAndShade = 0
End With

'塗り黄色にする
With Worksheets(cnsSYLKSHEETNAME).Range("E" & (i + lngStartRow - 1)).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = vbYellow '黄色
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'塗りピンク
With Worksheets(strSelectSheetName).Cells(i + 7 - 1, lngDate + 4 - 1).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(240, 120, 200) 'ピンク色
.TintAndShade = 0
.PatternTintAndShade = 0
End With
’塗り水色

With Worksheets(strSelectSheetName).Cells(i + 7 - 1, lngDate + 4 - 1).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(100, 200, 250) 'ブルー色
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'時間計測冒頭

Dim timDistanceTime
Dim timTimesend
Dim timTimesStart

timTimesStart = Time '時間計測開始

’速度アップ
Application.ScreenUpdating = False '画面表示off 'ver1.1.0 追加
Application.Calculation = xlCalculationManual '再計算OFF 'ver1.1.0 追加
Application.EnableEvents = False 'イベント抑制 'ver1.1.0 追加


Application.EnableEvents = True 'イベント活性 'ver1.1.0 追加
Application.Calculation = xlCalculationAutomatic '再計算ON 'ver1.1.0 追加
Application.ScreenUpdating = True '画面表示ON 'ver1.1.0 追加

’時間計測終了処理
timTimesend = Time
timDistanceTime = timTimesend - timTimesStart

MsgBox ("完了しました。時間は:" & Minute(timDistanceTime) & "分" & Second(timDistanceTime) & "秒 でした")


’ファイル存在チェック
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.fileExists(prmFolderPath & "\" & prmFilename) = False Then
'ファイルが無いエラーの場合

Else
'ファイルがある場合
blnFileExist = True


End If

'シート最大セルをチェックする
With Worksheets(cnsYOMISHEETNAME).Range("A1").SpecialCells(xlLastCell)
lngMaxRow = .Row '最大行
lngMaxCol = .Column '最大列
End With

’関数の挿入
strFormula = "=SUM(R[3]C:R[203]C)" '合計式セット

.Cells(lngRow0, lngCol0 + 1).Formula = strFormula '前月残合計式挿入
’列の選択
Columns("B:M").Select

’全選択
Cells.Select

'読み取り専用回避クローズ
Set wkbInput = Workbooks.Open(prmFolderPath & "\" & prmFilename, UpdateLinks:=0)
If wkbInput.ReadOnly = True Then
wkbInput.Close
MsgBox ("読み取り専用になっています。")
Exit Sub
End If

'大文字変換、半角変換
strHinban = StrConv(UCase(.Cells(cnsHINBANGYOU, j).Value), vbNarrow)





'リードオンリーでファイルを開く
Dim wkbInput As Workbook
Set wkbInput = Workbooks.Open(prmFolderPath & "\" & prmFilename, UpdateLinks:=0, ReadOnly:=True)


インプットボックス問い合わせ(キャンセルボタン拒否タイプ)
Dim strSign As String 'ver1.0.9 追加
Dim varSign As Variant 'ver1.1.1 追加
Do
'OKボタン押すまで逃がさない
varSign = Application.InputBox("チップ受取者の名前を入力してください。")

Loop While VarType(varSign) = vbBoolean
strSign = varSign

インプットボックス問い合わせ1
Dim buf As String
buf = Application.InputBox("名前を入力してください")
Select Case buf
Case "False"
MsgBox "キャンセルされました"
Case ""
MsgBox "空欄が入力されました"
Case Else
MsgBox buf & "が入力されました"
End Select


インプットボックス問い合わせ2
Dim buf As Variant
buf = Application.InputBox("名前を入力してください")
If VarType(buf) = vbBoolean Then
MsgBox "キャンセルされました"
Else
MsgBox buf & "が入力されました"
End If


’レンジによる大量の範囲選択

Dim rngRange As Range 'ver4.1.1 追加

For i = istart To iend Step istep '列指定
For j = jstart To jend Step jstep '行指定

strPageAct = Cells(j + 5, i + 13) 'ページ数表示位置を調べる

If strPageAct <> "" Then
'ページ番号があるページの場合
'ページエリアを指定して印刷する '

If rngRange Is Nothing Then 'ver4.1.1 変更

Set rngRange = Range(Cells(j, i), Cells(j + 37 - 1, i + 16 - 1)) 'ver4.1.1 変更
Else

Set rngRange = Union(rngRange, Range(Cells(j, i), Cells(j + 37 - 1, i + 16 - 1))) 'ver4.1.1 変更
End If


End If
Next
Next





'///////////////////////////////////////////////////////////////
' トラの巻集
'めんどくさい調べものを書き留める
'更新者:          、更新日:
'///////////////////////////////////////////////////////////////
ウインドウ枠
DoCmd.MoveSize , , 16000, 11500
DoCmd.MoveSize 1000, 1000, 15000, 11000 'ver1.2.0 追加
'       横位置,縦位置,横サイズ,縦サイズ


FileCopy "C:\Tmp\Test.txt", "C:\Work\Test.txt"

’重複レコードをまとめる時
SELECT DISTINCT 納入場所CD FROM dbo_T_納入場所名 WHERE 得意先CD=sr2_g_cmb得意先CD ORDER BY 納入場所CD;

フォームよりレコードを操作する

DoCmdオブジェクトのGoToRecordメソッドを使用してフォームよりレコードを操作する方法を説明します。

DoCmd.GotoRecord [,DataObjectType] [,ObjectName] [,AcRecord] [,Offset]

GoToRecordメソッドの引数は以下の通りです。引数を省略した場合は規定値が設定されます。
引数
説明
DataObjectType
対象となるオブジェクトを指定します。
acActiveDataObject
アクティブオブジェクト(規定値)
acDataForm
フォーム
acDataFunction
関数
acDataQuery
クエリ
acDataServerView
サーバービュー
acDataTable
テーブル
ObjectName
対象となるオブジェクトの名前を指定します。
AcRecord
移動の種類を指定します。
acNext
次のレコードへ移動
acPrevious
前のレコードへ移動
acFirst
先頭のレコードへ移動
acLast
最後のレコードへ移動
acGoto
指定したレコードへ移動
acNewRec
新規レコードへ移動
Offset
移動量を指定します。

Application.SetOption "Move After Enter", 0 'エンターキーで次に行かない
改行キーコントロール エンターキー
移動しない ; 0
次のフィールド(既定値) : 1
次のレコード : 2

Private Sub Form_Load()
'移動しない
'Application.SetOption "Move After Enter", 0
'次のフィールド
Application.SetOption "Move After Enter", 1
'次のレコード
'Application.SetOption "Move After Enter", 2

’文字置換
a=Replace(varDEMC, " ", "")

Sleep 2000 'スリープ

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_fncSearchWord
'| 引 数:
'| 戻り値:文字位置の何番目か表示 0は該当なし
'| 説 明:テーブルのフィールドを削除する処理
'| 履 歴:ver1.2.2 2019/08/09
'+--------------------------------------------------------------------------------+
Function sr2_f_fncSearchWord(sr2_h_strWord, sr2_h_strKey As String) As Long
'文字検索関数
'指定文字の指定KEYによる文字位置の検索
'左からの文字数を返す。
'検索出来なかった時は0を返す
'strWord:指定文字列
'strKey:検索キーとなる文字

On Error GoTo err1
'Err.Raise (2)
Dim sr2_h_lngMatchRow As Long
sr2_h_lngMatchRow = InStr(sr2_h_strWord, sr2_h_strKey)
sr2_f_fncSearchWord = sr2_h_lngMatchRow

Exit Function
err1:
'エラーの場合0を返す
sr2_f_fncSearchWord = 0
End Function

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_fncMatchRow
'| 引 数:
'| 戻り値:行列の何番目か表示 0は該当なし
'| 説 明:セルのマッチ処理
'| 履 歴:ver1.2.2 2019/08/09
'+--------------------------------------------------------------------------------+
Function sr2_f_fncMatchRow(wkb As Workbook, sr2_h_strSheetName, sr2_h_strKey, sr2_h_strRanges) As Long
'MATCH関数
'指定ファイルの指定KEYによる指定列のマッチを行う
'行番号を返す。
'検索出来なかった時は0を返す
'ver1.0.0 2017/02/07

On Error GoTo err1
Dim sr2_h_lngMatchRow As Long

With wkb.Worksheets(sr2_h_strSheetName)
sr2_h_lngMatchRow = WorksheetFunction.Match(sr2_h_strKey, .Range(sr2_h_strRanges), 0)
End With
sr2_f_fncMatchRow = sr2_h_lngMatchRow
Exit Function
err1:
'検索にヒットしない場合0を返す
sr2_f_fncMatchRow = 0
End Function





CurrentProject.Path 'カレントプロジェクトパス

テキストインポート
DoCmd.TransferText acImportFixed, "MMC03_MK5 インポート定義", "W_MMC03_MK5", sr2_h_strFileA1, False, ""

EXCELインポート
DoCmd.TransferSpreadsheet acImport, , "T_材料単価更新_取込wk", sr2_h_strSelectFile, True
'                   テーブル名       取り込みファイル名 インポートタイトルあり

DoCmd.Quit 'ACCESS終了

CurrentProject.Path

Trim() '両端のスペースカット
LTrim() '左トリム
RTrim() '右トリム
’スプリット分解
varRow = Split(strAddres, ":")
’文字分解
verYouso = Split(strLot, "-")
If UBound(verYouso) > 0 Then

DoCmd.OpenForm "F_出力条件入力画面" 'F_出力条件入力画面フォームを開く
DoCmd.OpenForm "F_現品票マスターメンテナンス表形式", acFormDS ’データシートビュー開く

’パスワードフォーム
Option Compare Database

Private Sub btn確定_Click()
sr2_h_PBPassword = Nz(txtPassword)
DoCmd.Close acForm, "F_PASSWORD", acSaveNo
End Sub

Private Sub Form_Load()
txtPassword.SetFocus
End Sub


Private Sub txtPassword_LostFocus()
sr2_h_PBPassword = Nz(txtPassword)
'DoCmd.Close acForm, "F_PASSWORD", acSaveNo
Me.Visible = False
End Sub



パスワードフォームに制御を渡す
sr2_h_PBPassword = ""
DoCmd.OpenForm "F_PASSWORD", , , , , acDialog 'F_PASSWORDフォームを開く
If sr2_h_PBPassword = "Dog18" Then

オプション

acQuitPrompt・・・保存してない場合は確認のダイアログを表示する(デフォルト)
acQuitSaveAll・・・自動的に保存
acQuitSaveNone・・・保存せず終了

DoCmd.OpenForm "F_履歴TB" '履歴一覧フォームを開く

Me.chkDel = True

DoCmd.Close '閉じる
DoCmd.Close acForm, "F_履歴TB" '閉じる

[Forms]![F_削除画面].Refresh
me.Refresh

'履歴削除更新
DoCmd.SetWarnings False
DoCmd.OpenQuery "Q_履歴削除更新条件", acNormal, acEdit 'Q_履歴削除更新条件
DoCmd.SetWarnings True

Me![F_削除のサブフォーム].Form.Requery

txt数量.Enabled = True

DoCmd.OpenQuery "Q_出力条件", acNormal, acEdit 'Q_出力条件
DoCmd.Requery

'ver1.2.2 追加 ***************************************************
'項目削除フィールド削除
If sr2_f_DELField("T_取り込み2WK", "No") = True Then
'特定フィールドが存在する場合
'特定フィールドの削除
CurrentDb().TableDefs("T_取り込み2WK").Fields.Delete ("No")
End If
'******************************************************************

’テーブル作成 オートナンバー付き
"CREATE TABLE T_取り込みWK (No Counter(1, 1), Flg TEXT "

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_DELField
'| 引 数:sr2_h_strTableName:テーブル名 sr2_h_strFieldName:削除フィールド名
'| 戻り値:
'| 説 明:テーブルのフィールドを削除する処理
'| 履 歴:ver1.2.2 2019/08/09
'+--------------------------------------------------------------------------------+
Public Function sr2_f_DELField(sr2_h_strTableName As String, sr2_h_strFieldName As String) As Boolean

On Error GoTo ErrHandler

CurrentDb.TableDefs(sr2_h_strTableName).Fields.Delete sr2_h_strFieldName 'フィールド削除

On Error GoTo 0

Exit Function

ErrHandler:
Select Case Err.Number
Case 3265
MsgBox "フィールドはありません。"
Case Else
MsgBox Err.Number & ":" & Err.Description
End Select
On Error GoTo 0
End Function


Dim rs As New ADODB.Recordset
Dim strSQL As String

strSQL = "select オーダ,出荷品番,削除 from T_削除処理SUB where " & _
" 削除 = true;"

rs.Open strSQL, CurrentProject.Connection

'削除処理SUB削除




DoCmd.RunSQL "DELETE * FROM T_削除処理SUB where 削除 = true;"


Dim dB As DAO.Database
Set dB = CurrentDb()
'T_出力タイプグループWKクリア
dB.xecute "DELETE * From T_出力タイプグEループWK;"

CurrentDb().execute "DELETE * From T_出力タイプグEループWK;"

'最前面にポップアップを出す
MsgBox "完了しました。", vbInformation + vbOKOnly + vbSystemModal

サブフォームコントロールレコード番号

Forms!フォーム1!サブフォーム1.Form.CurrentRecord

で取得できます。
(「Forms」と「Form」がありますのでご注意下さい)


また、フォーム1にコードを記述する場合であれば

Me!サブフォーム1.Form.CurrentRecord

サブフォーム1へのコード記述であれば

Me.CurrentRecord

ACCESS引数渡し

"C:\Program Files\Microsoft Office\Office11\Samples\Northwind.mdb" /cmd "Orders"

Public Sub CheckCommandLine()
' Check the value returned by Command function and display
' the appropriate form.
If Command = "Orders" Then
DoCmd.OpenForm "Orders"
ElseIf Command = "Employees" Then
DoCmd.OpenForm "Employees"
Else
Exit Sub
End If
End Sub


Dim strPath As String
strPath = "c:\Users\PA7C00\Desktop\10-16-01.csv"

Dim i As Long
Dim j As Long
Dim strLine As String
Dim arrLine As Variant 'カンマでsplitして格納

Open strPath For Input As #1 'csvファイルをオープン

i = 1
Do Until EOF(1)
'データが無くなるまで繰り返す。

Line Input #1, strLine '1行読み取り

arrLine = Split(Replace(fncReplaceColon(strLine), """", ""), ";") 'strLineをセミコロンで区切りarrLineに格納

For j = 0 To UBound(arrLine)
'データを吐き出す。
ws.Cells(i, j + 1).Value = arrLine(j)
Next j
i = i + 1
Loop

Close #1
マクロ設定---------------------------------------------------
作成→マクロ
新しいアクションの追加で「プロシージャの実行」を選択する
プロシージャ名に「AutoExec()」を入力
マクロを「AutoExec」という名前で保存

'-----------------------------------------------------------
'起動時に自動起動するマクロ
'-----------------------------------------------------------
Function AutoExec() As Integer
If Command = "状態" Then
'MsgBox Command
'パラメータが状態の場合
DoCmd.OpenForm "F_出力条件入力画面_状態" '状態フォームを開く
ElseIf Command = "履歴" Then
'MsgBox Command
'パラメータが履歴の場合
DoCmd.OpenForm "F_出力条件入力画面" '履歴フォームを開く
Else
'パラメータが上以外の場合
Exit Function
End If

End Function

'NOの変更(IDはオートナンバー)
strSQL = "UPDATE T_出荷加工処理SUB " & _
" SET T_出荷加工処理SUB.[] = DCount('[ID]','T_出荷加工処理SUB','[ID]<=' & [T_出荷加工処理SUB]![ID]);"
DoCmd.RunSQL strSQL

'ファイル名マスタの読み込み
V_FilePath = DLookup("[パス名]", "[T_ファイル名マスタ]", "[ID] = '06' ")
DLookup("金額","商品マスターtbl","コード='" & [コード] & "' AND [No]=" & [No])

Shell "MSAccess.exe /runtime " & "C:\CommonWork\access_data\" & namex, vbMaximizedFocus


Private Sub Form_Open(Cancel As Integer)
If sr2_h_PBstr履歴一覧レコード処理時間 <> "" Then

[Forms]![F_履歴TB].RecordSource = "SELECT * FROM dbo_T_日野577トレサ_履歴TB " & _
" WHERE 処理日 = '" & [Forms]![F_削除画面]![txtDate] & "' AND " & _
" PC名 = '" & [Forms]![F_削除画面]![txtPC名] & "' AND " & _
" 状態 = '" & [Forms]![F_削除画面]![cmb状態選択] & "' AND " & _
" 処理時間 = '" & sr2_h_PBstr履歴一覧レコード処理時間 & "' ;"

Else
[Forms]![F_履歴TB].RecordSource = "SELECT * FROM dbo_T_日野577トレサ_履歴TB " & _
" WHERE 処理日 = '" & [Forms]![F_削除画面]![txtDate] & "' AND " & _
" PC名 = '" & [Forms]![F_削除画面]![txtPC名] & "' AND " & _
" 状態 = '削除' ;"

End If

Me.Refresh
End Sub


Private Sub Form_Load()
Dim db As DAO.Database
Dim rs As DAO.Recordset

'Get the database and Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("T_工場決定")

If rs.EOF = False Then

Me.sr2_g_txt工場CD = rs!工場CD
Me.sr2_g_txt工場名 = rs!工場名
Me.sr2_g_txt現品票タイプ = rs!現品票オプションCD

rs.Close
End If
Set rs = Nothing
Set cn = Nothing

End Sub


Dim strSQL As String
Dim rs As New ADODB.Recordset



rs.Open strSQL, CurrentProject.Connection

If rs.EOF = False Then
'txtTPV品番 = rs!TPV品番 'TPV品番確定


'ver1.1.0 追加 *************************************************************
'-----------------------------------------------------
'スリム品番関数
'品番から余分な装飾を削る関数
'クエリ用
'strH:品番
'返値:スリム品番
'-----------------------------------------------------
Public Function sr2_f_fncスリム品番(strH As Variant) As Variant

sr2_f_fncスリム品番 = Replace(Replace(StrConv(UCase(strH), vbNarrow), " ", ""), "-", "")

End Function
'*****************************************************************************


'-----------------------------------------------------
'編集項目の両端のスペースカットし、半角大文字化するマクロ
'-----------------------------------------------------
Private Sub sr2_s_subTrim_編集項目()
Me.txtTPV品番 = Replace(StrConv(UCase(Trim(Me.txtTPV品番)), vbNarrow), " ", "-")
Me.txt客先品番 = Replace(StrConv(UCase(Trim(Me.txt客先品番)), vbNarrow), " ", "-")
Me.txt品名 = StrConv(UCase(Trim(Me.txt品名)), vbNarrow)
Me.txt客先名 = StrConv(UCase(Trim(Me.txt客先名)), vbNarrow)
Me.Refresh
End Sub

Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
'Private Const SND_SYNC = &H0 ‘同期再生
'Private Const SND_ASYNC = &H1 ‘非同期再生
'Private Const SND_LOOP = &H8 ‘繰り返し再生
'Private Const SND_PURGE = &H40 ‘停止
'-----------------------------------------------------
'サウンドマクロ
'-----------------------------------------------------
Public Sub sr2_s_subSound()
Call PlaySound("\ピンポン.wav", 0, &H0)
End Sub


'-----------------------------------------------------
'レコードのカウントを算出するマクロ
'-----------------------------------------------------
Public Sub sr2_s_subレコードカウント()

OrdersCount = DCount("[オーダ]", "Q_削除サブo")

[Forms]![F_削除画面]![txtカウンター] = OrdersCount

End Sub

'-----------------------------------------------------
'キーエンターキーを抑制するなどマクロ
’注意KeyPressでは改行を読めない
'-----------------------------------------------------
Private Sub aatxtQR2_KeyDown(KeyCode As Integer, Shift As Integer)
Const cnsMAX_LENGTH As Long = 40 '40’制限文字数
Dim sr2_h_lngAns As Long

'改行を抑止
'If KeyAscii = vbKeyReturn Then
If KeyCode = vbKeyReturn Then
KeyCode = 0
End If


'S/N:をキーに前データを削除 多行バージョン対策
sr2_h_lngAns = InStr(txtQR2.Text, "S/N:")
If sr2_h_lngAns <= 0 Then

Else
txtQR2 = ""

End If

If sr2_f_キープレス制約(txtQR2, KeyCode, cnsMAX_LENGTH) = True Then '制限文字数
'文字数オーバー
lblメッセージ.Caption = "入力オーバー"
Else
'lblメッセージ.caption = ""
End If

End Sub

'-----------------------------------------------------
'キープレス制約関数大文字
'テキストボックスの文字数を制約するマクロ
'sr2_h_TextBox:テキストボックス
'KeyAscii:キー
'sr2_h_Maxlength:最大数
'KeyAscii:返値キー
'返値:true:制約あり false:制約なし
'-----------------------------------------------------
Public Function sr2_f_キープレス制約_英数字大文字(sr2_h_TextBox As Object, KeyAscii As Integer, sr2_h_Maxlength As Long) As Boolean
If Len(sr2_h_TextBox.text) >= sr2_h_Maxlength And sr2_h_TextBox.SelLength = 0 Then
'文字数制限
Select Case KeyAscii
Case vbKeyBack, vbKeyReturn
Case Else
'バックスペース、エンターキー以外


KeyAscii = 0
sr2_f_キープレス制約_英数字大文字 = True '制約フラグON

End Select
Else
'MsgBox KeyAscii
Select Case KeyAscii
Case vbKeyBack, vbKeyReturn
Case Else
'バックスペース、エンターキー以外
If KeyAscii >= &H30 And KeyAscii <= &H39 Then
'数字ならば受け入れる
ElseIf KeyAscii >= &H40 And KeyAscii <= &H5F Then
'英大文字なら受け入れる
ElseIf KeyAscii >= &H60 And KeyAscii <= &H7E Then
'英小文字なら受け入れる
'英大文字に変換
KeyAscii = KeyAscii - &H20

ElseIf KeyAscii >= &H20 And KeyAscii <= &H2F Then
'英記号なら受け入れる

Else
'数字以外なら受け入れない
KeyAscii = 0
'数字sr2_f_キープレス制約_数字 = True '制約フラグON

End If

End Select
End If
End Function

'-----------------------------------------------------
'キープレス制約関数
'テキストボックスの文字数を制約するマクロ
'sr2_h_TextBox:テキストボックス
'KeyAscii:キー
'sr2_h_Maxlength:最大数
'KeyAscii:返値キー
'返値:true:制約あり false:制約なし
'-----------------------------------------------------
Public Function sr2_f_キープレス制約_数字(sr2_h_TextBox As Object, KeyAscii As Integer, sr2_h_Maxlength As Long) As Boolean
If Len(sr2_h_TextBox.Text) >= sr2_h_Maxlength And sr2_h_TextBox.SelLength = 0 Then
'文字数制限
Select Case KeyAscii
Case vbKeyBack, vbKeyReturn
Case Else
'バックスペース、エンターキー以外


KeyAscii = 0
sr2_f_キープレス制約_数字 = True '制約フラグON

End Select
Else
'MsgBox KeyAscii
Select Case KeyAscii
Case vbKeyBack, vbKeyReturn
Case Else
'バックスペース、エンターキー以外
If KeyAscii >= &H30 And KeyAscii <= &H39 Then
'数字ならば受け入れる
Else
'数字以外なら受け入れない
KeyAscii = 0
'数字sr2_f_キープレス制約_数字 = True '制約フラグON

End If

End Select
End If
End Function

'-----------------------------------------------------
'キープレス制約関数
'テキストボックスの文字数を制約するマクロ
'sr2_h_TextBox:テキストボックス
'KeyAscii:キー
'sr2_h_Maxlength:最大数
'KeyAscii:返値キー
'返値:true:制約あり false:制約なし
'-----------------------------------------------------
Public Function sr2_f_キープレス制約_日付(sr2_h_TextBox As Object, KeyAscii As Integer, sr2_h_Maxlength As Long) As Boolean
Dim sr2_h_lngLen As Long

sr2_h_lngLen = Len(sr2_h_TextBox.Text)

If Len(sr2_h_TextBox.Text) >= sr2_h_Maxlength And sr2_h_TextBox.SelLength = 0 Then

'文字数制限
Select Case KeyAscii
Case vbKeyBack, vbKeyReturn
Case Else
'バックスペース、エンターキー以外


KeyAscii = 0
sr2_f_キープレス制約_日付 = True '制約フラグON

End Select
Else
'MsgBox KeyAscii
Select Case KeyAscii
Case vbKeyBack, vbKeyReturn
Case Else
'バックスペース、エンターキー以外
If KeyAscii >= &H30 And KeyAscii <= &H39 Then
'数字ならば受け入れる
ElseIf KeyAscii = &H2F Then
'/ならば受け入れる
Else
'数字以外なら受け入れない
KeyAscii = 0
'数字sr2_f_キープレス制約_数字 = True '制約フラグON

End If

End Select
End If
End Function

'-----------------------------------------------------
'キープレス制約関数
'テキストボックスの文字数を制約するマクロ
'sr2_h_TextBox:テキストボックス
'KeyAscii:キー
'sr2_h_Maxlength:最大数
'KeyAscii:返値キー
'返値:true:制約あり false:制約なし
'-----------------------------------------------------
Public Function sr2_f_キープレス制約_日付(sr2_h_TextBox As Object, KeyAscii As Integer, sr2_h_Maxlength As Long) As Boolean
Dim sr2_h_lngLen As Long

sr2_h_lngLen = Len(sr2_h_TextBox.Text)

If Len(sr2_h_TextBox.Text) >= sr2_h_Maxlength And sr2_h_TextBox.SelLength = 0 Then

'文字数制限
Select Case KeyAscii
Case vbKeyBack, vbKeyReturn
Case Else
'バックスペース、エンターキー以外


KeyAscii = 0
sr2_f_キープレス制約_日付 = True '制約フラグON

End Select
Else
'MsgBox KeyAscii
Select Case KeyAscii
Case vbKeyBack, vbKeyReturn
Case Else
'バックスペース、エンターキー以外
If Not (sr2_h_lngLen = 4 Or sr2_h_lngLen = 7) And KeyAscii >= &H30 And KeyAscii <= &H39 Then
'数字ならば受け入れる
If sr2_h_lngLen = 0 And KeyAscii <> &H32 Then
'頭が2以外ならば受け入れない
KeyAscii = 0
ElseIf sr2_h_lngLen = 5 And KeyAscii <> &H30 And KeyAscii <> &H31 Then
'5文字目が0,1以外ならば受け入れない
KeyAscii = 0
ElseIf sr2_h_lngLen = 8 And KeyAscii <> &H30 And KeyAscii <> &H31 And KeyAscii <> &H32 And KeyAscii <> &H33 Then
'8文字目が0,1,2,3以外ならば受け入れない
KeyAscii = 0
End If
ElseIf (sr2_h_lngLen = 4 Or sr2_h_lngLen = 7) And KeyAscii = &H2F Then
'4文字の次、7文字の次が/ならば受け入れる
Else
'数字以外なら受け入れない
KeyAscii = 0
'数字sr2_f_キープレス制約_数字 = True '制約フラグON

End If

End Select
End If
End Function

'-----------------------------------------------------
'PC名、ユーザー名を調べる関数
'返値
'strUserName:ユーザー名
'strPCName:PC名
'-----------------------------------------------------
Public Sub sr2_f_fncUSERID_PCNAME(strUserName As String, strPCName As String)

Dim sr2_h_objObject As Object

Set sr2_h_objObject = CreateObject("WScript.Network")

With sr2_h_objObject
'MsgBox "ユーザー名: " & .UserName & vbCrLf _
& "コンピュータ名: " & .ComputerName
strUserName = .UserName
strPCName = .ComputerName
End With

Set sr2_h_objObject = Nothing
End Sub

'-----------------------------------------------------
'小文字を大文字に変換する関数
'strMoji:文字
'返値:大文字化文字
'-----------------------------------------------------
Public Function sr2_f_fnc大文字化(varMoji As Variant) As Variant

sr2_f_fnc大文字化 = StrConv(UCase(varMoji), vbNarrow)

End Function

'-----------------------------------------------------
' txtQR2キープレスの処理マクロ
'-----------------------------------------------------
Private Sub txtQR2_KeyPress(KeyAscii As Integer)

Const cnsMAX_LENGTH As Long = 40 '40’制限文字数
Dim sr2_h_lngAns As Long

'多改行を抑止
If KeyAscii = vbKeyReturn Then
KeyAscii = 0
End If


'S/N:をキーに前データを削除 多行バージョン対策
sr2_h_lngAns = InStr(txtQR2.Text, "S/N:")
If sr2_h_lngAns <= 0 Then

Else
txtQR2 = ""

End If

If sr2_f_キープレス制約(txtQR2, KeyAscii, cnsMAX_LENGTH) = True Then '制限文字数
'文字数オーバー
lblメッセージ.Caption = "入力オーバー"
Else
'lblメッセージ.caption = ""
End If
End Sub



'-----------------------------------------------------
'txt数量キープレスの処理マクロ
'-----------------------------------------------------
Private Sub txt数量_KeyPress(KeyAscii As Integer)
Dim sr2_h_strChr As String

Const cnsMAX_LENGTH As Long = 5 '制限文字数
sr2_h_strChr = Chr(KeyAscii) 'Chr(KeyAscii)


'数値限定
If sr2_h_strChr >= "0" And sr2_h_strChr <= "9" Or KeyAscii = vbKeyBack Then
If Len(txt数量.Text) = 0 And sr2_h_strChr = "0" Then
'データが0の場合
KeyAscii = 0

Else

'数字、バックスペースの場合
If sr2_f_キープレス制約(txt数量, KeyAscii, cnsMAX_LENGTH) = True Then '制限文字数
lblメッセージ.Caption = "入力オーバー"
Else
lblメッセージ.Caption = ""
End If
End If
Else
'数字、バックスペース以外の場合
KeyAscii = 0
End If

End Sub


'-----------------------------------------------------
'txtQR2控えに飛んだ場合の処理マクロ
'-----------------------------------------------------
Private Sub txtQR2控え_GotFocus()
'強制的にフォーカスを戻す
On Error Resume Next
'エラー時は無視する。他イベントでフォーカスが被る為

Me.txtQR2.SetFocus '強制的にフォーカスを戻す
On Error GoTo 0

End Sub

'-----------------------------------------------------
'出荷日更新後の処理マクロ
'-----------------------------------------------------
Private Sub txt出荷日_AfterUpdate()

txt出荷日 = Replace(txt出荷日, "/", "") '/を取り除く
txt出荷日 = Replace(txt出荷日, "-", "") '-を取り除く

End Sub

'-----------------------------------------------------
'キープレス制約関数
'テキストボックスの文字数を制約するマクロ
'sr2_h_TextBox:テキストボックス
'KeyAscii:キー
'sr2_h_Maxlength:最大数
'KeyAscii:返値キー
'返値:true:制約あり false:制約なし
'-----------------------------------------------------
Private Function sr2_f_キープレス制約(sr2_h_TextBox As Object, KeyAscii As Integer, sr2_h_Maxlength As Long) As Boolean
If Len(sr2_h_TextBox.Text) >= sr2_h_Maxlength And sr2_h_TextBox.SelLength = 0 Then
'文字数制限
Select Case KeyAscii
Case vbKeyBack, vbKeyReturn
Case Else
'バックスペース、エンターキー以外
KeyAscii = 0
sr2_f_キープレス制約 = True '制約フラグON

End Select
End If
End Function

'-----------------------------------------------------
'バックカラー変更関数フォーカスが当たった時
'テキストボックスのバックカラーを黄色にするマクロ
'objOBJ:テキストボックス
'-----------------------------------------------------
Private Sub sr2_s_subGotFocus(objOBJ As Object)
objOBJ.BackColor = vbYellow 'RGB(250, 250, 0) '黄色
End Sub

'-----------------------------------------------------
'バックカラー変更関数フォーカスをロスした時
'テキストボックスのバックカラーを白色にするマクロ
'objOBJ:テキストボックス
'-----------------------------------------------------
Private Sub sr2_s_subLostFocus(objOBJ As Object)
objOBJ.BackColor = vbWhite '白色
End Sub



'-----------------------------------------------------
'ファイルダイアログ
'-----------------------------------------------------
Private Sub コマンド143_Click()
a = GetOpenDialogFile("c:\", strInName, strTitle)
MsgBox (a)

End Sub

'-----------------------------------------------------
'チェック項目3する関数
'重複データチェック
'返値:false:重複がない
'   true:重複がある
'-----------------------------------------------------
Private Function sr2_f_fncチェック項目3() As Boolean

Dim cnt As Variant


If cnt > 0 Then
'重複がある
sr2_f_fncチェック項目3 = True
Else
'重複がない
sr2_f_fncチェック項目3 = False
End If

End Function

’シリアルナンバー作成(ID2が数値でしか対象とならない注意)
SN: DCount('[ID2]','Q_出力クエリ','[ID2]<=' & [ID2])
'--------------------------------------------
---------
'コンボ出荷品番変化後の処理マクロ
'-----------------------------------------------------
Private Sub cmb出荷品番_AfterUpdate()


txt出荷品名 = cmb出荷品番.Column(1) '出荷品番から出荷品名セット
txt得意先 = cmb出荷品番.Column(2) '出荷品番から得意先セット
txtTPV品番 = cmb出荷品番.Column(3) '出荷品番からTPV品番セット

txt出荷品名.Enabled = False
txt得意先.Enabled = False
txtTPV品番.Enabled = False
txtQR2.Enabled = True
'Me.Refresh

'txtQR2.SetFocus
Me.Refresh
End Sub

Format(Time(),"hh:nn:ss")
Format(Date(),"yyyy/mm/dd")






'////////////////////////////////////////////////////////////////////////////////////////////////////
'
' AccessクエリからEXCELファイルを生成する
'
' ※列幅を自動調整する機能付き
' ※新規作成の場合の調整用
' ※タイトル行1行目をウインドウ固定枠にする
' ■引数
' ・クエリ名 :クエリ名を指定
'
'////////////////////////////////////////////////////////////////////////////////////////////////////
Sub sr1_excel開く自動列幅調整2(クエリ名 As String)
Dim xlApp As Object 'Excel.Application
Dim xlBook As Object 'Excel.Workbook
Dim xlSheet As Object 'Excel.Worksheet

curdirx = CurDir
On Error Resume Next
MkDir "excel_out1"
On Error GoTo 0
ChDir "excel_out1"

'クエリからEXCEL化
date_time = Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss")
DoCmd.TransferSpreadsheet acExport, 10, クエリ名, "excelout_" & date_time & ".xlsx", True, ""

'列幅自動調整
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(CurDir & "\excelout_" & date_time & ".xlsx")
Set xlSheet = xlBook.Worksheets(1)
xlApp.Cells.EntireColumn.AutoFit '自動列幅調整
xlSheet.Rows(2).select
xlApp.ActiveWindow.FreezePanes = True
xlSheet.range("A2").select

xlBook.Save '保存して
xlApp.Quit '閉じる

Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing

'EXCELを開く
With CreateObject("Shell.Application")
.ShellExecute "excelout_" & date_time & ".xlsx", 3
End With
ChDir curdirx
End Sub

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_g_btnフォルダー_Click
'| 引 数:
'| 戻り値:
'| 説 明:フォルダーボタン押下時処理(フォルダー開く)
'| 履 歴:ver1.0.0 2019/12/16
'+--------------------------------------------------------------------------------+
Private Sub sr2_g_btnフォルダー_Click()

CreateObject("Shell.Application").Open cnsフォルダー 'フォルダーを最前面にもってくる

End Sub

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_GetOpenDialogFile
'| 引 数:
'sr2_h_strInPath:初期パス
'sr2_h_strInName:初期ファイル名
'sr2_h_sstrTitle:ダイアログタイトル
'| 戻り値:ファイル名(フルパス) キャンセルは””
'| 説 明:' ファイルを選択するダイアログを開く関数
'| 履 歴:
'+--------------------------------------------------------------------------------+

Public Function sr2_f_GetOpenDialogFile(ByVal sr2_h_strInPath As String, _
ByVal sr2_h_strInName As String, _
ByVal sr2_h_sstrTitle As String) As String

Dim objDialog As Object

'On Error GoTo err1
PBstrerrorSection = "GetOpenDialogFile" 'エラーセクション設定
'Err.Raise (2)

Set objDialog = Application.FileDialog(3) 'ファイルダイアログを開く

With objDialog
' 初期表示フォルダの設定
.InitialFileName = sr2_h_strInPath + "\" + sr2_h_strInName

' タイトルの設定
.Title = sr2_h_sstrTitle
'フィルターの設定
.Filters.Clear 'フィルターのクリア
.Filters.Add "EXCEL", "*.xls; *.xlsm; *.xlsx", 1
.Filters.Add "全てのファイル", "*.*", 2
'初期選択フィルターの設定
.FilterIndex = 1 'フィルター一番目を初期値に設定する
'複数ファイル選択の許可
.AllowMultiSelect = False 'ver1.2.0 追加
If .Show = False Then ' ファイルダイアログ表示
' [キャンセル]ボタンが押された場合
sr2_f_GetOpenDialogFile = ""
Else
' [OK]ボタンが押された場合
sr2_f_GetOpenDialogFile = .SelectedItems(1)
End If
End With

Set objDialog = Nothing
Exit Function
'err1:
'エラー処理
'Call subErrors
'MsgBox ("ERROR")

End Function

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_fncGetSpecialFolders_Desktop
'| 引 数:なし
'| 戻り値:パス名
'| 説 明:スペシャルフォルダを探し、返す関数 デスクトップのパスを返す関数
'| 履 歴:
'+--------------------------------------------------------------------------------+
'-------------------------------------------------------------
'スペシャルフォルダを探し、返す関数
'返値:フォルダー名
'Desktop
'デスクトップフォルダ
'Favorites
'お気に入りフォルダ
'Fonts
'フォントフォルダ
'MyDocuments
'マイドキュメントフォルダ
'Programs
'プログラムフォルダ
'Recent
'最近開いたファイルフォルダ
'SendTo
'送るフォルダ
'StartMenu
'スタートアップメニューフォルダ
'StartUp
'スタートアップフォルダ
'-------------------------------------------------------------
Function sr2_f_fncGetSpecialFolders_Desktop() As String
Dim sr2_h_objWScriptHost As Object
Dim sr2_h_str検索項目 As String


Set sr2_h_objWScriptHost = CreateObject("WScript.Shell")
' ↓ここは変数で入れない
sr2_f_fncGetSpecialFolders_Desktop = sr2_h_objWScriptHost.SpecialFolders("DESKTOP") 'パスを探す

End Function


'////////////////////////////////////////////////////////////////////////////////////////////////////
'
' AccessクエリからEXCELファイルを生成する
'
' ※列幅を自動調整する機能付き
'
' ■引数
' ・クエリ名 :クエリ名を指定
'
'////////////////////////////////////////////////////////////////////////////////////////////////////
Sub sr1_excel開く自動列幅調整(クエリ名 As String)

Dim xlApp As Object 'Excel.Application
Dim xlBook As Object 'Excel.Workbook
Dim xlSheet As Object 'Excel.Worksheet
Dim Path As String
Dim WSH As Object

Set WSH = CreateObject("WScript.Shell")
Path = WSH.SpecialFolders("MyDocuments") & "\" 'マイドキュメントフォルダーを調べる
CurDirx = CurDir
On Error Resume Next
MkDir "excel_out1"
On Error GoTo 0
ChDir "excel_out1"

'クエリからEXCEL化
date_time = Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss")
DoCmd.TransferSpreadsheet acExport, 10, クエリ名, Path & "excel_out1\excelout_" & date_time & ".xlsx", True, ""

'列幅自動調整
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(Path & "excel_out1\excelout_" & date_time & ".xlsx")
Set xlSheet = xlBook.Worksheets(1)
xlApp.Cells.EntireColumn.AutoFit '自動列幅調整

xlBook.Save '保存して
xlApp.Quit '閉じる

Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing

'EXCELを開く
With CreateObject("Shell.Application")
.ShellExecute Path & "excel_out1\excelout_" & date_time & ".xlsx", 3
End With
ChDir CurDirx
End Sub

'////////////////////////////////////////////////////////////////////////////////////////////////////
'
' AccessクエリからEXCELファイルを生成する
'
' ※列幅を自動調整する機能付き
' ※新規作成の場合の調整用
' ※タイトル行1行目をウインドウ固定枠にする
' ■引数
' ・クエリ名 :クエリ名を指定
'
'////////////////////////////////////////////////////////////////////////////////////////////////////
Sub sr1_excel開く自動列幅調整2(クエリ名 As String)
Dim xlApp As Object 'Excel.Application
Dim xlBook As Object 'Excel.Workbook
Dim xlSheet As Object 'Excel.Worksheet
Dim Path As String
Dim WSH As Object

Set WSH = CreateObject("WScript.Shell")
Path = WSH.SpecialFolders("MyDocuments") & "\" 'マイドキュメントフォルダーを調べる
CurDirx = CurDir
On Error Resume Next
MkDir "excel_out1"
On Error GoTo 0
ChDir "excel_out1"

'クエリからEXCEL化
date_time = Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss")
DoCmd.TransferSpreadsheet acExport, 10, クエリ名, Path & "excel_out1\excelout_" & date_time & ".xlsx", True, ""

'列幅自動調整
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(Path & "excel_out1\excelout_" & date_time & ".xlsx")
Set xlSheet = xlBook.Worksheets(1)
xlApp.Cells.EntireColumn.AutoFit '自動列幅調整
xlSheet.Rows(2).select
xlApp.ActiveWindow.FreezePanes = True
xlSheet.range("A2").select

xlBook.Save '保存して
xlApp.Quit '閉じる

Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing

'EXCELを開く
With CreateObject("Shell.Application")
.ShellExecute Path & "excel_out1\excelout_" & date_time & ".xlsx", 3
End With
ChDir CurDirx
End Sub

'+--------------------------------------------------------------------------------+
'| 関 数:
'| 引 数:なし
'| 戻り値:なし
'| 説 明:ロカールリンク先が同一フォルダにある場合のリンク更新(一括)
'| 履 歴:2018/10/12
'+--------------------------------------------------------------------------------+
Public Sub sr2_s_同一フォルダ_ローカルリンク更新一括()

Dim DB As DAO.Database
Dim TD As DAO.TableDef

Dim COL As Object ' AccessObject.Collection
Dim ACC As AccessObject

Dim TBL As String
Dim sr2_h_パス1 As String
Dim sr2_h_Accessファイル名 As String
Dim sr2_h_リンク先パス As String

sr2_h_リンク先パス = CurrentProject.Path 'リンク先のフォルダ指定

Set DB = CurrentDb()

'テーブル
Set COL = CurrentData.AllTables
For Each ACC In COL
If StrComp(Left$(ACC.Name, 4), "MSys", vbTextCompare) <> 0 Then
'システムテーブル以外の場合
Set TD = DB.TableDefs(ACC.Name)
If Left(TD.Connect, 10) = ";DATABASE=" Then

sr2_h_Accessファイル名 = Mid$(TD.Connect, InStrRev(TD.Connect, "\") + 1)
sr2_h_パス1 = sr2_h_リンク先パス & "\" & sr2_h_Accessファイル名
TBL = TD.SourceTableName
If Dir$(sr2_h_パス1, vbNormal) = vbNullString Then
Debug.Print sr2_h_Accessファイル名 & " ( " & TBL & " ) が、存在しません。"
Else
TD.Connect = ";DATABASE=" & sr2_h_パス1 & ";TABLE=" & TBL
TD.RefreshLink ' リンク情報の更新
End If
End If
Set TD = Nothing
End If
Next
Set COL = Nothing

DB.Close
Set DB = Nothing

End Sub

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_g_btnLINK_Click
'| 引 数:
'| 戻り値:
'| 説 明:EXCELフォルダーリンクオープン処理
'| 履 歴:ver1.0.0 2019/10/09
'+--------------------------------------------------------------------------------+
Private Sub sr2_g_btnLINK_Click()

Dim sr2_h_Path As Variant
sr2_h_Path = cnsEXECLフォルダー

CreateObject("Shell.Application").Open sr2_h_Path 'フォルダーを最前面にもってくる

End Sub

'ver1.2.0 追加 ***********************************************************************
'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_fncFileSystemMethod1
'| 引 数:sr2_h_strFullPass:検査フルパス名
'| 戻り値:
'sr2_h_strBaseFileName:返り値 ファイルベース名
'sr2_h_strAtter:返り値 拡張子名
'sr2_h_strFullPass2:フルパス名のみ
'| 説 明:フルパスファイル名を分解する関数
'| 履 歴:
'+--------------------------------------------------------------------------------+
Public Function sr2_f_fncFileSystemMethod1(ByVal sr2_h_strFullPass As String, _
sr2_h_strBaseFileName As String, sr2_h_strAtter As String, sr2_h_strFullPass2 As String)
'var1.2.0 2017/07/03


' FileSystemObjectを作成する。
Dim Obj As Object

'On Error GoTo err1
'PBstrerrorSection = "fncFileSystemMethod1" 'エラーセクション設定
'Err.Raise (2)


Set Obj = CreateObject("Scripting.FilesystemObject")

' ドライブ名をデバッグ出力する。
' Debug.Print Obj.GetDriveName(sr2_h_strFullPass)

' パス名をデバッグ出力する。
sr2_h_strFullPass2 = Obj.GetParentFolderName(sr2_h_strFullPass)

' ファイル名をデバッグ出力する。
'Debug.Print Obj.GetFileName(sr2_h_strFullPass)

' ベース名をデバッグ出力する。
sr2_h_strBaseFileName = Obj.GetBaseName(sr2_h_strFullPass)

' 拡張子をデバッグ出力する。
sr2_h_strAtter = Obj.GetExtensionName(sr2_h_strFullPass)

' オブジェクトを破棄する。
Set Obj = Nothing

Exit Function
err1:
'エラー処理
'Call subErrors

End Function

'フルパスから最後のフォルダを取り出す
dim sp as variant
dim sr2_h_LastFolder as string
sp = Split(sr2_h_Path, "\")
sr2_h_LastFolder= sp(UBound(sp))

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_fncCheckFieldCount
'| 引 数:sr2_h_strTBLName:テーブル名
'| 戻り値:フィールド列数
'| 説 明:TBLのフィールド列数を調べる関数
'| 履 歴:
'+--------------------------------------------------------------------------------+
Function sr2_f_fncCheckFieldCount(ByVal sr2_h_strTBLName As String) As Long

'列数調べる
'Dim cn As ADODB.Connection
Dim rs As New ADODB.Recordset

'Set cn = CurrentProject.Connection
'レコードセットを開く
'rs.Open sr2_h_strTBLName, cn, adOpenKeyset, adLockOptimistic
rs.Open sr2_h_strTBLName, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
'列数を調べる
sr2_f_fncCheckFieldCount = rs.Fields.Count

rs.Close
'Set cn = Nothing
Set rs = Nothing

End Function

'行数調べる
recCount = DCount("*","テーブルA")

ファイルにインポートします。
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, “T_取り込みテーブル”, “C:\Users\ユーザ名\Desktop\元Excelファイル.xlsx”, True, “Sheets1!A1:F100”

’シート指定
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "T_取り込みテーブル", FileName, True, "Sheet1!"



Public Sub Samp1()
  Dim v As Variant
  Dim sS As String
  Dim i As Long

'  v = GetExcelSheet(CurrentProject.Path & "\test.xlsm")
  v = GetExcelSheet("C:\test\テスト.xlsx")
  If (IsArray(v)) Then
    sS = "> シート数 = " & UBound(v) + 1 & vbCrLf
    For i = 0 To UBound(v)
      sS = sS & v(i) & vbCrLf
    Next
    MsgBox sS
  End If
End Sub

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_s_LinkAccess_ADD
'| 引 数:sr2_h_FullPath:リンクさせるACCESSLのファイル名、sr2_h_TableName:リンクするテーブル名
'| Optional sr2_h_TableNameLink:リンク元テーブル名
'| 戻り値:
'| 説 明:ACCESSテーブルのリンクテーブル作成処理
'| 履 歴:ver1.0.0 2019/0
'+--------------------------------------------------------------------------------+
Public Sub sr2_s_LinkAccess_ADD(sr2_h_FullPath As String, sr2_h_TableName As String, Optional sr2_h_TableNameLink As Variant = Null)

Dim DB As DAO.Database
Dim tbl As Object
Dim sr2_h_daoTableDef As TableDef

Set DB = CurrentDb

'テーブルが存在したならば削除
For Each sr2_h_daoTableDef In CurrentDb.TableDefs
If sr2_h_daoTableDef.Name = sr2_h_TableName Then
'テーブルが存在する場合
'DoCmd.RunSQL "DROP TABLE T_取り込みWK;"
DB.TableDefs.Delete sr2_h_TableName
DB.TableDefs.Refresh
Exit For
End If
Next

'リンクテーブルを作成
Set tbl = CurrentDb.CreateTableDef(sr2_h_TableName)
'リンク元の設定
tbl.Connect = ";DATABASE=" & sr2_h_FullPath
If IsNull(sr2_h_TableNameLink) = False Then
'リンク元の名前が違う
tbl.SourceTableName = sr2_h_TableNameLink 'リンク元テーブル名
Else
'通常
tbl.SourceTableName = sr2_h_TableName 'リンク元テーブル名
End If
DB.TableDefs.Append tbl


DB.Close

Set DB = Nothing
Set tbl = Nothing
RefreshDatabaseWindow

End Sub

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_fncGetExcelSheet
'| 引 数:sr2_h_strPath:パス(EXCELファイル名)
'| 戻り値:シート名群
'| 説 明:EXCELシート名群取得
'| 履 歴:
'+--------------------------------------------------------------------------------+
Public Function sr2_f_fncGetExcelSheet(sr2_h_strPath As String) As Variant
Dim sr2_h_objApp As Object
Dim sr2_h_objBook As Object
Dim vA() As Variant
Dim v As Variant
Dim i As Long

On Error Resume Next
i = 0

Set sr2_h_objBook = GetObject(sr2_h_strPath)

If (Not sr2_h_objBook Is Nothing) Then
'EXCELが存在する場合
For Each v In sr2_h_objBook.Worksheets
'シート名を順に読み込む
ReDim Preserve vA(i)
vA(i) = v.Name
i = i + 1
Next

Set sr2_h_objApp = sr2_h_objBook.Application

For Each v In sr2_h_objApp.Windows
If (v.Caption = sr2_h_objBook.Name) Then
If (Not v.Visible) Then
'シートが非表示ならば
sr2_h_objBook.Close SaveChanges:=False 'ファイルの変更を保存せず閉じる
End If
Exit For
End If
Next

Set sr2_h_objBook = Nothing
If (sr2_h_objApp.Workbooks.Count = 0) Then
'excelのブックが無くなったら

sr2_h_objApp.Quit 'EXCELを終了する
End If

Set sr2_h_objApp = Nothing

End If
sr2_f_fncGetExcelSheet = vA '値を返す

If (Err <> 0) Then
'エラーの場合エラー番号を返す
sr2_f_fncGetExcelSheet = Err.Number
End If
End Function

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_s_LinkExcel_ADD
'| 引 数:sr2_h_FullPath:リンクさせるEXCELのファイル名、sr2_h_Sheet:リンクするシート名
'| 戻り値:
'| 説 明:EXCELテーブルのリンクテーブル作成処理
'| 履 歴:ver1.0
'+--------------------------------------------------------------------------------+
Sub sr2_s_LinkExcel_ADD(sr2_h_FullPath As String, sr2_h_Sheet As String)

Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim sr2_h_daoTableDef As TableDef

Dim sFile As String

'Const sFile As String = "Excel 8.0;HDR=YES;IMEX=2;DATABASE=C:\Users\PA0167.DSV001\Desktop\客先売価の更新自動化\単価0List_201909.xlsx"
sFile = "Excel 8.0;HDR=YES;IMEX=2;DATABASE=" & sr2_h_FullPath

' On Error Resume Next
Set db = CurrentDb
'db.TableDefs.Delete "T_Tmp"
'テーブルが存在したならば削除

For Each sr2_h_daoTableDef In CurrentDb.TableDefs
If sr2_h_daoTableDef.Name = "T_取り込みWK" Then
'テーブルが存在する場合
DoCmd.RunSQL "DROP TABLE T_取り込みWK; "
Exit For
End If
Next


Set tdf = db.CreateTableDef("T_取り込みWK")
With tdf
.Connect = sFile
'.SourceTableName = "Q_etc単価0List$"
.SourceTableName = sr2_h_Sheet & "$"
End With
db.TableDefs.Append tdf
db.TableDefs.Refresh

Set tdf = Nothing
Set db = Nothing
RefreshDatabaseWindow

End Sub

'テーブルが存在したならば削除

For Each sr2_h_daoTableDef In CurrentDb.TableDefs
If sr2_h_daoTableDef.Name = "T_取り込みWK" Then
'テーブルが存在する場合
'DoCmd.RunSQL "DROP TABLE T_取り込みWK;"
db.TableDefs.Delete "T_取り込みWK"
db.TableDefs.Refresh
Exit For
End If
Next

Dim sr2_h_daoTableDef As TableDef

'テーブルが存在したならば削除
For Each sr2_h_daoTableDef In CurrentDb.TableDefs
If sr2_h_daoTableDef.Name = "T_取り込みWK" Then
DoCmd.RunSQL "DROP TABLE T_取り込みWK; "
'MsgBox "その名前のテーブルは、すでに存在しています。"
Exit For
End If
Next

SQL = "SELECT '' AS [エラー] , * INTO T_取り込み2WK FROM T_取り込みWK" 'エラー項目追加
DoCmd.RunSQL SQL

'key項目、sr工場区分項目後ろに追加
Set db = CurrentDb
Set tdf = db.TableDefs("T_取り込み2WK")
Set fld = tdf.CreateField(Name:="key", Type:=dbText, Size:=50)
'fld.Attributes = dbAutoIncrField
fld.AllowZeroLength = True '空文字の許可
tdf.Fields.Append Object:=fld


Sub sr2_s_テキストファイル属性変更()

Dim cn As DAO.Database
Dim rs As DAO.Recordset

Dim sr2_h_lngフィールド数 As Long


'T_取り込みWK 属性変更
sr2_h_lngフィールド数 = sr2_f_fncCheckFieldCount("T_取り込み2WK")

'DB接続
Set cn = CurrentDb

If sr2_h_lngフィールド数 >= 6 Then
'データフィールがある場合
For i = 5 To sr2_h_lngフィールド数 - 1 - 2
Set rs = cn.OpenRecordset("T_取り込み2WK") '読み込み専用
sr2_h_str氏名 = rs.Fields(i).Name 'フィールド名取得
rs.Close

CurrentDb.Execute "ALTER TABLE T_取り込み2WK ALTER COLUMN [" & sr2_h_str氏名 & "] LONG;"

Next
End If

Set rs = Nothing

End Sub

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_g_btnファイル検索_Click
'| 引 数:
'| 戻り値:
'| 説 明:ファイル検索ボタン押下時処理
'| 履 歴:
'+--------------------------------------------------------------------------------+
Private Sub sr2_g_btnファイル検索_Click()

Dim v As Variant
Dim i As Long
Dim sr2_h_strFileName As String
Dim sr2_h_strDESKTOP As String
Dim sr2_h_strBaseFileName As String
Dim sr2_h_strAtter As String
Dim sr2_h_strFullPass2 As String
Dim sr2_h_strPathName As String

sr2_h_strDESKTOP = sr2_f_fncGetSpecialFolders_Desktop 'デスクトップパスを調べる

If sr2_h_PBFileName = "" Then
sr2_h_strPathName = sr2_h_strDESKTOP
sr2_h_strFileName = ""
Else
Call sr2_f_fncFileSystemMethod1(sr2_h_PBFileName, sr2_h_strBaseFileName, sr2_h_strAtter, sr2_h_strFullPass2) 'フルパスファイル名を分解
sr2_h_strPathName = sr2_h_strFullPass2
sr2_h_strFileName = sr2_h_strBaseFileName & "." & sr2_h_strAtter
End If

sr2_h_PBFileName = sr2_f_GetOpenDialogFile(sr2_h_strPathName, sr2_h_strFileName, "データEXCEL検索") 'ファイルダイアログを開く

sr2_g_lblファイル名.Caption = sr2_h_PBFileName 'ファイル名をラベルに表示する

If sr2_h_PBFileName <> "" Then
'ファイル選択がある場合
DoCmd.OpenForm "F_シートダイアログ" 'シート名選択ダイアログを開く
End If


End Sub



'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_fncGetExcelSheet
'| 引 数:sr2_h_strPath:パス(EXCELファイル名)
'| 戻り値:シート名群
'| 説 明:EXCELシート名群取得
'| 履 歴:
'+--------------------------------------------------------------------------------+
Public Function sr2_f_fncGetExcelSheet(sr2_h_strPath As String) As Variant
Dim sr2_h_objApp As Object
Dim sr2_h_objBook As Object
Dim vA() As Variant
Dim v As Variant
Dim i As Long

On Error Resume Next
i = 0

Set sr2_h_objBook = GetObject(sr2_h_strPath)

If (Not sr2_h_objBook Is Nothing) Then
'EXCELが存在する場合
For Each v In sr2_h_objBook.Worksheets
'シート名を順に読み込む
ReDim Preserve vA(i)
vA(i) = v.Name
i = i + 1
Next

Set sr2_h_objApp = sr2_h_objBook.Application

For Each v In sr2_h_objApp.Windows
If (v.Caption = sr2_h_objBook.Name) Then
If (Not v.Visible) Then
'シートが非表示ならば
sr2_h_objBook.Close SaveChanges:=False 'ファイルの変更を保存せず閉じる
End If
Exit For
End If
Next

Set sr2_h_objBook = Nothing
If (sr2_h_objApp.Workbooks.Count = 0) Then
'excelのブックが無くなったら

sr2_h_objApp.Quit 'EXCELを終了する
End If

Set sr2_h_objApp = Nothing

End If
sr2_f_fncGetExcelSheet = vA '値を返す

If (Err <> 0) Then
'エラーの場合エラー番号を返す
sr2_f_fncGetExcelSheet = Err.Number
End If
End Function


Dim sr2_h_objShell As Object
Dim sr2_h_Dummy As Variant

'実行完了まで戻らないキック
Set sr2_h_objShell = CreateObject("WScript.Shell")
sr2_h_Dummy = sr2_h_objShell.Run("MSAccess.exe " & "C:\CommonWork\access_data\" & cnsKICKACCESSNAME & " /x 起動", 3, True)


Public Function sr2_f_fncExistFile(sr2_h_フルパス As String) As Boolean
'ファイル存在チェック
Dim FSO As Object

Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.FileExists(sr2_h_フルパス) = False Then
'ファイルが無いエラーの場合

Else
'ファイルがある場合
sr2_f_fncExistFile = True


End If

End Function


'オートナンバーリセット

With CurrentProject.Connection
'データ削除
CurrentProject.Connection.Execute "DELETE * FROM T_車種分類別売上", dbFailOnError
'オートナンバーリセット【ウィザードで作成したオートナンバーではエラー発生】
                             'スタート,ステップ
.Execute "Alter Table T_車種分類別売上 Alter Column [ID] Identity(1, 1)", dbFailOnError
End With



'フォルダーの存在チェック
Public Function sr2_f_fncIsExistDirA(sr2_h_sFolder As String) As Boolean
Dim sr2_h_result

sr2_h_result = Dir(sr2_h_sFolder, vbDirectory)

If sr2_h_result = "" Then
'// フォルダが存在しない
sr2_f_fncIsExistDirA = False
Else
'// フォルダが存在する
sr2_f_fncIsExistDirA = True
End If
End Function

'ver1.2.2追加 ***********************************
'オートナンバーNOを後ろに追加
Set db = CurrentDb
Set tdf = db.TableDefs("T_取り込みWK")

Set fld = tdf.CreateField(Name:="No", Type:=dbLong)
fld.Attributes = dbAutoIncrField
tdf.Fields.Append Object:=fld
db.Close
Set db = Nothing
Set tdf = Nothing
Set fld = Nothing
'*************************************************

'ver1.1.0追加 ***********************************
'列の追加
Set fld = tdf.CreateField(Name:="品番short", Type:=dbText, Size:=50)
fld.AllowZeroLength = True '空文字の許可
tdf.Fields.Append Object:=fld
db.Close
Set db = Nothing
Set tdf = Nothing
Set fld = Nothing
'*************************************************

'テーブルが存在したならば削除(テーブル削除)ドロップ
For Each sr2_h_daoTableDef In CurrentDb.TableDefs
If sr2_h_daoTableDef.Name = "T_取り込みWK" Then
DoCmd.RunSQL "DROP TABLE T_取り込みWK; "
'MsgBox "その名前のテーブルは、すでに存在しています。"
Exit For
End If
Next



'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_getOpenDirListCHK
'| 引 数:sr2_h_Path:チェックするフルパス
'| 戻り値:true:開いてる False:開いていない
'| 説 明:対象フォルダが開いているかチェックする関数
'| 履 歴:ver1.2.2 2019/08/20 板津
'+--------------------------------------------------------------------------------+
Function sr2_f_getOpenDirListCHK(sr2_h_Path As Variant) As Boolean ' As Collection

Dim sh As Object
Dim wcobj As Object
Dim sr2_h_result As Variant

Dim s As String
Dim res As New Collection

'オブジェクトの取得
Set sh = CreateObject("Shell.Application")
'コレクションオブジェクトの取得
Set wcobj = sh.Windows


For Each wobj In wcobj
'Internt Explorerが開いているファイルは除外する。
If (wobj.FullName Like "*Explorer.EXE") = True Then
s = wobj.LocationURL
'オブジェクトフォルダは除外する
If Left(s, 10) <> "file:///::" Then
' 最初の"file:///"を取り除く
If s Like "file:///?:*" Then
'ローカル
s = Right(s, Len(s) - Len("file:///"))
Else
'サーバ
s = Right(s, Len(s) - Len("file:"))
End If
' 左から1文字ずつチェックして文字列を置き換えていく
sr2_h_result = ""

For i = 1 To Len(s)
Select Case Mid(s, i, 1)
Case "/"
sr2_h_result = sr2_h_result & "\"
Case "%"
sr2_h_result = sr2_h_result & Chr(CInt("&H" & Mid(s, i + 1, 2)))
i = i + 2
Case Else
sr2_h_result = sr2_h_result & Mid(s, i, 1)
End Select
Next
If sr2_h_result = sr2_h_Path Then
'フォルダーが一致した場合
sr2_f_getOpenDirListCHK = True
Exit For
End If
'res.Add (sr2_h_result)
End If
End If
Next
'Set sr2_f_getOpenDirList = res
End Function

'////////////////////////////////////////////////////////////////////////////////////////////////////
' システムの起動確認
'
' 受渡変数
' appName:起動アプリの実行ファイル名
' filName:起動ファイル名
' 戻り
' 起動時:True、未起動時:False
'
' ------------------------------------------------------------------------------------------
' 担当者 処置日 内容
' ------------------------------------------------------------------------------------------
'   2018/09/05 システムの起動確認
'
'////////////////////////////////////////////////////////////////////////////////////////////////////
Function sr1_起動確認(appName As String, filName As String) As Boolean
sr1_起動確認 = True

'ローカルコンピュータに接続する。
Set oLocator = CreateObject("WbemScripting.SWbemLocator")
Set oService = oLocator.ConnectServer
'クエリー条件を WQL にて指定する。
If appName = "" Then
Set oClassSet = oService.ExecQuery("Select * From Win32_Process Where CommandLine Like '%" & filName & "%'")
Else
Set oClassSet = oService.ExecQuery("Select * From Win32_Process Where Description='" & appName & "' And CommandLine Like '%" & filName & "%'")
End If

If oClassSet.Count = 0 Then
sr1_起動確認 = False
Else
Dim objWShell As New IWshRuntimeLibrary.WshShell

For Each oClass In oClassSet
objWShell.AppActivate oClass.ProcessID
Next

Set objWShell = Nothing
End If

'使用した各種オブジェクトを後片付けする。
Set oClassSet = Nothing
Set oService = Nothing
Set oLocator = Nothing
End Function

'-----------------------------------------------------
'PC名、ユーザー名を調べる関数
'返値
'strUserName:ユーザー名
'strPCName:PC名
'-----------------------------------------------------
Public Sub sr2_f_fncUSERID_PCNAME(strUserName As String, strPCName As String)

Dim sr2_h_objObject As Object

Set sr2_h_objObject = CreateObject("WScript.Network")

With sr2_h_objObject
'MsgBox "ユーザー名: " & .UserName & vbCrLf _
& "コンピュータ名: " & .ComputerName
strUserName = .UserName
strPCName = .ComputerName
End With

Set sr2_h_objObject = Nothing
End Sub

sr2_g_txtPC名 = CreateObject("WScript.Network").ComputerName 'PC名取得
sr2_g_txtユーザー名 = CreateObject("WScript.Network").UserName 'ユーザー名取得

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_g_cmb品番_exit
'| 引 数:
'| 戻り値:
'| 説 明:sr2_g_cmb品番_exit処理
'| 履 歴:ver1.2.2 2019/08/22 
'+--------------------------------------------------------------------------------+
'Private Sub sr2_g_cmb品番_Click()
Private Sub sr2_g_cmb品番_exit(Cancel As Integer)

Dim sr2_h_品番 As String
Dim sr2_h_品名 As String
Dim sr2_h_調査 As Long

sr2_h_調査 = IIf(DCount("*", "dbo_T_出荷情報DB", "出荷品番 = '" & Me.sr2_g_cmb品番.Value & "'") <> 0, _
1, 0)

If sr2_h_調査 > 0 Then

Else
'該当なしの場合
MsgBox "品番が部品リストにありません。", vbExclamation

Me.sr2_g_lbl品名.Caption = vbNullString
Cancel = True 'タブ移動阻止(タブ移動させない)
End If
End Sub

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_s_Access_Run
'| 引 数:sr2_h_ファイル名:実行ファイル名(フルパス)、sr2_h_プロシージャ名:実行プロシージャ名(括弧なしで)
'| 戻り値:なし
'| 説 明:Access(.accdb)を開き、プロシージャを実行する。非表示モード
'|
'| 履 歴:2018/09/13 新規作成
'| 履 歴:2019/07/26 VbScript仕様からAccess Eval関数仕様に変更
'+--------------------------------------------------------------------------------+
Public Sub sr2_s_Access_Run( _
ByVal sr2_h_ファイル名 As String, _
ByVal sr2_h_プロシージャ名 As String)

Dim RTN As Long
Dim MSG As String

Dim objAccess As New Access.Application

'Access起動
objAccess.OpenCurrentDatabase sr2_h_ファイル名
objAccess.Visible = False

'プロシージャ実行
'On Error Resume Next

RTN = Nz(objAccess.Eval(sr2_h_プロシージャ名 & "()"), 0)
MSG = ""

If Err.Number = 0 Then
ElseIf Err.Number = 16 Then
'Err.Description:式が複雑すぎます
'デバッグでの実行は正常に処理可能。
'ただし戻りの際にエラーが発生する。
'問題ないため、このままスルーとする。
Else
MSG = "エラーNo:" & Err.Number & vbCrLf & "内容:" & Err.Description & vbCrLf & vbCrLf
RTN = Err.Number
End If

On Error GoTo 0

'Access終了
objAccess.CloseCurrentDatabase
objAccess.Quit
Set objAccess = Nothing

End Sub

'////////////////////////////////////////////////////////////////////////////////////////////////////
'
'マイドキュメントフォルダーにexcel_out1フォルダーを作成し、PDFを保存、表示します。
'PdfOut_yyyymmdd_hhmmssファイルを作成
'OutputToのパラメーターです。
'出力タイプ:出力タイプ (acReport,acOutputReport,acForm,acOutputTable,acOutputQuery,etc)
'オブジェクト名:クエリ名やレポート名など
'出力フォーマット:出力する形式 (acFormatPDF,acFormatXLSX,etc)
'
'////////////////////////////////////////////////////////////////////////////////////////////////////
Sub sr2_s_pdf出力_開く(出力タイプ As Long, オブジェクト名 As String, 出力フォーマット As String, Optional sr2_h_strオプション As String)

Dim Path As String
Dim WSH As Variant
Dim sr2_h_strFile As String 'ver1.2.2 追加
Dim SQL As String 'ver1.2.2 追加

Set WSH = CreateObject("WScript.Shell")
Path = WSH.SpecialFolders("MyDocuments") & "\" 'マイドキュメントフォルダーを調べる

'フォルダーを作成
On Error Resume Next
MkDir Path & "excel_out1"
On Error GoTo 0

'ACCESSから出力する
date_time = Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss")

'ver1.2.2追加 **************************************************
'ナビゲーションウインドウを最小化
DoCmd.NavigateTo "acNavigationCategoryObjectType", ""
DoCmd.RunCommand acCmdDocMinimize
'※ナビゲーションウインドウが非表示だと連続でPDFが出せない為
'****************************************************************

sr2_h_strFile = Path & "excel_out1\" & "PdfOut_" & date_time & sr2_h_strオプション & ".pdf" 'ver1.2.2 追加

'DoCmd.OutputTo 出力タイプ, オブジェクト名, 出力フォーマット, _
Path & "excel_out1\" & "PdfOut_" & date_time & sr2_h_strオプション & ".pdf", True'ver1.2.2 削除
DoCmd.OutputTo 出力タイプ, オブジェクト名, 出力フォーマット, sr2_h_strFile, True 'ver1.2.2 変更

SQL = "INSERT INTO PDFファイルWK ([ファイル名]) VALUES ('" & sr2_h_strFile & "')" 'ver1.2.2 追加

CurrentDb().Execute SQL 'ver1.2.2 追加


'ver1.2.2追加 **************************************************
'ナビゲーションウインドウを隠す
DoCmd.NavigateTo "acNavigationCategoryObjectType", ""
DoCmd.RunCommand acCmdWindowHide
'※ナビゲーションウインドウが非表示だと連続でPDFが出せない為
'通常触られたくないので非表示にする
'****************************************************************

Set WSH = Nothing

End Sub

'VBスクリプト作成
'ver1.2.2追加*********************************************************************************
'VBS作成
Open "C:\CommonWork\access_data\b0064.完了メッセージ.vbs" For Output As #1 'ファイルを出力モードで開く

Print #1, "msgbox " & Chr$(34) & "完了しました。" & Chr$(34)

Close #1
'VBS実行
Shell "WScript.exe C:\CommonWork\access_data\b0064.完了メッセージ.vbs"
'**********************************************************************************************

'PDFを開く
Public Function test2()


Sample ("C:\Users\PA0167.DSV001\Documents\excel_out1\PdfOut_20190830_170731_白.pdf")
'Sample ("C:\Users\PA0167.DSV001\Documents\excel_out1\PdfOut_20190830_170735_構成部品.pdf")
'Sample ("C:\Users\PA0167.DSV001\Documents\excel_out1\PdfOut_20190830_170129_赤.pdf")
MsgBox "OK", vbOKOnly + vbSystemModal

End Function

Sub Sample(myFile)
’PDFが下にあったら最上面に表示させる。重複オープンはない。
Dim objShell As Object
' Dim myFile As String
'myFile = "C:\test.pdf"

Set objShell = CreateObject("WScript.Shell")
objShell.Run "rundll32.exe url.dll,FileProtocolHandler " & myFile & "", 1, False
Set objShell = Nothing


End Sub

'エクスプローラーでファイル選択
Private Sub コマンド47_Click()


SelFileInExplorer "C:\Users\PA0167.DSV001\Documents\excel_out1\PdfOut_20190902_115818_構成部品.pdf"
End Sub

Private Sub SelFileInExplorer(ByVal TargetFilePath As String)
'指定したファイルをエクスプローラーで開いて選択する
With CreateObject("Scripting.FileSystemObject")
'If .FileExists(TargetFilePath) = True Then
Shell "EXPLORER.EXE /select,""" & TargetFilePath & """", vbNormalFocus
'End If
End With
End Sub

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_g_btnPDFLINK_Click
'| 引 数:
'| 戻り値:
'| 説 明:PDFフォルダーオープン処理
'| 履 歴:ver1.2.2 2019/09/02 板津
'+--------------------------------------------------------------------------------+
Private Sub sr2_g_btnPDFLINK_Click()
Dim sr2_h_Path As Variant
Dim objWShell As Object

sr2_h_Path = sr2_f_fncGetSpecialFolders_MyDocuments() & "\" & "excel_out1"

CreateObject("Shell.Application").Open sr2_h_Path 'フォルダーを最前面にもってくる

End Sub



Public sr2_h_str処理日 As String

Public sr2_h_str処理時間 As String


'-----------------------------------------------------
'日付時間設定関数
'日付/時間を変数から返す関数
'クエリ用
'strF:識別名 処理日/処理時間
'返値:日付/時間
'-----------------------------------------------------
Public Function sr2_f_fncDate(strF As String)

Select Case strF
Case "処理日"
sr2_f_fncDate = sr2_h_str処理日
Case "処理時間"
sr2_f_fncDate = sr2_h_str処理時間
End Select

End Function

Public sr2_h_PBstr工程区分 As String
Public sr2_h_PBstr紙色 As String
Public sr2_h_PBstr現品表形式区分 As String
'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_fncQueryParam
'| 引 数:なし
'| 戻り値:
'| 説 明:クエリに出力するパラメータ設定関数
'| 履 歴:
'+--------------------------------------------------------------------------------+
Public Function sr2_f_fncQueryParam(ByVal sr2_h_strタイプ As String) As String

Select Case sr2_h_strタイプ
Case "工程区分"
sr2_f_fncQueryParam = sr2_h_PBstr工程区分

Case "紙色"
sr2_f_fncQueryParam = sr2_h_PBstr紙色

Case "現品表形式区分"
sr2_f_fncQueryParam = sr2_h_PBstr現品表形式区分
End Select

End Function


'+--------------------------------------------------------------------------------+
'| 関 数:sr2_s_subDelete返却用データ
'| 引 数:なし
'| 戻り値:なし
'| 説 明:返却用データ削除
'|
'| 履 歴:ver1.2.0 2019/09/11 新規作成 
'+--------------------------------------------------------------------------------+
Public Sub sr2_s_subDelete返却用データ()
Dim fld As String
Dim fso As FileSystemObject
Set fso = New FileSystemObject

'データ削除

'\\NETWORKDISK1\決算棚卸\3返却用EXCEL入れ
fld = sr2_c_pファイル出力先 & "\" & coFldr_104 & "\" & "*.*"
Call fso.DeleteFile(fld, True) ' すべてのファイルを削除



' 後始末
Set fso = Nothing
End Sub

'バリアントの配列variant
Sub Test2()
Dim arrList As Variant
Dim str1 As String
str1 = "1,侍エンジニア1,VBA,5年"
arrList = Split(str1, ",")

Dim i As Integer
For i = 0 To UBound(arrList)
Debug.Print arrList(i)
Next i

End Sub

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_fncGetFieldNameCheck
'| 引 数:
'| sr2_h_テーブル:テーブル名
'| sr2_h_タイトル:比較タイトル(配列)variant
'| 戻り値:false:合格 ,true:不合格
'| 説 明:テーブルフィールドの合否判定関数
'| 履 歴:ver1.0.0 2019/09/12
'+--------------------------------------------------------------------------------+
Public Function sr2_f_fncGetFieldNameCheck(sr2_h_テーブル As String, sr2_h_タイトル As Variant) As Boolean
Dim TD As TableDef
Dim Fld As Field
Dim i As Long
Dim DB As Database

Set DB = CurrentDb
Set TD = DB.TableDefs(sr2_h_テーブル)
'フィールドを表示する
For Each Fld In TD.Fields
If i <= UBound(sr2_h_タイトル) Then
'規定タイトルの範囲の内の場合
If Fld.Name <> sr2_h_タイトル(i) Then
'タイトルが違う場合
sr2_f_fncGetFieldNameCheck = True
Exit For
End If
i = i + 1
Else
'規定タイトルの範囲の外の場合
Exit For
End If
Next
End Function


'+--------------------------------------------------------------------------------+
'| 関 数:sr2_s_LinkExcel_ADD
'| 引 数:sr2_h_FullPath:リンクさせるEXCELのファイル名、sr2_h_Sheet:リンクするシート名
'| 戻り値:
'| 説 明:EXCELテーブルのリンクテーブル作成処理
'| 履 歴:ver1.0.0 2019/09/11 
'+--------------------------------------------------------------------------------+
Public Sub sr2_s_LinkExcel_ADD(sr2_h_FullPath As String, sr2_h_Sheet As String)

Dim DB As DAO.Database
Dim tdf As DAO.TableDef
Dim sr2_h_daoTableDef As TableDef

Dim sFile As String

'Const sFile As String = "Excel 8.0;HDR=YES;IMEX=2;DATABASE=C:\Users\PA0167.DSV001\Desktop\客先売価の更新自動化\単価0List_201909.xlsx"
sFile = "Excel 8.0;HDR=YES;IMEX=2;DATABASE=" & sr2_h_FullPath

' On Error Resume Next
Set DB = CurrentDb
'db.TableDefs.Delete "T_Tmp"
'テーブルが存在したならば削除

For Each sr2_h_daoTableDef In CurrentDb.TableDefs
If sr2_h_daoTableDef.Name = "T_取り込みWK" Then
'テーブルが存在する場合
'DoCmd.RunSQL "DROP TABLE T_取り込みWK;"
DB.TableDefs.Delete "T_取り込みWK"
DB.TableDefs.Refresh
Exit For
End If
Next


Set tdf = DB.CreateTableDef("T_取り込みWK")
With tdf
.Connect = sFile
'.SourceTableName = "Q_etc単価0List$"
.SourceTableName = sr2_h_Sheet & "$"
End With
DB.TableDefs.Append tdf
DB.TableDefs.Refresh

Set tdf = Nothing
Set DB = Nothing
RefreshDatabaseWindow

End Sub
'+--------------------------------------------------------------------------------+
'| 関 数:sr2_s_LinkExcelDAO_DEL
'| 引 数:
'| 戻り値:
'| 説 明:EXCELテーブルのリンクテーブル削除処理
'| 履 歴:ver1.0.0 2019/09/19 
'+--------------------------------------------------------------------------------+
'リンクの削除
Public Sub sr2_s_LinkExcelDAO_DEL()
Dim db As DAO.Database

Set db = CurrentDb

For Each sr2_h_daoTableDef In CurrentDb.TableDefs
If sr2_h_daoTableDef.Name = "T_取り込みWK" Then
'テーブルが存在する場合
db.TableDefs.Delete "T_取り込みWK"
db.TableDefs.Refresh
Exit For
End If
Next


db.Close

Set db = Nothing
End Sub

'リンクデータを消しても消えない時は例えば
chdir c:\
で強引に切ると良い

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_s_subFolderWindowClose
'| 引 数:sr2_h_strFolder:指定フォルダー名
'| 戻り値:
'| 説 明:指定フォルダウインドウを閉じる処理
'| 履 歴:ver1.0.0 2019/09/18 
'+--------------------------------------------------------------------------------+
Sub sr2_s_subFolderWindowClose(sr2_h_strFolder As String)
Dim w As Object
Set sh = CreateObject("Shell.Application")

For Each w In sh.WIndows

'指定フォルダーを探す
If Replace(Mid(w.LocationURL, 9), "/", "\") = sr2_h_strFolder Then
'指定フォルダがあったならば
w.Quit 'ウインドウを閉じる
End If
Next

End Sub

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_fncFolderNameXchange
'| 引 数:sr2_h_strFolder:指定フォルダー名
'| 戻り値:true:成功、false:失敗
'| 説 明:指定フォルダー名を変更する関数 (フォルダ名+★に)
'| 履 歴:ver1.0.0 2019/09/18 
'+--------------------------------------------------------------------------------+
Function sr2_f_fncFolderNameXchange(sr2_h_strFolder As String) As Boolean
On Error GoTo err1

Name sr2_h_strFolder As sr2_h_strFolder & "★"
sr2_f_fncFolderNameXchange = True
Exit Function
err1:

sr2_f_fncFolderNameXchange = False

End Function

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_fncCheckOpenFile
'| 引 数:sr2_h_strFullpath:指定ファイル名
'| 戻り値:true:開いている、false:閉じてる
'| 説 明:指定EXCELfileのオープンを調べる関数
'| 履 歴:ver1.0.0 2019/09/18 
'+--------------------------------------------------------------------------------+
Function sr2_f_fncCheckOpenFile(sr2_h_strFullpath As String) As Boolean

On Error Resume Next

'// 保存済みのブックか判定
Open sr2_h_strFullpath For Append As #1
Close #1

If Err.Number > 0 Then
'// 既に開かれている場合
sr2_f_fncCheckOpenFile = True
Else
'// 開かれていない場合
sr2_f_fncCheckOpenFile = False
End If


End Function

’ウインドウを最前面に持ってくる キャプションがわかっている場合

Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Sub SetForegroundWindow Lib "user32" (ByVal hWnd As Long)

'ウインドウが可視かどうかを取得する
Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long

'次または前のウインドウハンドルを取得する
Declare Function GetNextWindow Lib "user32" Alias "GetWindow" _
(ByVal hWnd As Long, ByVal wFlag As Long) As Long

Public Const cnsフォルダー = "\\NETWORKDISK1\kikaku\■経理access専用\出荷実績登録\計上通知照合_ホンダ"
Public Const cnsフォルダーキャプション = "計上通知照合_ホンダ" '重複フォルダーオープン阻止と最前面表示の為

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_s_ウインドウハンドルで取得したウインドウを最前面にする関数
'| 引 数:
'| 戻り値:
'| 説 明:フォルダーファイルの前面表示(既に開かれている場合のみ)
'| 履 歴:ver1.0.0 2019/12/16
'+--------------------------------------------------------------------------------+

Sub sr2_s_ウインドウハンドルで取得したウインドウを最前面にする関数()

SetForegroundWindow sr2_f_キャプション名からウインドウハンドルを取得する

End Sub

'+--------------------------------------------------------------------------------+
'| 関 数:sr2_f_キャプション名からウインドウハンドルを取得する
'| 引 数:
'| 戻り値:ウインドウハンドル番号
'| 説 明:指定のフォルダーキャプション(タイトル)からハンドル番号を取得する関数
'| 履 歴:ver1.0.0 2019/12/16
'+--------------------------------------------------------------------------------+
Function sr2_f_キャプション名からウインドウハンドルを取得する() As Variant

Dim hWnd As Long
hWnd = FindWindow(vbNullString, cnsフォルダーキャプション)
sr2_f_キャプション名からウインドウハンドルを取得する = hWnd
End Function




’ウインドウを最前面に持ってくる2キャプションがあいまいの場合

’ウインドウハンドルを取得する
Declare Function FindWindow Lib “user32” Alias “FindWindowA” _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

’ウインドウのキャプションタイトルを取得する
Declare Function GetWindowText Lib “user32” Alias “GetWindowTextA” _
(ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

’ウインドウが可視かどうかを取得する
Declare Function IsWindowVisible Lib “user32” (ByVal hWnd As Long) As Long

’次または前のウインドウハンドルを取得する
Declare Function GetNextWindow Lib “user32” Alias “GetWindow” _
(ByVal hWnd As Long, ByVal wFlag As Long) As Long

Const GW_HWNDLAST = 1
Const GW_HWNDNEXT = 2

Sub キャプション名の一部からウインドウハンドルを取得する()

Dim hWnd As Long
Dim strCaption As String * 80
Dim 対象ウインドウハンドル As Long

hWnd = FindWindow(vbNullString, vbNullString) ’1つめのウインドウを取得する
Do
If IsWindowVisible(hWnd) Then
GetWindowText hWnd, strCaption, Len(strCaption)
If InStr(strCaption, “Chrome”) <> 0 Then
対象ウインドウハンドル = hWnd
Exit Do
End If
End If
hWnd = GetNextWindow(hWnd, GW_HWNDNEXT)
Loop Until hWnd = GetNextWindow(hWnd, GW_HWNDLAST) ’最後のウインドウになるまで繰り返す

End Sub