Function getFiles()
Dim i As Integer, FSO As Object, f As Object, path As String
Range("対象表").Clear
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
path = .SelectedItems(1)
End If
End With
Set FSO = CreateObject("Scripting.FileSystemObject")
i = 0
For Each f In FSO.GetFolder(path).Files
If InStr(f.Name, ".xls") <> 0 Then
i = i + 1
Cells(i + 2, 2) = f.path
End If
Next f
Set FSO = Nothing
Names("対象表").RefersTo = Range(Cells(3, 2), Cells(i + 2, 4))
setLine Range("対象表")
End Function
Sub loadFiles()
fileCnt = getFiles()
End Sub
Sub encrypt()
Dim wb As Workbook
Dim i As Integer
Dim path As String
Dim checkFlg As String
Const Pass = "1050014"
Application.ScreenUpdating = False '画面更新を一時停止
Application.DisplayAlerts = False '画面アラートを無効
Dim 行番号 As Long
Set 対象表 = Range("対象表")
' ここで行ごとの処理を行います。
For 行番号 = 1 To 対象表.Rows.Count
path = 対象表.Cells(行番号, 1)
checkFlg = 対象表.Cells(行番号, 2)
If Dir(path) <> "" And path <> "" And checkFlg = "〇" Then
If OptionButton1.Value = True Then 'パスワード保護の場合
Set wb = Workbooks.Open(path)
wb.SaveAs filename:=path, Password:=Pass 'パスワード付与して同名保存
wb.Close savechanges:=True
ElseIf OptionButton2.Value = True Then 'パスワード解除の場合
Set wb = Workbooks.Open(path, Password:=Pass)
wb.SaveAs filename:=path, Password:="" 'パスワード無しで同名保存
wb.Close savechanges:=True
End If
対象表.Cells(行番号, 3) = "○"
i = i + 1 'カウント
Else
対象表.Cells(行番号, 3) = "×"
End If
Next
Application.DisplayAlerts = True '画面アラートを有効
Application.ScreenUpdating = True '画面更新停止を解除
MsgBox i & "件のブックを処理しました。"
End Sub
Sub setLine(rg As Range)
rg.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
Dim i As Integer, FSO As Object, f As Object, path As String
Range("対象表").Clear
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
path = .SelectedItems(1)
End If
End With
Set FSO = CreateObject("Scripting.FileSystemObject")
i = 0
For Each f In FSO.GetFolder(path).Files
If InStr(f.Name, ".xls") <> 0 Then
i = i + 1
Cells(i + 2, 2) = f.path
End If
Next f
Set FSO = Nothing
Names("対象表").RefersTo = Range(Cells(3, 2), Cells(i + 2, 4))
setLine Range("対象表")
End Function
Sub loadFiles()
fileCnt = getFiles()
End Sub
Sub encrypt()
Dim wb As Workbook
Dim i As Integer
Dim path As String
Dim checkFlg As String
Const Pass = "1050014"
Application.ScreenUpdating = False '画面更新を一時停止
Application.DisplayAlerts = False '画面アラートを無効
Dim 行番号 As Long
Set 対象表 = Range("対象表")
' ここで行ごとの処理を行います。
For 行番号 = 1 To 対象表.Rows.Count
path = 対象表.Cells(行番号, 1)
checkFlg = 対象表.Cells(行番号, 2)
If Dir(path) <> "" And path <> "" And checkFlg = "〇" Then
If OptionButton1.Value = True Then 'パスワード保護の場合
Set wb = Workbooks.Open(path)
wb.SaveAs filename:=path, Password:=Pass 'パスワード付与して同名保存
wb.Close savechanges:=True
ElseIf OptionButton2.Value = True Then 'パスワード解除の場合
Set wb = Workbooks.Open(path, Password:=Pass)
wb.SaveAs filename:=path, Password:="" 'パスワード無しで同名保存
wb.Close savechanges:=True
End If
対象表.Cells(行番号, 3) = "○"
i = i + 1 'カウント
Else
対象表.Cells(行番号, 3) = "×"
End If
Next
Application.DisplayAlerts = True '画面アラートを有効
Application.ScreenUpdating = True '画面更新停止を解除
MsgBox i & "件のブックを処理しました。"
End Sub
Sub setLine(rg As Range)
rg.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
