Option Explicit
Public Const G_Ver As String = "V1.0 "
Public Const G_MSG_TIL As String = "EX_DUMMY調査表作成マン"
Public Const L_SHEET As String = "LST"
Public Const Z_SHEET As String = "Grep整形"
Public Const G_CLR_GLY As Integer = 48 '灰色
Const L_GYO As Integer = 3
Const L_RTS As Integer = 3
Const L_GYO_FDR As Integer = 1
Const L_RTS_FDR As Integer = 3
Const Z_GYO As Integer = 3
Const Z_RTS As Integer = 3
Public iG_Debug As Integer '表示・非表示の制御
Public sGFdr As String
Public sG_SRC As String
Public start_time As Double
Public fin_time As Double
Public t As Long
Public sG_ReasonCd As String
'
' メイン処理
'
Sub Main()
Application.MacroOptions Macro:="Main", ShortcutKey:="j"
Dim wsL As Worksheet: Set wsL = Worksheets(L_SHEET)
Dim wsZ As Worksheet: Set wsZ = Worksheets(Z_SHEET)
Const L_RTS_MAX As Integer = 8
Const Z_RTS_MAX As Integer = 7
' // 共通用
Dim bRC As Boolean
Dim sMsg As String
Dim ArrInFile() As String
Dim sInFile As String
Dim i As Long
Dim iGYO As Integer
Dim iImpLine As Long
Dim iCnt As Integer
Dim iOKCnt As Integer
Dim iNGCnt As Integer
' // LST用
Dim iL_Line As Integer
Dim iL_Cnt As Integer
' -------------------------------
' 初期処理
' -------------------------------
iG_Debug = 1: iL_Cnt = 0
'使用可否のチェック
If EnvSecCheck() = False Then
Exit Sub
End If
Worksheets(L_SHEET).Activate
bRC = FreezePanes(L_SHEET, 3, 4)
' ファイルの記載が開始行になければ、フォルダーの内容を自動セット
If Trim(wsL.Cells(L_GYO, L_RTS)) = "" Then
sGFdr = Trim(wsL.Cells(L_GYO_FDR, L_RTS_FDR))
bRC = FdrFLst(ThisWorkbook.Path & "\" & sGFdr, ".txt", "LST")
End If
ArrInFile = L_Read_To_Arr(wsL, iL_Cnt)
'設定シート内容チェック
bRC = IsSeteiCheck(iL_Cnt)
If bRC = False Then
Exit Sub
End If
If iG_Debug = 1 Then 'リアルタイム時間計測（開始）
bRC = RealTimeDisplay(1, 0, 0)
End If
Application.ScreenUpdating = False ' 描画を停止する
' -------------------------------
' 主処理
' -------------------------------
iOKCnt = 0: iNGCnt = 0
For i = 0 To UBound(ArrInFile)
wsL.Cells(L_GYO + i, L_RTS + 2) = ""
wsL.Cells(L_GYO + i, L_RTS + 3) = ""
wsL.Cells(L_GYO + i, L_RTS + 4) = ""
'一覧ファイルの配列から取り出し
sInFile = ArrInFile(i)
iImpLine = 0
iImpLine = Import_To_GrepRes(sInFile)
If iImpLine > 0 Then
wsL.Cells(L_GYO + i, L_RTS + 2) = iImpLine
Else
wsL.Activate
wsL.Cells(L_GYO + i, L_RTS + 5) = "対象データなし " & sG_ReasonCd
End If
'罫線
'2023.12.24
bRC = Border_Table(wsZ, 2, 1, iImpLine + 1, Z_RTS_MAX)
'印刷設定
bRC = PrintSetup(Z_SHEET, "A", 1, "G", iImpLine, "A3", "縦")
'別ブックへ出力してSTATUSを更新
bRC = BookCopyAndStatus(wsZ, iImpLine, i, sInFile, iOKCnt, iNGCnt)
'2023.12.24 ---
If iNGCnt > 0 Then
wsL.Cells(L_GYO + i, L_RTS + 3) = "コピー失敗"
End If
' -------------
If iG_Debug = 1 Then 'リアルタイム時間計測（終了）
bRC = RealTimeDisplay(2, i + 1, UBound(ArrInFile) + 1)
End If
Next i
' -------------------------------
' 終了処理
' -------------------------------
Application.ScreenUpdating = True ' 描画を再開する
Worksheets(L_SHEET).Activate
'印刷設定
bRC = PrintSetup(L_SHEET, "C", 1, "K", i + 1, "A4", "縦")
wsL.Cells(2, 3) = "TEXT"
bRC = CheckHostMemLine(L_SHEET, 3, 3) 'シート,検索開始行,開始列
'リスト結果をブックへ書き出す
If LstBookCopy("リスト結果", L_SHEET) = True Then
Debug.Print "リスト結果 " & "正常"
Else
Debug.Print "リスト結果 " & "異常"
End If
'処理・未処理
sMsg = "処理終了" & vbCrLf & _
vbCrLf & _
L_SHEET & " シート " & vbCrLf & _
" Entry Folder : " & sGFdr & vbCrLf & _
" Entry Member : " & vbCrLf & _
" OK " & vbTab & iOKCnt & " 件" & vbCrLf & _
" NG " & vbTab & iNGCnt & " 件"
MsgBox sMsg, , G_MSG_TIL
Exit Sub
SManError:
MsgBox "ファイルを開けません ", vbExclamation
End Sub
'
' テキストファイルを読み込む
Public Function Import_To_GrepRes(sInFile As String) As Integer
Dim wsZ As Worksheet: Set wsZ = Worksheets(Z_SHEET)
Dim FS
Set FS = CreateObject("Scripting.FileSystemObject")
'テキストファイルから読み込み（Shift-JIS）
Dim bRC As Boolean
Dim sRec As String
Dim j As Integer
Dim i As Integer
'2023.12.24
Dim jCnt As Integer
Dim iPos As Integer
Dim iErrFG As Integer
Dim iSlen As Integer
Dim iELen As Integer
Dim iCMNT_RTS As Integer
Dim iPATH_RTS As Integer
Dim iFILE_RTS As Integer
Dim iCHRGYO_RTS As Integer
Dim iValue_RTS As Integer
Dim iDD_RTS As Integer
Dim iSep0Pos As Integer ' _COPY_JCL
Dim iSep1Pos As Integer ' \
Dim iSep2Pos As Integer ' (
Dim iSep3Pos As Integer ' )
Dim iSep4Pos As Integer ' //
Dim iSep5Pos As Integer ' DD
iErrFG = 0
Import_To_GrepRes = False
' テキストインポート
If sGFdr = "" Then
sG_SRC = ThisWorkbook.Path & "\" & sInFile
Else
sG_SRC = ThisWorkbook.Path & "\" & sGFdr & "\" & sInFile
End If
bRC = FS.FileExists(sG_SRC)
If bRC = False Then
'// 入力テキストファイルなし
sG_ReasonCd = "E001"
Exit Function
End If
iCMNT_RTS = 1: iPATH_RTS = 2: iFILE_RTS = 3: iCHRGYO_RTS = 4: iValue_RTS = 5: iDD_RTS = 6
bRC = Format_Z(0)
'2023.12.24
i = 0: j = 2: jCnt = 0
Open sG_SRC For Input As #1
Do Until EOF(1)
Line Input #1, sRec
iSep0Pos = InStr(sRec, "_COPY_JCL")
iSep1Pos = InStrRev(sRec, "\")
If iSep1Pos > 0 And iSep0Pos > 0 Then
'2023.12.24
jCnt = jCnt + 1
'NO
wsZ.Cells(j, iPATH_RTS - 1) = jCnt
'フォルダパス
wsZ.Cells(j, iPATH_RTS) = Mid(sRec, 1, iSep1Pos - 1)
'ファイル名
iSep2Pos = InStr(iSep1Pos, sRec, "(")
wsZ.Cells(j, iFILE_RTS) = Mid(sRec, iSep1Pos + 1, iSep2Pos - iSep1Pos - 1)
'ファイル内の位置
iSep3Pos = InStr(iSep2Pos, sRec, ")")
wsZ.Cells(j, iCHRGYO_RTS) = Mid(sRec, iSep2Pos, iSep3Pos - iSep2Pos + 1)
'検索値
iSep4Pos = InStr(iSep3Pos, sRec, "//")
wsZ.Cells(j, iValue_RTS) = Mid(sRec, iSep4Pos)
If Mid(sRec, iSep4Pos, 3) = "//*" Then
wsZ.Cells(j, iCMNT_RTS) = 1
wsZ.Range(wsZ.Cells(j, iCMNT_RTS), wsZ.Cells(j, iValue_RTS)).Interior.ColorIndex = G_CLR_GLY
End If
'DD名
iSep5Pos = InStr(iSep4Pos, sRec, " DD ")
wsZ.Cells(j, iDD_RTS) = Trim(Mid(sRec, iSep4Pos, iSep5Pos - iSep4Pos))
'引当（除外DD名）
wsZ.Range("G" & j).Formula = _
"=IFERROR(VLOOKUP($F" & j & ",除外DUMMY!$B:$C,2,false)," & """""" & ")"
j = j + 1
End If
i = i + 1
Loop
Close #1
'2023.12.24
'If iErrFG = 0 Then
' Import_To_GrepRes = i - 1
'End If
Import_To_GrepRes = jCnt
End Function
' LSTシートの内容を配列へ保管
Public Function L_Read_To_Arr(wsL As Worksheet, _
ByRef iL_Cnt As Integer) As String()
Dim i As Long
Dim iGYO As Long
Dim iCnt As Long
Dim tmp() As String
'配列件数を求める
iGYO = L_GYO
i = 0
Do Until _
Trim(wsL.Cells(iGYO, L_RTS)) = ""
iGYO = iGYO + 1
i = i + 1
Loop
iCnt = i
If i > 0 Then
ReDim tmp(i - 1)
' 一時的に配列へ格納する
iGYO = L_GYO
For i = 0 To iCnt - 1
tmp(i) = UCase(Trim(wsL.Cells(iGYO, L_RTS)))
'Debug.Print sArray(i)
iGYO = iGYO + 1
Next i
End If
' 戻値
iL_Cnt = iCnt
L_Read_To_Arr = tmp
End Function
'
' HOST行数との照合
Public Function CheckHostMemLine(SHName As String, _
iGYO As Integer, _
iRTS As Integer) As Boolean
Dim ws As Worksheet: Set ws = Worksheets(L_SHEET)
Dim iEndRow As Double
Dim i As Integer
Dim sFileName As String
Dim sFDPath As String
'最終行の取得
iEndRow = ws.Cells(iGYO - 1, iRTS).End(xlDown).Row
sFDPath = ThisWorkbook.Path & "\" & Trim(ws.Cells(1, 3))
For i = iGYO To iEndRow
'HSIZE
sFileName = sFDPath & "\" & Trim(ws.Cells(i, 3))
'照合
ws.Range("K" & i).Formula = _
"=IF($I" & i & "=" & "$J" & i & "," & """〇""" & "," & """X""" & ")"
Next i
End Function
'
' テキストファイルの行数を求める
Public Function GetLineCount(filelName As String) As Long
Dim fso1 As Object
Dim lineCount As Long
Set fso1 = CreateObject("Scripting.FIleSystemObject")
'ファイルの行数取得
lineCount = 0
If fso1.FileExists(filelName) Then
lineCount = fso1.OpenTextFile(filelName, 8).Line
Set fso1 = Nothing
GetLineCount = lineCount - 1
Else
GetLineCount = 0
End If
End Function
'
' リスト外部ブックとして保存
Public Function LstBookCopy(wbNamei As String, SHName As String) As Boolean
Dim wb As Workbook
Dim sMsg As String
Dim sLstBookName As String
Dim sFileNameFull As String
LstBookCopy = False
' 入力ファイル名形式から、出力のブック名を作成する
sLstBookName = "生成目録_" & Trim(SHName) & "_" & _
Format(Date, "yyyymmdd") & "_" & _
Format(Time, "hhmmss") & ".xlsx"
If sGFdr = "" Then
sLstBookName = sGFdr & "\" & sLstBookName
End If
sFileNameFull = ThisWorkbook.Path & "\" & sLstBookName
'// 開いているかチェック
If IsBookOpened(sFileNameFull) = False Then
'// ブックへ書き込
Sheets(Array(SHName)).Copy
Set wb = ActiveWorkbook
Application.DisplayAlerts = False
wb.SaveAs Filename:=sFileNameFull
wb.Close
Application.DisplayAlerts = True
LstBookCopy = True
Else
LstBookCopy = False
sG_ReasonCd = "E009"
End If
End Function
'
'ウインドウ枠の固定
Function FreezePanes(ShName1 As String, iGYO As Integer, iRTU As Integer) As Boolean
Worksheets(ShName1).Activate
Cells(iGYO, iRTU).Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
FreezePanes = True
End Function
'
'*************************
' フォルダの存在確認
Public Function IsExistsFdr(ByVal sPathFdr As String) As Boolean
Dim objFso As Object
Set objFso = CreateObject("Scripting.FIleSystemObject")
If objFso.FolderExists(sPathFdr) Then
IsExistsFdr = True
Else
IsExistsFdr = False
End If
Set objFso = Nothing
End Function
'***************:*********
' フォルダの再作成
Public Function IsExistsFdrAndCreate(ByVal sFdrFullPath As String) As Boolean
Dim objFso As Object
Set objFso = CreateObject("Scripting.FIleSystemObject")
If objFso.FolderExists(sFdrFullPath) Then
IsExistsFdrAndCreate = True
Else
MkDir sFdrFullPath
IsExistsFdrAndCreate = False
End If
Set objFso = Nothing
End Function
'
Public Function FdrFLst(sFD As String, sFilter As String, SHName As String) As Boolean
Dim inputFolder As String
Dim outputWs As Worksheet
Dim outputColumn As Long
Dim outputRow As Long
Dim fso As Object
'Dim file As String
Dim file
inputFolder = sFD
Set outputWs = Worksheets(SHName)
'出力行・列
outputRow = 3
outputColumn = 3
Set fso = CreateObject("Scripting.FIleSystemObject")
'ファイル数分の繰り返し
For Each file In fso.GetFolder(inputFolder).Files
If InStr(file.Name, sFilter) > 0 Or _
InStr(file.Name, UCase(sFilter)) > 0 Then
'出力シートへファイル名を出力
outputWs.Cells(outputRow, outputColumn) = file.Name
outputRow = outputRow + 1
End If
Next
outputWs.Columns(outputColumn).AutoFit
Set fso = Nothing
End Function
'
Public Function Format_LST() As Boolean
Dim wsL As Worksheet: Set wsL = Worksheets(L_SHEET)
Dim bRC As Boolean
wsL.Activate
ActiveWindow.Zoom = 100
ActiveWindow.DisplayGridlines = False
'罫線クリヤー
wsL.Cells.Borders.LineStyle = xlLineStyleNone
' フォント
With Worksheets(L_SHEET).Cells.Font
.Name = "BIZ UDゴシック"
.Size = 11
End With
' 枠の固定
bRC = FreezePanes(L_SHEET, 3, 3)
' //
wsL.Columns("C:I").AutoFit
'カーソル位置を設定
wsL.Activate
wsL.Cells(1, 1).Select
' // 戻値
Format_LST = True
End Function
'
Public Function Format_Z(iG_Debug As Integer) As Boolean
Const Z_RTS_MAX As Integer = 7
Dim wsZ As Worksheet: Set wsZ = Worksheets(Z_SHEET)
Dim bRC As Boolean
wsZ.Activate
ActiveWindow.Zoom = 100
ActiveWindow.DisplayGridlines = False
'クリヤー
With Worksheets(Z_SHEET)
.Cells.Clear
End With
' フォント
With Worksheets(Z_SHEET).Cells.Font
.Name = "BIZ UDゴシック"
.Size = 11
End With
' フィルター設定
wsZ.Range("A:G").AutoFilter
' 枠の固定
bRC = FreezePanes(Z_SHEET, 2, 3)
'カーソル位置を設定
wsZ.Cells(1, 1).Select
'
With wsZ.Range(wsZ.Cells(1, 1), wsZ.Cells(1, 7))
.Rows.AutoFit
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Font.Bold = True
' 罫線
.Borders.LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Font.Color = vbWhite
.Interior.Color = vbRed
End With
' // タイトル
With wsZ.Cells(1, 1)
.Offset(0, 0).Value = "DUMMY定義がコメント"
.Offset(0, 1).Value = "フォルダーパス"
.Offset(0, 2).Value = "ファイル名"
.Offset(0, 3).Value = "ファイル内のDUMMY定義の位置"
.Offset(0, 4).Value = "DUMMY定義値"
.Offset(0, 5).Value = "DD名"
.Offset(0, 6).Value = "確認除外（「除外DUMMY」シートと引当）"
End With
With wsZ.Columns("A:A")
' // 列幅
.Offset(0, 0).ColumnWidth = 2 '
.Offset(0, 1).ColumnWidth = 80 '
.Offset(0, 2).ColumnWidth = 30 '
.Offset(0, 3).ColumnWidth = 8 '
.Offset(0, 4).ColumnWidth = 65 '
.Offset(0, 5).ColumnWidth = 20 '
.Offset(0, 6).ColumnWidth = 10 '
' // 列の中央合わせ
.Offset(0, 0).HorizontalAlignment = xlCenter '
.Offset(0, 6).HorizontalAlignment = xlCenter '
End With
' // 戻値
Format_Z = True
End Function
'
' 外部ブックとして保存
Public Function BookCopy(i As Long, _
sInFile As String, _
SHName As String, _
ImpLine As Long) As Boolean
Dim wb As Workbook
Dim bRC As Boolean
Dim sFileNameFull As String
Dim sBookName As String
Dim sMsg As String
' 入力ファイル名形式から、出力のブック名を作成する
sBookName = Mid(sInFile, 1, InStr(1, sInFile, ".TXT") - 1) & _
"_JCL" & ".xlsx"
If sGFdr = "" Then
sFileNameFull = ThisWorkbook.Path & "\結果\" & sBookName
Else
sFileNameFull = ThisWorkbook.Path & "\" & sGFdr & "\結果\" & sBookName
End If
'// 開いているかチェック
If IsBookOpened(sFileNameFull) = False Then
'// ブックへ書込
Sheets(Array(SHName, "除外DUMMY")).Copy
Set wb = ActiveWorkbook
Application.DisplayAlerts = False
wb.SaveAs Filename:=sFileNameFull
wb.Close
Application.DisplayAlerts = True
BookCopy = True
Else
BookCopy = False
sG_ReasonCd = "E003"
End If
End Function
'
' 外部ブックとしてSTATUS更新
Public Function BookCopyAndStatus(wsZ As Worksheet, _
iImpLine As Long, _
i As Long, _
sInFile As String, _
ByRef iOKCnt As Integer, _
ByRef iNGCnt As Integer) As Boolean
'別ブックへ結果出力
If BookCopy(i, sInFile, Z_SHEET, iImpLine) = True Then
If iImpLine > 0 Then
iOKCnt = iOKCnt + 1
Else
iNGCnt = iNGCnt + 1
End If
Else
'// 読取行数がない場合
iNGCnt = iNGCnt + 1
wsZ.Cells(L_GYO + i, L_RTS + 4) = "NG"
End If
End Function
'
' 入力件数を受取り、確認画面を表示する
Public Function IsSeteiCheck(iCnt As Integer) As Boolean
Const L_GYO_FDR As Integer = 1
Const L_RTS_FDR As Integer = 3
Dim iRC As Integer
Dim sMsg As String
Dim sBookPath As String
Dim wsL As Worksheet: Set wsL = Worksheets(L_SHEET)
IsSeteiCheck = False
'// 入力ファイルの保管フォルダ
sGFdr = Trim(wsL.Cells(L_GYO_FDR, L_RTS_FDR))
If sGFdr <> "" Then
If IsExistsFdr(ThisWorkbook.Path & "\" & sGFdr) = False Then
MsgBox "E005 :入力フォルダなし " & sGFdr, vbExclamation, G_MSG_TIL
Exit Function
End If
End If
sBookPath = ThisWorkbook.Path 'パスの取得
sMsg = " 場所 " & vbTab & ThisWorkbook.Path & vbCrLf & _
" BOOK : " & vbTab & ThisWorkbook.Name & vbCrLf & _
" SHEET: " & vbTab & L_SHEET & vbCrLf & _
" " & vbCrLf & _
" FDR " & sGFdr & vbCrLf & _
" 件数 " & vbTab & iCnt
If iCnt = 0 Then
sMsg = "E001 :入力テキストファイルなし " & vbCrLf & sMsg
MsgBox sMsg, vbExclamation, G_MSG_TIL
IsSeteiCheck = False
Else
sMsg = "処理開始 " & vbCrLf & sMsg
iRC = MsgBox(sMsg, vbYesNo + vbInformation, G_MSG_TIL)
If iRC <> vbYes Then
sMsg = "処理中止"
MsgBox sMsg, vbExclamation, G_MSG_TIL
IsSeteiCheck = False
Else
'結果フォルダの作成
Dim bRC As Boolean
bRC = IsExistsFdrAndCreate(ThisWorkbook.Path & "\" & sGFdr & "\結果")
IsSeteiCheck = True
End If
End If
End Function
'
' 実行時間の表示
Public Function RealTimeDisplay(iFG As Integer, _
iCnt As Long, _
iMaxCnt As Long) As Boolean
RealTimeDisplay = False
If iFG = 1 Then '//開始
start_time = Timer
End If
If iFG = 2 Then '//終了
Application.StatusBar = _
" 回数 " & iCnt & _
" / " & iMaxCnt & _
" 経過時間: " & _
Int((Timer - start_time) / 3600) & "時間" & _
Int((Timer - start_time) / 60) Mod 60 & "分" & _
Int(Timer - start_time) Mod 60 & "秒" & _
Int(100 * ((Timer - start_time) - Int(Timer - start_time)))
DoEvents
End If
RealTimeDisplay = True
End Function
'
' //*****************************
' //* 共通利用
' //*****************************
'
' テーブル罫線描画
Function Border_Table(ws As Worksheet, _
iGYO_S As Long, iRTS_S As Long, _
iGYO_E As Long, iRTS_E As Long) As Boolean
Border_Table = False
'極細線
With ws.Range(ws.Cells(iGYO_S, iRTS_S), ws.Cells(iGYO_E, iRTS_E))
.Borders.Weight = xlThin
.Borders.LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
End With
' // 戻値
Border_Table = True
End Function
'
' ブックが開いているかの確認
Function IsBookOpened(a_sFilePath) As Boolean
On Error Resume Next
'// 保存済みのブックか判定
Open a_sFilePath For Append As #1
Close #1
If Err.Number > 0 Then '// 既に開かれている場合
IsBookOpened = True
Else '// 開かれていない場合
IsBookOpened = False
End If
End Function
'
Public Function IsExistsSheet(ByVal SHName As String)
Dim ws As Variant
For Each ws In Sheets
If LCase(ws.Name) = LCase(SHName) Then
IsExistsSheet = True ' 存在する
Exit Function
End If
Next
' 戻値
IsExistsSheet = False
End Function
'
'印刷設定
Public Function PrintSetup(SHName As String, _
S_col As String, S_row As Long, _
E_col As String, E_row As Long, _
sSize As String, sHoukou As String) As Boolean
PrintSetup = False
If sSize = "A4" Then
If sHoukou = "横" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperA4
.Orientation = xlLandscape
End With
Else
If sHoukou = "縦" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperA4
.Orientation = xlPortrait
End With
Else
Exit Function
End If
End If
Else
If sSize = "A3" Then
If sHoukou = "横" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperA3
.Orientation = xlLandscape
End With
Else
If sHoukou = "縦" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperA3
.Orientation = xlPortrait
End With
Else
Exit Function
End If
End If
Else
If sSize = "B4" Then
If sHoukou = "横" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperB4
.Orientation = xlLandscape
End With
Else
If sHoukou = "縦" Then
With Sheets(SHName).PageSetup
.PaperSize = xlPaperB4
.Orientation = xlPortrait
End With
Else
Exit Function
End If
End If
Else
Exit Function
End If
End If
End If
With Sheets(SHName).PageSetup
'2023.12.24
' 範囲
.PrintArea = S_col & S_row & ":" & E_col & E_row + 1
' 余白
.LeftMargin = Application.CentimetersToPoints(1)
.RightMargin = Application.CentimetersToPoints(1)
.TopMargin = Application.CentimetersToPoints(1)
.BottomMargin = Application.CentimetersToPoints(1)
.HeaderMargin = Application.CentimetersToPoints(0)
.FooterMargin = Application.CentimetersToPoints(0)
' 中央
.CenterHorizontally = True 'CenterVertically
' 向き
.Orientation = xlLandscape ' xlPortrait
' ズーム(すべての列を1ページ)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
'ヘッダーとフッター
.CenterHeader = "&A"
.RightHeader = "&D"
.CenterFooter = "&P" & "/" & "&N"
End With
PrintSetup = True
End Function
'
' 使用可否チェック
Public Function EnvSecCheck() As Boolean
EnvSecCheck = False
Dim sEnv As String
' 今日の日付を取得
Dim today As Date
Const LimitDate As String = "2024/03/01"
Const User1 As String = "xx"
Const User2 As String = "Forza1063Z"
sEnv = "ユーザ" & vbTab & ":" & Environ("USERNAME") & vbCrLf & _
"ドメイン" & vbTab & ":" & Environ("USERDOMAIN") & vbCrLf & _
"PC " & vbTab & ":" & Environ("COMPUTERNAME")
If Environ("USERNAME") = User1 Or _
Environ("USERNAME") = User2 Then
today = Date
If today < LimitDate Then
EnvSecCheck = True
Else
sEnv = "利用期限日を超過しました"
MsgBox sEnv, vbCritical, G_MSG_TIL
End If
Else
sEnv = "利用権限者ではありません"
MsgBox sEnv, vbCritical, G_MSG_TIL
End If
End Function
