|
カテゴリ:カテゴリ未分類
↓がコードの続きです。コピペしてください。
(先に『Excel VBA ファイル名順にコピー1』のコードからコピペしてください) '除外クリック Private Sub btnListItemDel_Click() Dim itmLvw As ListItem Dim i As Long btnListItemDel.Enabled = False 'リストの後ろの方から、選択されているアイテムを削除 For i = lvwList.ListItems.Count To 1 Step -1 Set itmLvw = lvwList.ListItems(i) If itmLvw.Selected Then lvwList.ListItems.Remove itmLvw.Index End If Next i End Sub 'ストップクリック Private Sub btnCopyStop_Click() GLB_BLN_STOP = True End Sub 'コピー実行クリック Private Sub btnCopyRun_Click() InitAllCtl (False) If tbxPathEX = "" Then MsgBox ("出力先フォルダを入力してください。") InitAllCtl (True) Exit Sub End If If lvwList.ListItems.Count > 0 Then 'コピー実行 If fncCopyRun = True Then MsgBox ("コピーが終わりました。") Else MsgBox ("コピーを失敗しました") Else MsgBox ("処理データがありません") End If InitAllCtl (True) End Sub 'コピー実行 Private Function fncCopyRun() As Boolean Const CST_YEN = "\" Dim strFilename As String Dim strFilePath As String Dim strFilePathEX As String Dim i As Long Dim intMaxListCnt As Integer Dim intUwagaki As Integer fncCopyRun = True On Error GoTo errFnc GLB_BLN_STOP = False btnCopyRun.Visible = False btnCopyStop.Visible = True lblCopyRun.Visible = True 'チェック If (Len(tbxPath.Text) = 0) Or (tbxPath.Text = "False") Then Exit Function strFilePath = tbxPath.Text If (Len(tbxPathEX.Text) = 0) Or (tbxPathEX.Text = "False") Then Exit Function strFilePathEX = tbxPathEX.Text 'リスト数 intMaxListCnt = lvwList.ListItems.Count intUwagaki = 0 ' For i = 1 To intMaxListCnt lvwList.ListItems(i).Selected = False Next i For i = 1 To intMaxListCnt 'lvwList.ListItems(i).Selected = True DoEvents lblCopyRun.Caption = "コピー中 " & Str(i) & " / " & Str(intMaxListCnt) If GLB_BLN_STOP Then If MsgBox("中止しますか?", vbYesNo) = vbYes Then Exit For Else GLB_BLN_STOP = False End If End If strFilename = lvwList.ListItems(i).Text '上書き確認 If Dir(strFilePathEX & CST_YEN & strFilename) <> "" Then If intUwagaki = 0 Then If MsgBox("「 " & strFilename & " 」は、すでに存在します。上書きしますか?", vbYesNo) = vbYes Then intUwagaki = 1 'コピー実行 FileCopy strFilePath & CST_YEN & strFilename, strFilePathEX & CST_YEN & strFilename Else intUwagaki = -1 End If If MsgBox("今後すべてに同じ処理をしますか?", vbYesNo) = vbNo Then intUwagaki = 0 End If ElseIf intUwagaki = 1 Then 'コピー実行 FileCopy strFilePath & CST_YEN & strFilename, strFilePathEX & CST_YEN & strFilename End If Else 'コピー実行 FileCopy strFilePath & CST_YEN & strFilename, strFilePathEX & CST_YEN & strFilename End If Next i lblCopyRun.Caption = "実行中" GLB_BLN_STOP = False btnCopyRun.Visible = True btnCopyStop.Visible = False lblCopyRun.Visible = False Exit Function errFnc: lblCopyRun.Caption = "実行中" GLB_BLN_STOP = False btnCopyRun.Visible = True btnCopyStop.Visible = False lblCopyRun.Visible = False fncCopyRun = False End Function 'リストビューフォーカスIN Private Sub lvwList_Click() If lvwList.ListItems.Count > 0 Then btnListItemDel.Enabled = True End If ' If lvwList.SelectedItem.Index > 0 Then ' btnListItemDel.Enabled = True ' End If End Sub 'フィルタ用のテキストボックス変更イベント 'Private Sub tbxJyouken_Change() Private Sub tbxJyouken_Exit(ByVal Cancel As MSForms.ReturnBoolean) If ThisWorkbook.Worksheets(CST_STR_SETTING).Range(CST_STR_SET_CELL2).Value <> tbxJyouken.Text Then If tbxJyouken.Enabled = True Then subPathChange ThisWorkbook.Worksheets(CST_STR_SETTING).Range(CST_STR_SET_CELL2).Value = tbxJyouken.Text End If End Sub 'コピー元のテキストボックス変更イベント Private Sub tbxPath_Exit(ByVal Cancel As MSForms.ReturnBoolean) If ThisWorkbook.Worksheets(CST_STR_SETTING).Range(CST_STR_SET_CELL1).Value <> tbxPath.Text Then If tbxPath.Enabled = True Then subPathChange ThisWorkbook.Worksheets(CST_STR_SETTING).Range(CST_STR_SET_CELL1).Value = tbxPath.Text End If End Sub 'コピー元ファイル読み込み Private Sub subPathChange() Const CST_YEN = "\" Dim strFilename As String Dim strFilePath As String Dim intCntEve As Long InitAllCtl (False) lvwList.ListItems.Clear 'チェック If (Len(tbxPath.Text) = 0) Or (tbxPath.Text = "False") Then InitAllCtl (True) Exit Sub End If strFilePath = tbxPath.Text ' 指定フォルダ内のファイル名を参照する(1件目) strFilename = Dir(strFilePath & CST_YEN & "*.*", vbNormal) If strFilename = "" Then MsgBox "このフォルダにはファイルは存在しません。" InitAllCtl (True) Exit Sub End If GLB_BLN_STOP = False btnCopyRun.Visible = False btnCopyStop.Visible = True lblCopyRun.Visible = True intCntEve = 0 ' 指定フォルダの全ファイルについて繰り返す Do While strFilename <> "" intCntEve = intCntEve + 1 lblCopyRun.Caption = "読み込み中 " & Str(intCntEve) & " 個" If intCntEve Mod 10 = 0 Then DoEvents If GLB_BLN_STOP Then If MsgBox("中止しますか?", vbYesNo) = vbYes Then Exit Do Else GLB_BLN_STOP = False End If End If If strFilename Like "*" & tbxJyouken.Text & "*" Then 'リストに追加 With lvwList.ListItems.Add .Text = strFilename .SubItems(1) = FileDateTime(strFilePath & CST_YEN & strFilename) End With End If ' 次のファイル名を参照 strFilename = Dir Loop InitAllCtl (True) lblCopyRun.Caption = "実行中" GLB_BLN_STOP = False btnCopyRun.Visible = True btnCopyStop.Visible = False lblCopyRun.Visible = False End Sub '閉じるクリック Private Sub btnClose_Click() UserForm_Terminate End Sub 'フォーム右上の×クリック Private Sub UserForm_Terminate() Dim intBkCnt As Integer '上書き保存 ThisWorkbook.Worksheets(CST_STR_SETTING).Range(CST_STR_SET_CELL1).Value = tbxPath.Text ThisWorkbook.Worksheets(CST_STR_SETTING).Range(CST_STR_SET_CELL2).Value = tbxJyouken.Text ThisWorkbook.Worksheets(CST_STR_SETTING).Range(CST_STR_SET_CELL3).Value = tbxPathEX.Text ThisWorkbook.Save If CST_BOO_MODE Then Unload fmCopy Exit Sub End If 'ブックのチェック intBkCnt = 0 For Each wkbCheck In Workbooks intBkCnt = intBkCnt + 1 Next wkbCheck If intBkCnt = 1 Then '他のExcelブックがなければExcel閉じる Application.DisplayAlerts = False Application.Quit Else ThisWorkbook.Close SaveChanges:=False End If End Sub '列見出しクリックでソート Private Sub lvwList_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader) lvwList.SortKey = ColumnHeader.Index - 1 If lvwList.SortOrder = lvwAscending Then lvwList.SortOrder = lvwDescending Else lvwList.SortOrder = lvwAscending End If lvwList.Sorted = True End Sub ' ''禁止文字変換 'Private Function fncStrChange(strSheetNM As String) As String ' ' Dim strWk As String ' ' '半角にして禁止文字を変換 ' strWk = StrConv(strSheetNM, vbNarrow) ' strWk = Replace(strWk, ":", "・") ' strWk = Replace(strWk, "\", "_") ' strWk = Replace(strWk, "?", "_") ' strWk = Replace(strWk, "[", "(") ' strWk = Replace(strWk, "]", ")") ' strWk = Replace(strWk, "/", "_") ' strWk = Replace(strWk, "*", "×") ' ' '戻り値セット ' fncStrChange = strWk 'End Function お気に入りの記事を「いいね!」で応援しよう
vHbyi8 <a href="http://zgqrzwvxtesj.com/">zgqrzwvxtesj</a>, [url=http://wjettdzzlkoi.com/]wjettdzzlkoi[/url], [link=http://fijrstrqjmcm.com/]fijrstrqjmcm[/link], http://rkzrkopvbbps.com/
(2014.11.14 16:36:34)
vx7Mqg http://www.QS3PE5ZGdxC9IoVKTAPT2DBYpPkMKqfz.com
(2015.01.06 10:55:43)
|