日本語ローコードYUGE Ver1.19

Excel_LowCode_YUGE.vba

'
' 日本語ローコードYUGE Ver1.19
' (注意)変更しないでください。
' https://excel-databace.hatenablog.com/entry/yuge-help
'
'Ver 1.17  2020/11/16  タイマー機能追加
'    1.18  2020/11/25  ユーザーマクロに説明追加/年月範囲追加/印刷ダイアログ
'    1.19  2020/12/25  テーブル作成/解除
'
Option Explicit

'----- YUGE共通変数(汎用) -----
Public ygInt1 As Integer, ygInt2 As Integer, ygInt3 As Integer, ygInt4 As Integer, ygInt5 As Integer
Public ygSTR1 As String, ygSTR2 As String, ygSTR3 As String, ygSTR4 As String, ygSTR5 As String
Public ygBackForm As String
Public ygEnd  As Integer, ygCntPrt As Integer
'----- YUGE共通変数(日付) -----
Public yg日付 As String, yg日付ST As String, yg日付ED As String
Public yg年月 As String, yg年月ST As String, yg年月ED As String
Public yg年  As Integer, yg年ST  As Integer, yg年ED As Integer
'--- Timer ---
Public ygBlnTimer    As Boolean
Public ygLngTimerID  As Long
Public ygProcMacro   As String

'MkPassWord/RePassWord用(数字4桁を入力してください)
Private Const ygPassWord = "1234"

'2020/11/13 --------------------------------------------------*
#If VBA7 Then
'VBA7
Declare PtrSafe Function SetTimer Lib "user32" _
       (ByVal hwnd As Long, _
        ByVal nIDEvent As Long, _
        ByVal uElapse As Long, _
        ByVal lpTimerFunc As LongPtr) As Long

Declare PtrSafe Function KillTimer Lib "user32" _
       (ByVal hwnd As Long, _
        ByVal nIDEvent As Long) As Long
#Else
'Downlevel when using previous version of VBA7
Declare Function SetTimer Lib "user32" _
       (ByVal hwnd As Long, _
        ByVal nIDEvent As Long, _
        ByVal uElapse As Long, _
        ByVal lpTimerFunc As Long) As Long

Declare Function KillTimer Lib "user32" _
       (ByVal hwnd As Long, _
        ByVal nIDEvent As Long) As Long
#End If

Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
  'タイマー 実行処理
  On Error Resume Next
  
  Application.Run ygProcMacro
End Sub

'2020/07/24 --------------------------------------------------*
Function f_確認(qメーッセージ As String, qアイコン As String, qタイトル As String) As Integer
  '
  '【構文】  f_確認("<メーッセージ>","<アイコンタイプ: i ? ! x >","<タイトル>")
  '【戻り値】［OK］［はい］は 1、［いいえ］は 2、［x］は 0
  '
  Dim wTitle  As String
  
  If qタイトル = "" Then
    wTitle = "確認"
  Else
    wTitle = qタイトル
  End If
  
  Select Case qアイコン
    Case "i":  MsgBox qメーッセージ, vbOKOnly + vbInformation, wTitle
    Case "?":  MsgBox qメーッセージ, vbYesNo + vbQuestion, wTitle
    Case "!":  MsgBox qメーッセージ, vbOKOnly + vbExclamation, wTitle
    Case "x":  MsgBox qメーッセージ, vbYesNo + vbCritical, wTitle
    Case Else: MsgBox "アイコンタイプは、[i][?][!][x]で指定してください。", vbOKOnly + vbExclamation, "確認"
  End Select
End Function

'2020/08/08 --------------------------------------------------*
Function f_クエリー表示(qクエリー名 As String, qデータベース名 As String, qフィルター As String) As Integer
  '
  '【構文】  f_クエリー表示("<クエリー名>","<データベース名>","<フィルター>")
  '【戻り値】成功:1 失敗:0
  '
  Dim wQuery  As String
  Dim wAccdb  As String
  Dim wFilter As String
  
  wQuery = qクエリー名
  wAccdb = qデータベース名
  wFilter = qフィルター
  
  f_クエリー表示 = 0
  
  
End Function

