涵言星美吧 关注:2贴子:778
  • 3回复贴,共1

毫无文学细胞了

只看楼主收藏回复

偶然点进来了 都不知道说什么


来自iPhone客户端1楼2014-07-01 00:16回复
    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


    2楼2019-01-28 16:23
    回复
      明日修正をお願いします。
      ついでにデフォルトで保護に○がつくようにしておいてください。


      3楼2019-01-28 16:24
      回复
        Function getFiles()
        Dim i As Integer, FSO As Object, f As Object, path As String
        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, ".xlsx") <> 0 Then
        i = i + 1
        Cells(i + Cells(1, 1), 2) = f.path
        Cells(i + Cells(1, 1), 3) = "〇"
        End If
        Next f
        Set FSO = Nothing
        Names("対象表").RefersTo = Range(Cells(3, 2), Cells(i + Cells(1, 1), 4))
        Cells(1, 1) = Cells(1, 1) + i
        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


        5楼2019-01-30 17:36
        回复