Excel黒字化

``
Dim cnt As Long

Public Sub ChangeCharacterColor(path, flag)

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim i_WksCnt As Integer
    Dim intIdx As Integer
    Dim sName As String
    
    Set wb = Workbooks.Open(path)

    i_WksCnt = wb.Worksheets.Count

    For intIdx = 1 To i_WksCnt
        sName = wb.Worksheets(intIdx).Name
    
        Set ws = wb.Worksheets(intIdx)
        ws.Activate
        ws.Cells.Select
        
        With Selection.Font
        .ColorIndex = 1
        .TintAndShade = 0
        End With
        
        '各シートA1を選択
        ws.Cells(1, 1).Select
        
        If flag = True Then
        
            For i = 1 To ws.Shapes.Count
            With ws.Shapes(i).TextFrame.Characters
                .Font.Color = RGB(0, 0, 0)
            End With
            Next i
        
        End If
        
        
        
        
        
    Next

    '先頭シートに戻す
    Set ws = wb.Worksheets(1)
    ws.Activate

    wb.Save
    wb.Close
    
    Set wb = Nothing


End Sub


'Main procedure
Public Sub Create_BookList_From_Folder(dir)
    Dim MyPath As String
    Dim stKekka As Worksheet
    Set stKekka = ThisWorkbook.Worksheets("FILE_LIST")
    MyPath = dir
    cnt = 1
    With stKekka
        .Cells.ClearContents
        .Cells(1, 2).Value = "対象"
        .Cells(1, 3).Value = "ファイルパス"
        .Cells(1, 4).Value = "フォルダ名"
        .Cells(1, 5).Value = "ファイル名"
    End With
    Call Create_BookList_From_Folder2(MyPath)
End Sub


Private Sub Create_BookList_From_Folder2(MyPath As String)
    Dim buf As String
    Dim stKekka As Worksheet
    Set stKekka = ThisWorkbook.Worksheets("FILE_LIST")

    'ファイルの処理
    buf = dir(MyPath & "\" & "*.*")
    Do While buf <> ""
        If (MyPath & "\" & buf) Like "*.xlsx" Then
            cnt = cnt + 1
            With stKekka
                .Cells(cnt, 3).Value = MyPath & "\" & buf
                .Cells(cnt, 4).Value = MyPath
                .Cells(cnt, 5).Value = buf
            End With
        End If
        buf = dir()
    Loop

    'サブフォルダの数だけ自分自身を呼び出す。
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(MyPath).SubFolders
            Call Create_BookList_From_Folder2(f.path)
        Next f
    End With
End Sub

``

``
Sub CreateFileList_Click()

Dim dir As String

dir = ThisWorkbook.Worksheets("Main").Range("BASE_DIR")

'リスト作成
Create_BookList_From_Folder dir

MsgBox "ファイルリストを作成しました。", vbInformation

End Sub
Sub Kurojika()

    Dim ws As Worksheet
    Dim cnt As Long
    Dim fName As String
    Dim chkVal As String
    Dim bFlag As Boolean
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    
    Set ws = ThisWorkbook.Worksheets("FILE_LIST")
    
    chkVal = ThisWorkbook.Worksheets("Main").Range("TRAGET_OBJ")
    
    bFlag = False
    If chkVal = "オブジェクト対象" Then
        bFlag = True
    End If
    
    cnt = 2
    
    Do
       fName = ws.Cells(cnt, "C")
        
        If fName = "" Then
            Exit Do
        End If
        
        ChangeCharacterColor fName, bFlag
        
        cnt = cnt + 1
    Loop

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "対象ファイルの黒字化が終了しました。", vbInformation

End Sub
``