'2020/11/26 --------------------------------------------------*
Function f_シート印刷(qシート名 As String, qブック名 As String, qプレビュー処理 As String, q印刷枚数 As Integer) As Integer
  '
  '【構文】  f_シート印刷("<シート名>","<ブック名>,"<プレビュー処理>", <印刷枚数>)
  '【戻り値】成功:1 失敗:0
  '
  Dim wFL     As Integer
  Dim wBook   As String
  Dim wIsPreview As String
  Dim wBLret  As Boolean
  
  f_シート印刷 = 0
  
  'Book名省略
  If qブック名 = "" Then
    wBook = ThisWorkbook.Name
  Else
    wBook = qブック名
  End If
  
  'Bookを判定
  wFL = f_ファイル判定(wBook, True)
  If wFL = 0 Then Exit Function
  
  'Sheetを判定
  wFL = f_シート判定(qシート名, qブック名, False, True)
  If wFL = 0 Then Exit Function
  
  '印刷処理
  With Workbooks(wBook)
  
    '自動計算チェック
    'Application.Calculation = xlCalculationAutomatic
    .Worksheets(qシート名).Activate
    
    'プレビュー処理を省略
    If qプレビュー処理 = "" Then
      wIsPreview = "する"
    Else
      wIsPreview = qプレビュー処理
    End If
    
    Select Case wIsPreview
      Case "する"
        'プレビュー
        .Worksheets(qシート名).PrintOut preview:=True
        
      Case Else
        If ygCntPrt = 1 Then
          '(1枚目)印刷ダイアログ
          wBLret = Application.Dialogs(xlDialogPrint).Show(Arg4:=q印刷枚数)
          
          '中止
          If wBLret = False Then ygCntPrt = -1
        Else
          '(2枚目以降)印刷実行
          .Worksheets(qシート名).PrintOut Copies:=q印刷枚数
        End If
    End Select
  End With
  
  '初期状態 Close
  If wFL = 2 Then
    Workbooks(wBook).Close savechanges:=False
  End If
  
  f_シート印刷 = 1
End Function

'2020/08/08 --------------------------------------------------*
Function f_シート削除(qシート名 As String, qブック名 As String, q警告 As String) As Integer
  '
  '【構文】  f_シート追加("<シート名>","<ブック名>")
  '【戻り値】成功:1 失敗:0
  '
  Dim wFL     As Integer
  Dim wBook   As String
  Dim WSH    As Worksheet

  f_シート削除 = 0
  
  'Book名省略
  If qブック名 = "" Then
    wBook = ThisWorkbook.Name
  Else
    wBook = qブック名
  End If
  
  'Bookを判定
  wFL = f_ファイル判定(wBook, True)
  If wFL = 0 Then Exit Function
  
  'オープン判定
  'シート名省略
  
  '警告表示
  If q警告 = "する" Or q警告 = "" Then
    Application.DisplayAlerts = True
  Else
    Application.DisplayAlerts = False
  End If
  
  'シート判定
  wFL = f_シート判定(qシート名, qブック名, False, False)
  If wFL = 0 Then Exit Function
  
  'シート削除
  With Workbooks(wBook)
    .Worksheets(qシート名).Activate
    .Worksheets(qシート名).Delete
  End With

  Application.DisplayAlerts = True
  
  f_シート削除 = 1
  
  For Each WSH In Workbooks(wBook).Worksheets
    If qシート名 = WSH.Name Then
      '(存在:キャンセル)
      f_シート削除 = 0
      Exit For
    End If
  Next
End Function

