Option Explicit
' **********************************************************
' * ファイル名取得マン
' * 入力：３行、５列目
' * 一覧 タイトル：４行目、E～L
'* 内容：５行目
' **********************************************************
Public Const G_MSG_TIL As String = "ファイル名取得マン "
Public Const G_Ver As String = " 1.7"
Public Const J_SHEET As String = "SRC"
Public Const W_GYO_H As Integer = 1
Public Const G_J_INFILE_GYO As Integer = 3
Public Const G_J_INFILE_RTU As Integer = 5
'検索先
Public G_SRC As String
Public G_Grep_Cnt As Long
Public iG_Debug As Integer
Public iGMaxLine As Long
Public iGImpLine As Long
Public G_iLine As Long
Public G_FILE_INFO As String
Public t As Long
Public start_time As Double
Public fin_time As Double
'
'
Sub Main()
'
Application.MacroOptions Macro:="Main", ShortcutKey:="j"
Dim wsJ As Worksheet: Set wsJ = Worksheets(J_SHEET)
Dim bRC As Boolean
Dim sMsg As String
Dim i As Integer
Dim iCnt As Integer
' -------------------------------
' 初期処理
' -------------------------------
'使用可否のチェック
bRC = EnvSecCheck()
If bRC = False Then
Exit Sub
End If
'設定内容チェック
bRC = IsSeteiCheck()
If bRC = False Then
Exit Sub
End If
' SRCシートのフォーマット
bRC = SRC_Format(wsJ)
Application.ScreenUpdating = True ' 描画開始
'
'ウインドウ枠の固定
'bRC = FreezePanes(J_SHEET, 5, 12)
' -------------------------------
' 主処理
' -------------------------------
'テキストファイルをセルへセットする
G_Grep_Cnt = Import_ToWK()
bRC = Set_Duplicate_FileName()
wsJ.Activate
' -------------------------------
' 終了処理
' -------------------------------
bRC = PrintSetup("SRC", 2, G_Grep_Cnt)
'結果をブックへ書き出す
If BookCopyMultiSheeet(J_SHEET) = False Then
Exit Sub
End If
Application.ScreenUpdating = True ' 描画再開
Worksheets(J_SHEET).Activate
sMsg = "処理を終了しました" & vbCrLf & _
vbCrLf & _
J_SHEET & " シート " & vbCrLf & _
" 全数 " & vbTab & G_Grep_Cnt & " 件"
MsgBox sMsg, , G_MSG_TIL & G_Ver
Exit Sub
SManError:
MsgBox "ファイルを開けません ", vbExclamation
End Sub
'
Public Function Import_ToWK() As Integer
Dim wsJ As Worksheet: Set wsJ = Worksheets(J_SHEET)
'テキストファイルから読み込み（Shift-JIS）
Dim sRec As String
Dim bRC As Boolean
Dim j As Long: Dim i As Long
Dim k As Long
Dim l As Long
Dim sPath As String
Dim iPos As Integer
Dim iSepPos As Long
Dim sFileName As String
Dim iPos1 As Integer
Dim iPos2 As Integer
' 列の幅(SRC)
wsJ.Range("A" & W_GYO_H).Cells.ColumnWidth = 1
wsJ.Range("B" & W_GYO_H).Cells.ColumnWidth = 1
wsJ.Range("C" & W_GYO_H).Cells.ColumnWidth = 1
wsJ.Range("D" & W_GYO_H).Cells.ColumnWidth = 6
wsJ.Range("E" & W_GYO_H).Cells.ColumnWidth = 30
'文字型書式
'リアルタイム時計計測
iG_Debug = 1
If iG_Debug = 1 Then
bRC = RealTimeDisplay(1, 0, 0)
End If
i = 0: k = 0
Open G_SRC For Input As #1
Do Until EOF(1)
Line Input #1, sRec
i = i + 1
If sRec <> "" Then
iPos1 = InStrRev(sRec, "\")
iPos2 = InStr(sRec, "[SJIS]")
If InStrRev(sRec, "\") > 0 And InStr(sRec, "[SJIS]") > 0 Then
wsJ.Cells(k + 5, j + 5) = ""
wsJ.Cells(k + 5, j + 6) = ""
wsJ.Cells(k + 5, j + 8) = ""
sRec = Trim(Left(sRec, InStr(sRec, "[SJIS]") - 1))
'
iSepPos = InStrRev(sRec, "\")
'
sPath = Mid(sRec, 1, iSepPos - 1)
sFileName = Mid(sRec, iSepPos + 1)
' Path
wsJ.Cells(k + 5, j + 5) = sPath
wsJ.Cells(k + 5, j + 6) = sFileName
Dim sRes As String
Dim sDCreated As String
Dim sDateLastModified As String
Dim sDateLastAccessed As String
Dim sSize As String
sRes = XGetFileDate(sPath & "\" & sFileName, _
sDCreated, _
sDateLastModified, _
sDateLastAccessed, _
sSize)
wsJ.Cells(k + 5, j + 8) = sDCreated
wsJ.Cells(k + 5, j + 9) = sDateLastModified
wsJ.Cells(k + 5, j + 10) = sDateLastAccessed
wsJ.Cells(k + 5, j + 11) = sSize
'
wsJ.Cells(k + 5, j + 12) = "DEL " & """" & sPath & "\" & sFileName & """"
k = k + 1
'No
wsJ.Cells(k + 5, j + 4) = k
End If
End If
'
If iG_Debug = 1 Then
bRC = RealTimeDisplay(2, i, G_iLine)
If i Mod 50 Then
Application.ScreenUpdating = True ' 描画再開
Else
Application.ScreenUpdating = False ' 描画停止
End If
End If
Loop
Close #1
Import_ToWK = i
End Function
'
'
Public Function Set_Duplicate_FileName() As Boolean
Dim wsJ As Worksheet: Set wsJ = Worksheets(J_SHEET)
Dim k As Long
Set_Duplicate_FileName = False
k = 0
Do Until k > G_Grep_Cnt
' 重複
wsJ.Cells(k + 5, 7).Formula = "=COUNTIF($F$5:$F$" & G_Grep_Cnt & ",$F" & k + 5 & ")"
k = k + 1
Loop
Set_Duplicate_FileName = True
End Function
'
' ファイル日付を取得する
Public Function XGetFileDate(sFile As String, _
ByRef sDCreated As String, _
ByRef sDateLastModified As String, _
ByRef sDateLastAccessed As String, _
ByRef sSize As String) As String
Dim fso As Object
Set fso = CreateObject("Scripting.FIleSystemObject")
XGetFileDate = ""
On Error Resume Next
sDCreated = fso.GetFile(sFile).DateCreated ' 作成日時
sDateLastModified = fso.GetFile(sFile).DateLastModified ' 更新日時
sDateLastAccessed = fso.GetFile(sFile).DateLastAccessed ' アクセス日時
sSize = fso.GetFile(sFile).Size ' サイズ
' 後始末
Set fso = Nothing
'
XGetFileDate = ""
End Function
Public Function SRC_Format(wsJ As Worksheet) As Boolean
SRC_Format = False
' フォント
With Worksheets(J_SHEET).Cells.Font
.Name = "BIZ UDゴシック"
.Size = 11
End With
'列の幅
wsJ.Range("A" & 1).Cells.ColumnWidth = 1
wsJ.Range("B" & 1).Cells.ColumnWidth = 1
wsJ.Range("C" & 1).Cells.ColumnWidth = 1
wsJ.Range("D" & 1).Cells.ColumnWidth = 6
wsJ.Range("E" & 1).Cells.ColumnWidth = 120
wsJ.Range("F" & 1).Cells.ColumnWidth = 120
'文字型書式
'結果タイトルの表示
wsJ.Cells(2, 8).Value = "*** ファイル チェック表 ***"
wsJ.Cells(4, 4).Value = "No."
wsJ.Cells(4, 5).Value = "PATH"
wsJ.Cells(4, 6).Value = "FILE"
wsJ.Cells(4, 7).Value = "重複"
wsJ.Cells(4, 8).Value = "作成"
wsJ.Cells(4, 9).Value = "更新"
wsJ.Cells(4, 11).Value = "サイズ"
wsJ.Columns(7).HorizontalAlignment = xlCenter
wsJ.Columns(8).HorizontalAlignment = xlCenter
SRC_Format = True
End Function
'
'
Public Function IsSeteiCheck() As Boolean
Dim wsJ As Worksheet: Set wsJ = Worksheets(J_SHEET)
Dim iRC As Integer
Dim sMsg As String
Dim sBookPath As String
Dim R_SRC As String
IsSeteiCheck = False
sBookPath = ThisWorkbook.Path 'パスの取得
'シートから読込ファイルを取得する
R_SRC = sGetSeteiValue(wsJ, G_J_INFILE_GYO, G_J_INFILE_RTU)
If R_SRC = "" Then
MsgBox "ファイルなし " & G_SRC, vbCritical, G_MSG_TIL & G_Ver
Exit Function
End If
'
G_SRC = ThisWorkbook.Path & "\" & R_SRC '読込ファイルの絶対パス
G_iLine = GetLineCount(G_SRC) '読込ファイルの行数
If G_iLine <= 0 Then
MsgBox "データなし " & G_SRC, vbCritical, G_MSG_TIL & G_Ver
Exit Function
End If
G_FILE_INFO = GetFileDate(G_SRC) '読込ファイルの日付情報
'
sMsg = " 開始" & vbCrLf & _
" 読込ファイル " & vbCrLf & _
R_SRC & " 件数：" & G_iLine & vbCrLf & _
"情報:" & vbCrLf & G_FILE_INFO
iRC = MsgBox(sMsg, vbYesNo + vbInformation, G_MSG_TIL & G_Ver)
If iRC <> vbYes Then
sMsg = "処理を中止"
MsgBox sMsg, vbExclamation, G_MSG_TIL & G_Ver
Exit Function
End If
'罫線
wsJ.Range("E4:L" & G_iLine + 4).BorderAround LineStyle:=xlContinuous, _
Weight:=xlMedium, Color:=vbRed
'wsJ.Range("M4:N" & G_iLine + 4).BorderAround LineStyle:=xlContinuous, _
' Weight:=xlMedium, Color:=vbBlue
IsSeteiCheck = True
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 GetFileDate(sFile As String) As String
Dim fso As Object
Dim sDCreated As String
Dim sDLastModified As String
Dim sDLastAccessed As String
Set fso = CreateObject("Scripting.FIleSystemObject")
GetFileDate = ""
sDCreated = fso.GetFile(sFile).DateCreated ' 作成日時
sDLastModified = fso.GetFile(sFile).DateLastModified ' 更新日時
sDLastAccessed = fso.GetFile(sFile).DateLastAccessed ' アクセス日時
' 後始末
Set fso = Nothing
'
GetFileDate = " 作成_" & sDCreated & vbCrLf & _
" 更新_" & sDLastModified & vbCrLf & _
" 参照_" & sDLastAccessed
End Function
'
' 外部ブックとして保存
Public Function BookCopyMultiSheeet(ShName1 As String) As Boolean
Dim wb As Workbook
Dim sFileName As String
Dim sFileNameFull As String
Dim sMsg As String
sFileName = "結果_" & G_MSG_TIL & ".xlsx"
sFileNameFull = ThisWorkbook.Path & "\" & sFileName
Sheets(Array(ShName1)).Copy
Set wb = ActiveWorkbook
Application.DisplayAlerts = False
wb.SaveAs filename:=sFileNameFull
wb.Close
Application.DisplayAlerts = True
BookCopyMultiSheeet = True
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 sGetSeteiValue(wsS As Worksheet, _
i As Integer, _
j As Integer) As String
Dim sValue As String
sValue = ""
sValue = Trim(wsS.Cells(i, j).Value)
sGetSeteiValue = sValue
End Function
'
'使用可否チェック
Public Function EnvSecCheck() As Boolean
Dim sEnv As String
EnvSecCheck = False
If Environ("USERNAME") = "AAAAAAAA" Then
EnvSecCheck = True
End If
EnvSecCheck = True
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 IsExistDir(a_sFolder As String) As Boolean
Dim result
result = Dir(a_sFolder, vbDirectory)
If result = "" Then
IsExistDir = False '// フォルダが存在しない
Else
IsExistDir = True '// フォルダが存在する
End If
End Function
'
Public Function IsNum(ByVal G_TOV As String) As Boolean
Dim i As Long
Dim Buf As Variant '配列を指定
IsNum = False
If IsNumeric(G_TOV) = False Then
'MsgBox "設定 分析開始行 " & G_TOV, vbCritical
Exit Function
End If
IsNum = True
End Function
'
Public Function PrintSetup(SHName As String, S_row, E_row As Long) As Boolean
With Sheets(SHName).PageSetup
' 範囲
.PrintArea = "D" & S_row & ":" & "S" & E_row + 3
' 余白
.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
End With
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