'2020/06/03 --------------------------------------------------*
Function f_シート判定(qシート名 As String, qブック名 As String, q閉じる As Boolean, q警告 As Boolean) As Integer
  '
  '【構文】  f_シート判定("<シート名>","<ブック名>",<終了状態>,<エラー表示指定>)
  '【戻り値】成功(初期Open):1 成功(初期Close):2 失敗:0
  '
  Dim wFL     As Integer
  Dim wFLMsg  As Integer
  Dim wMSG    As String
  Dim wBook   As String
  Dim wPath   As String
  Dim wFile   As String
  Dim wExt    As String
  Dim wVar    As Variant

  f_シート判定 = 0

  'シート名を省略
  If qシート名 = "" Then
    wMSG = "シート名を指定してください。"
    MsgBox wMSG, vbOKOnly + vbExclamation, "確認"
    Exit Function
  End If

  'Book名を省略
  If qブック名 = "" Then
    wBook = ThisWorkbook.Name
  Else
    wBook = qブック名
  End If
  
  'パス指定がない
  If InStr(wBook, "\") = 0 Then
    wPath = ThisWorkbook.Path
    wFile = wPath & "\" & wBook
  Else
    wFile = wBook
  End If
  
  wFL = f_ファイル判定(wFile, q警告)
  If wFL = 0 Then Exit Function
  
  'ExcelBookを判定(xlsx/xlsm)
  
  'Book Open を判定
  wBook = fyPickFile(wFile)
  
  wFL = f_ブックオープン判定(wBook, False)
  If wFL = 0 Then
    wMSG = "ブック（" & wBook & "）が、開いていません。" & vbCrLf & _
           "オープンしますか？"
    wFLMsg = MsgBox(wMSG, vbYesNo + vbQuestion, "確認")
    If wFLMsg = vbYes Then
      'Workbooks.Open FileName:=wFile
      Set wVar = Workbooks.Open(wFile)
      
      If TypeName(wVar) <> "Workbook" Then
        wMSG = "オープンできません。"
        MsgBox wMSG, vbOKOnly + vbExclamation, "確認"
        Exit Function
      End If
    Else
      Exit Function
    End If
  End If
  
  If fyIsSheet(wBook, qシート名) = True Then
    If wFL = 0 Then
      '初期Close
      f_シート判定 = 2
    Else
      '初期Open
      f_シート判定 = 1
    End If
  End If
  
  'Bookを閉じる
  If wFL = 1 And q閉じる = True Then
    Workbooks(wBook).Close savechanges:=False
  End If
End Function

'2020/07/20 --------------------------------------------------*
Function f_シート追加(qシート名 As String, qブック名 As String) As Integer
  '
  '【構文】  f_シート追加("<シート名>","<ブック名>")
  '【戻り値】成功:1 失敗:0
  '
  Dim wFL     As Integer
  Dim wBook   As String

  f_シート追加 = 0
  
  'Book名省略
  If qブック名 = "" Then
    wBook = ThisWorkbook.Name
  Else
    wBook = qブック名
  End If
  
  'Bookを判定
  wFL = f_ファイル判定(wBook, True)
  If wFL = 0 Then Exit Function
  
  'オープン判定
  'シート名省略
  
  
  'シート追加
  With Workbooks(wBook)
    .Worksheets.Add
  End With

  f_シート追加 = 1
End Function

'2020/06/01 --------------------------------------------------*
Function f_シート表示(qシート名 As String, qブック名 As String) As Integer
  '
  '【構文】  f_シート表示("<シート名>","<ブック名>")
  '【戻り値】成功:1 失敗:0
  '
  Dim wFL     As Integer
  Dim wBook   As String
  
  f_シート表示 = 0
  
  'Book名省略
  If qブック名 = "" Then
    wBook = ThisWorkbook.Name
  Else
    wBook = qブック名
  End If
  
  'Bookを判定
  wFL = f_ファイル判定(wBook, True)
  If wFL = 0 Then Exit Function
  
  'Sheetを判定
  wFL = f_シート判定(qシート名, qブック名, False, True)
  If wFL = 0 Then Exit Function
  
  'シート表示
  With Workbooks(wBook)
    .Worksheets(qシート名).Activate
  End With
  
  f_シート表示 = 1
End Function

'2020/07/26 --------------------------------------------------*
Function f_シートメニュー(qクリック表示 As String, q非表示シート As String, qメニュー初期値 As Integer) As String
  '
  '【構文】　f_シートメニュー("<クリック表示>","<非表示シート>",メニュー初期値)
  '【戻り値】選択したシート名。[中止]したときは 空白 を返します。
  '
  Dim WSH         As Worksheet
  Dim wMyBook     As String
  Dim wMySheet    As String
  Dim w非表示     As String
  Dim wSName      As String
  Dim wNO         As Integer
  Dim wMenuList   As String
  Dim wSheet(100) As String
  
  wMyBook = ThisWorkbook.Name
  w非表示 = q非表示シート & ",,,"
  wMenuList = ""
  wNO = 0
  
  For Each WSH In Workbooks(wMyBook).Worksheets
    wSName = WSH.Name
  
    'w非表示Sheetは、リストに追加しない
    If InStr(w非表示, wSName & ",") = 0 Then
      wNO = wNO + 1
      wSheet(wNO) = wSName
      wMenuList = wMenuList & wSName & ","
    End If
  Next
  
  If wMenuList <> "" Then
    wMenuList = Left(wMenuList, Len(wMenuList) - 1)
  End If
  
  '【f_メニュー】
  ygSTR1 = "$シートメニュー$"
  ygSTR2 = wMenuList
  ygSTR3 = "シートを選択してください"
  ygSTR4 = qクリック表示
  ygInt1 = qメニュー初期値
  Fy_メニュー.Show vbModal
  
  f_シートメニュー = wSheet(ygInt1)

End Function

'2020/07/25 --------------------------------------------------*
Function f_条件日付(q日付初期値 As String, q範囲指定 As String) As String
  '
  '【構文】　f_条件日付("<日付初期値>","範囲指定")
  '【戻り値】入力した日付。[中止]したときは 空白 を返します。
  '
  Dim wMSG  As String
  
  f_条件日付 = ""
  
  '初期化
  yg日付 = "": yg日付ST = "": yg日付ED = ""
  
  Select Case True
    'しない（日付入力）
    Case (q範囲指定 = "しない" Or q範囲指定 = "")
      yg日付 = q日付初期値
      Fy_条件日付.Show vbModal
      If ygEnd = 0 Then Exit Function
      
      f_条件日付 = yg日付
    
    'する（日付範囲入力）
    Case (q範囲指定 = "する")
      yg日付 = q日付初期値
      Fy_条件日付範囲.Show vbModal
      If ygEnd = 0 Then Exit Function
      
      f_条件日付 = yg日付ST & " ～ " & yg日付ED
    
    'エラー
    Case Else
      wMSG = "範囲指定は、'する' 'しない' を指定してください。（省略可）"
      MsgBox wMSG, vbOKOnly + vbExclamation, "確認"
  End Select
End Function

'2020/10/06 --------------------------------------------------*
Function f_条件年月(q年月初期値 As String, q範囲指定 As String, qメッセージ As String) As String
  '
  '【構文】　f_条件年月("<年月初期値>","範囲指定","メッセージ")
  '【戻り値】入力した年月(yyyy/mm)。[中止]したときは 空白 を返します。
  '
  Dim wMSG  As String
  
  f_条件年月 = ""
  
  '初期化
  yg年月 = "": yg年月ST = "": yg年月ED = ""
  
  'メッセージ
  ygSTR1 = qメッセージ
  
  Select Case True
    'しない（年月入力）
    Case (q範囲指定 = "しない" Or q範囲指定 = "")
      yg年月 = q年月初期値
      Fy_条件年月.Show vbModal
      If ygEnd = 0 Then Exit Function
      
      f_条件年月 = yg年月
    
    'する（年月範囲入力）
    Case (q範囲指定 = "する")
      yg年月 = q年月初期値
      Fy_条件年月範囲.Show vbModal
      If ygEnd = 0 Then Exit Function
      
      f_条件年月 = yg年月ST & " ～ " & yg年月ED
    
    'エラー
    Case Else
      wMSG = "範囲指定は、'する' 'しない' を指定してください。（省略可）"
      MsgBox wMSG, vbOKOnly + vbExclamation, "確認"
  End Select
End Function

'2020/06/01 --------------------------------------------------*
Function f_ダイヤログ(q取得属性 As String, q初期フォルダ As String) As String
  '
  '【構文】  f_ダイヤログ("<取得属性>","<初期フォルダ>")
  '【戻り値】成功:ファイル名/フォルダ名 失敗:空白
  '
  Dim wIniFilename  As String
  
  f_ダイヤログ = ""
  
  If Not (q取得属性 = "ファイル" Or q取得属性 = "フォルダ") Then Exit Function
  
  If q初期フォルダ = "" Then
    wIniFilename = ThisWorkbook.Path
  Else
    wIniFilename = q初期フォルダ
  End If
  
  'フォルダ
  If q取得属性 = "フォルダ" Then
    With Application.FileDialog(msoFileDialogFolderPicker)
      .InitialFileName = ""
      .Title = "フォルダ ダイイアログ"
      If .Show = True Then
        f_ダイヤログ = .SelectedItems(1)
      End If
    End With
  End If
  
  'ファイル
  If q取得属性 = "ファイル" Then
    With Application.FileDialog(msoFileDialogOpen)
      .Title = "ファイル ダイイアログ"
      If .Show = True Then
          f_ダイヤログ = .SelectedItems(1)
      End If
    End With
  End If
  
End Function

'2020/12/25 --------------------------------------------------*
Function f_テーブル解除(qシート名 As String, qテーブル名 As String) As Integer
  '
  '【構文】  f_テーブル解除("<シート名>","<テーブル名>",<セル範囲>)
  '【戻り値】成功:1 失敗:0 見つからない:-1
  '
  Dim WSH    As Worksheet
  Dim LST    As ListObject
  Dim wBook  As String
  Dim wMSG   As String
  Dim wFL    As Integer
  Dim wTblName As String
  Dim wRange   As String
  
  wFL = -1
  wBook = ThisWorkbook.Name
  
  'テーブル名
  If qテーブル名 = "" Then
    wTblName = "DataTableYUGE"
  Else
    wTblName = qテーブル名
  End If
  
  For Each WSH In Workbooks(wBook).Worksheets
    If qシート名 = WSH.Name Then
      wFL = 0
      
      For Each LST In WSH.ListObjects
        If wTblName = LST.Name Then
          '(解除)
          WSH.ListObjects(wTblName).Unlist
          wFL = 1
          Exit For
        End If
        
        If wFL = 0 Then Exit For
      Next LST
    End If
  Next WSH
  
  'シート名なし
  If wFL = -1 Then
    wMSG = "シート（" & qシート名 & "）が、見つかりません。"
    MsgBox wMSG, vbOKOnly + vbExclamation, "確認"
  End If
  
  'テーブル名なし
  If wFL = 0 Then
    wMSG = "テーブル名（" & wTblName & "）が、見つかりません。"
    MsgBox wMSG, vbOKOnly + vbExclamation, "確認"
  End If

  f_テーブル解除 = wFL
  If wFL <> 1 Then Exit Function
  
  wRange = Sheets(qシート名).UsedRange.Address
  
  With Workbooks(wBook).Worksheets(qシート名).Range(wRange)
    '太字解除
    .Font.Bold = False
    
    '塗りつぶしなし
    .Interior.Pattern = xlNone
    .Interior.TintAndShade = 0
    .Interior.PatternTintAndShade = 0
    
    '罫線なし
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
  End With
End Function

'2020/12/25 --------------------------------------------------*
Function f_テーブル作成(qシート名 As String, qテーブル名 As String, qセル範囲 As String) As Integer
  '
  '【構文】  f_テーブル作成("<シート名>","<テーブル名>",<セル範囲>)
  '【戻り値】成功:1 失敗:0 見つからない:-1
  '
  Dim wRange   As String
  Dim wTblName As String
  Dim wBook    As String
  Dim NM       As Name
  
  f_テーブル作成 = 0
  
  Application.CutCopyMode = False
  'テーブル名
  If qテーブル名 = "" Then
    wTblName = "DataTableYUGE"
  Else
    wTblName = qテーブル名
  End If
  
  If fyIsTableName("", wTblName) = True Then
    ygInt1 = f_テーブル解除(qシート名, wTblName)
  End If
  
  'セル範囲
  If qセル範囲 = "" Then
    wRange = Sheets(qシート名).UsedRange.Address
  Else
    wRange = qセル範囲
  End If
  
  Sheets(qシート名).ListObjects.Add(xlSrcRange, Range(wRange), , xlYes).Name = "DataTableYUGE"
  
  f_テーブル作成 = 1
End Function

'2020/06/05 --------------------------------------------------*
Function f_ファイルオープン(qファイル名 As String, qエラー表示指定 As Boolean) As Integer
  '
  '【構文】  f_ファイルオープン("<ファイル名>",<エラー表示指定>)
  '【戻り値】成功:1 失敗:0 見つからない:-1
  '
  Dim wFL     As Integer
  Dim wMSG    As String
  Dim WSH
  
  f_ファイルオープン = 0
  
  wFL = f_ファイル判定(qファイル名, qエラー表示指定)
  If wFL = 0 Then
    f_ファイルオープン = -1
    Exit Function
  End If
  
  Set WSH = CreateObject("Wscript.Shell")
  WSH.Run qファイル名, 3   '3:最大化された状態で起動します。選択状態になります。
  Set WSH = Nothing
  
  f_ファイルオープン = 1
  
End Function

'2020/06/03 --------------------------------------------------*
Function f_ファイル判定(qファイル名 As String, qエラー表示指定 As Boolean) As Integer
  '
  '【構文】  f_ファイル判定("<ファイル名>",<エラー表示指定>)
  '【戻り値】成功:1 失敗:0
  '
  Dim wMSG    As String
  Dim wPath   As String
  Dim wFile   As String
  Dim wFolder As String
  
  f_ファイル判定 = False
  
  'ファイル名を省略
  If qファイル名 = "" Then
    wMSG = "ファイルを指定してください。"
    MsgBox wMSG, vbOKOnly + vbExclamation, "確認"
    Exit Function
  End If
  
  '拡張子がない
  If InStr(qファイル名, ".") = 0 Then
    wMSG = "ファイル名に拡張子を記述してください。"
    MsgBox wMSG, vbOKOnly + vbExclamation, "確認"
    Exit Function
  End If
  
  'パス指定がない
  If InStr(qファイル名, "\") = 0 Then
    wPath = ThisWorkbook.Path
    wFile = wPath & "\" & qファイル名
  Else
    wFile = qファイル名
  End If
  
  'ファイルがない
  If Dir(wFile) = "" Then
    If qエラー表示指定 = True Then
      wMSG = "フォルダ（" & fyPickFolder(wFile) & "）に" & vbCrLf & _
             "ファイル（" & fyPickFile(wFile) & "）が、見つかりません。"
      MsgBox wMSG, vbOKOnly + vbExclamation, "確認"
    End If
    Exit Function
  End If
  
  f_ファイル判定 = True
End Function

'2020/06/03 --------------------------------------------------*
Function f_ブックオープン判定(qブック名 As String, qエラー表示指定 As Boolean) As Integer
  '
  '【構文】  f_ブックオープン判定("<ブック名>",<エラー表示指定>)
  '【戻り値】成功:1 失敗:0
  '
  Dim wMSG    As String
  Dim wBook   As Workbook
  
  f_ブックオープン判定 = 0
  
  'Book名を省略
  If qブック名 = "" Then
    wMSG = "ブック名を指定してください。"
    MsgBox wMSG, vbOKOnly + vbExclamation, "確認"
    Exit Function
  End If
  
  'OpenBookをチェック
  For Each wBook In Workbooks
    If wBook.Name = qブック名 Then
      f_ブックオープン判定 = 1
      Exit Function
    End If
  Next wBook
  
  'Not Open
  If qエラー表示指定 = True Then
    wMSG = "フォルダ（" & qブック名 & "）は、開いていません。"
    MsgBox wMSG, vbOKOnly + vbExclamation, "確認"
  End If
End Function

'2020/07/20 --------------------------------------------------*
Function f_メニュー(qタイトル As String, qメニューリスト As String, qメッセージ As String, qメニュー初期値 As Integer) As Integer
  '
  '【構文】　f_メニュー("<タイトル>","<メニュー1>,<メニュー2>,・・・","<メーッセージ>",メニュー初期値)
  '【戻り値】選択したメニュー番号。[中止]したときは 0 を返します。
  '
  ygSTR1 = qタイトル
  ygSTR2 = qメニューリスト
  ygSTR3 = qメッセージ
  ygInt1 = qメニュー初期値
  Fy_メニュー.Show vbModal
  
  f_メニュー = ygInt1
End Function

'2020/11/13 --------------------------------------------------*
Function f_タイマー開始(q間隔秒 As Long, qマクロ名 As String) As Long
  '
  '【構文】　f_タイマー開始(間隔(秒))
  '【戻り値】[失敗]したときは 0 を返します。成功した時は、0 以外
  '
  On Error GoTo subError
  Dim wMsgStr   As String
  Dim wElapse   As Long
  Dim wTimeST   As String
  Dim wTimeED   As String
  Dim w更新秒   As Long
  
  f_タイマー開始 = 0
  
  '--- エラーチェック ---
  If q間隔秒 <= 0 Then
    wMsgStr = "タイマー間隔(秒)を設定してください。"
    MsgBox wMsgStr, vbOKOnly + vbExclamation, "確認"
    Exit Function
  End If
  
  If qマクロ名 = "" Then
    wMsgStr = "マクロ名を指定してください。"
    MsgBox wMsgStr, vbOKOnly + vbExclamation, "確認"
    Exit Function
  End If
  
  '更新時間をチェック
  wTimeST = Format(Time, "hh:mm:ss")
  
  '(マクロ実行)
  ygProcMacro = qマクロ名
  Application.Run ygProcMacro
  
  wTimeED = Format(Time, "hh:mm:ss")
  w更新秒 = (Hour(wTimeED) * 60 * 60 + Minute(wTimeED) * 60 + Second(wTimeED) + 5) - _
            (Hour(wTimeST) * 60 * 60 + Minute(wTimeST) * 60 + Second(wTimeST))
  
  If w更新秒 > q間隔秒 Then
    wMsgStr = "タイマーを停止します。" & vbCrLf & vbCrLf & _
              "更新間隔を " & Str(w更新秒) & " 秒 以上に、設定してください。"
    MsgBox wMsgStr, vbOKOnly + vbExclamation, "確認"
    Exit Function
  End If
  
  wElapse = q間隔秒 * 1000
  
  '(開始)
  ygLngTimerID = SetTimer(0, 0, wElapse, AddressOf TimerProc)
            
  If ygLngTimerID = 0 Then
    MsgBox "タイマーをセットできませんでした。プログラムを再起動してください。" & vbCrLf & vbCrLf & _
           "Timer not created. Ending Program"
           
    f_タイマー開始 = -1
    GoTo subExit
  End If
  
  f_タイマー開始 = ygLngTimerID
  ygBlnTimer = True
  
subExit:
  Exit Function

subError:
  MsgBox Error$ & "(#" & Trim(Trim(Err.Number)) & ")", vbOKOnly + vbExclamation _
  , "確認 : タイマー開始"
  Resume subExit
End Function

'2020/11/13 --------------------------------------------------*
Function f_タイマー停止() As Long
  '
  '【構文】　f_タイマー停止()
  '【戻り値】既に[停止]しているときは 0、成功した時は 1、[失敗]したときは -1 を返します。
  '
  On Error GoTo subError
  Dim wMsgStr As String
  
  f_タイマー停止 = 0
  
  If ygBlnTimer = False Then
    wMsgStr = "タイマーは、停止しています。"
    MsgBox wMsgStr, vbOKOnly + vbExclamation, "確認"
    Exit Function
  End If
  
  '(停止)
  ygLngTimerID = KillTimer(0, ygLngTimerID)
  
  If ygLngTimerID = 0 Then
    f_タイマー停止 = -1
  Else
    f_タイマー停止 = ygLngTimerID
  End If
  
  ygBlnTimer = False
  
subExit:
  Exit Function

subError:
  MsgBox Error$ & "(#" & Trim(Trim(Err.Number)) & ")", vbOKOnly + vbExclamation _
  , "確認 : タイマー停止"
  Resume subExit
End Function

'*************************** EOE100 ***************************
'2020/07/23 --------------------------------------------------*
Function fy対応文字列(qSTR As String, qNUM As Integer) As String
  ' qSTR : ,区切り文字列 "abc,def,ghi"
  ' qNUM : 対応番号
  ' 見つからないときは ""を返す
  Dim wkST  As Integer
  Dim wkED  As Integer
  Dim wkNO  As Integer
  Dim wkMAX As Integer
  
  If fyNz(InStr(qSTR, ","), 0) > 1 And qNUM > 0 Then
    wkED = 0
    wkMAX = 0
    For wkNO = 1 To qNUM
      wkST = wkED + 1
      
      If Mid(qSTR, wkST, 1) = "," Then
        wkED = wkST
      Else
        wkED = fyNz(InStr(wkST + 1, qSTR, ","), 0)
      End If
      
      If wkED = 0 And wkMAX = 0 Then
        wkED = Len(qSTR) + 1
        wkMAX = wkNO
      End If
    
      If wkMAX > 0 And wkNO > wkMAX Then
        wkST = 0
        wkED = 0
        Exit For
      End If
    Next wkNO
    
    If wkST < wkED And wkED - wkST >= 1 Then
      fy対応文字列 = Trim(Mid(qSTR, wkST, wkED - wkST))
    Else
      fy対応文字列 = ""
    End If
  Else
    If qNUM = 1 Then
      fy対応文字列 = Trim(qSTR)
    Else
      fy対応文字列 = ""
    End If
  End If
End Function

'2020/07/23 --------------------------------------------------*
Function fyNz(qVari As Variant, qZero As Variant) As Variant
  ' 構文  : Nz(qVari, "") / Nz(qVari, 0)
  If IsNull(qVari) = True Then
    fyNz = qZero
  Else
    fyNz = qVari
  End If
End Function

'2007/10/14 --------------------------------------------------*
Function fyPickFolder(qFileName As String) As String
'   フルパスのファイル名からフォルダ名を取り出す関数です。
'   例：PickFolder("C:\山田健一\Access\例題.MDB")は
'       "C:\山田健一\Access" を返します。
'       PickFolder("C:\例題.MDB")は "C:\" を返します。
    
    Dim wLen As Integer, wI As Integer, wJ As Integer
    wLen = Len(qFileName)
    For wI = wLen To 1 Step -1
                                     
        wJ = InStr(wI, qFileName, "\")
        If wJ <> 0 Then
            Exit For
        End If
    Next wI
    If wJ = 0 Then
        fyPickFolder = ""
    Else
        fyPickFolder = Mid$(qFileName, 1, wJ - 1)
    End If
End Function

Function fyPickFile(qFileName As String) As String
'   フルパスのファイル名からファイル名を取り出す関数です。
'   例：PickFile("C:\山田健一\Access\例題.MDB")は "例題.MDB" を返します。
    
    Dim wLen As Integer, wI As Integer, wJ As Integer
    wLen = Len(qFileName)
    For wI = wLen To 1 Step -1
                                      
        wJ = InStr(wI, qFileName, "\")
        If wJ <> 0 Then
            Exit For
        End If
    Next wI
    If wJ = 0 Then
        fyPickFile = ""
    Else
        fyPickFile = Mid$(qFileName, wJ + 1, wLen - wJ + 1)
    End If
End Function

Public Function fyPickExtension(qFileName As String) As String
'   ファイル名から拡張子を取り出す関数です。
'   例：PickFile("例題.MDB")は "MDB" を返します。
    
    If InStr(Filename, ".") > 0 Then
      
      If InStr(qFileName, ".") < Len(qFileName) Then
        fyPickExtension = Mid(qFileName, InStr(qFileName, ".") + 1, Len(qFileName) - InStr(qFileName, "."))
      End If
    End If
End Function

'*************************** EOE200 ***************************
'2020/05/13 --------------------------------------------------*
Public Function fyIsSheet(qBook As String, qSheet As String) As Boolean
  'Sheetの存在を判定
  Dim WSH    As Worksheet
  Dim wMSG   As String
  Dim wBook  As String
  
  fyIsSheet = False
  
  'Book名を省略
  If qBook = "" Then
    wBook = ThisWorkbook.Name
  Else
    wBook = qBook
  End If
  
  For Each WSH In Workbooks(wBook).Worksheets
    If qSheet = WSH.Name Then
      '(存在)
      fyIsSheet = True
      Exit For
    End If
  Next
  
  If fyIsSheet = False Then
    wMSG = "シート(" & qSheet & ")が、見つかりません。"
    MsgBox wMSG, vbOKOnly + vbExclamation, "確認"
  End If
End Function

'2020/12/25 --------------------------------------------------*
Public Function fyIsTableName(qBook As String, qTableName As String) As Boolean
  'テーブル定義の存在を判定
  Dim WSH    As Worksheet
  Dim LST    As ListObject
  Dim wBook  As String
  
  fyIsTableName = False
  
  'Book名を省略
  If qBook = "" Then
    wBook = ThisWorkbook.Name
  Else
    wBook = qBook
  End If
  
  For Each WSH In Workbooks(wBook).Worksheets
    For Each LST In WSH.ListObjects
      If qTableName = LST.Name Then
        '(存在)
        fyIsTableName = True
        Exit For
      End If
      If fyIsTableName = True Then Exit For
    Next LST
  Next WSH
End Function