回答編集履歴

処理修正

2015/06/10 05:09

投稿

bbs

スコア16

test CHANGED Viewed

@@ -136,203 +136,275 @@
-    Dim OutPutFile As Boolean
     ' GetFolderでパスを取得しAdoに格納
+    Dim file As Object
     For Each file In Fso.GetFolder(strPathName).Files
-        ' 除外ファイルチェック
+        ' 登録ファイルチェック
-        OutPutFile = True
+        If IsOutPutFile(file) Then
+            ' ファイル名は以下の形式
-        For i = 0 To ListBox1.ListCount - 1
+            ' (番号)_(○○○)_(×××).xls
+            ado.AddNew
-            If Dir(file) Like ("*" & ListBox1.List(i) & "*") Then
+            ado.Fields(0) = padZero(CInt(Split(Dir(file), "_")(0)), 4)  ' 番号(0埋)
-                OutPutFile = Fasle ' 除外ファイル名が含まれていた場合は登録フラグOFF
+            ado.Fields(1) = file                                        ' フルPATH
+            ado.Update
-                Exit For
+        End If
+    Next
+    ado.Sort = "FILENUMBER ASC" ' FILENUMBERでソート
+    ado.MoveFirst
+    Do Until ado.EOF
+        xlApp.Workbooks.Open FileName:=CStr(ado.Fields(1)), UpdateLinks:=0  ' Excelを開く
+        DoEvents
+        If IsCancel Then
+            If IsOpenBook(CStr(ado.Fields(1))) And Not xlApp Is Nothing Then
+                xlApp.DisplayAlerts = False
+                xlApp.Workbooks.Close                               ' Excelを閉じる
+                xlApp.DisplayAlerts = True
             End If
-        Next
-        If OutPutFile Then
+            If Not Fso Is Nothing Then Set Fso = Nothing
-            ado.AddNew
-            ' ファイル名は以下の形式
+            If Not ado Is Nothing Then Set ado = Nothing
-            ' (番号)_(○○○)_(×××).xls
+            If Not xlApp Is Nothing Then Set xlApp = Nothing
-            ado.Fields(0) = padZero(CInt(Split(Dir(file), "_")(0)), 4)  ' 番号(0埋)
+            MsgBox "処理を中断しました。", vbInformation, "処理中断"
-            ado.Fields(1) = file                                        ' フルPATH
-            ado.Update
+            Exit Sub
         End If
+        xlApp.Visible = False                                       ' 非表示
+        xlApp.ActiveWorkbook.PrintOut                               ' 印刷
+        xlApp.DisplayAlerts = False
+        xlApp.Workbooks.Close                                       ' Excelを閉じる
+        xlApp.DisplayAlerts = True
+        Sleep 1                                                     ' CPU使用率考慮
+        ado.MoveNext
+    Loop
+    ado.Close
+    Set xlApp = Nothing
+    Set ado = Nothing
+    Set Fso = Nothing
+    MsgBox "印刷ジョブに登録しました。", vbInformation, "処理終了"
+    Exit Sub
+ErrorHandler:
+    If Not Fso Is Nothing Then Set Fso = Nothing
+    If Not ado Is Nothing Then Set ado = Nothing
+    If Not xlApp Is Nothing Then Set xlApp = Nothing
+    MsgBox Err.Number & ":" & Err.Description, vbCritical & vbOKOnly, "例外発生"
+End Sub
+'''
+''' キャンセルボタン
+'''
+Private Sub CommandButton4_Click()
+    IsCancel = True
+End Sub
+'''
+''' 閉じるボタン
+'''
+Private Sub CommandButton2_Click()
+    Unload UserForm1
+End Sub
+'''
+''' 追加ボタン
+'''
+Private Sub CommandButton3_Click()
+    Dim i As Integer
+    For i = 0 To ListBox1.ListCount - 1
+      If ListBox1.List(i) = TextBox1.Text Then
+        MsgBox "既に登録済みです。", vbCritical & vbOKOnly, "重複エラー"
+        Exit Sub
+      End If
     Next
-    ado.Sort = "FILENUMBER ASC" ' FILENUMBERでソート
-    ado.MoveFirst
-    Do Until ado.EOF
-        xlApp.Workbooks.Open FileName:=CStr(ado.Fields(1)), UpdateLinks:=0  ' Excelを開く
-        DoEvents
-        If IsCancel Then
-            If IsOpenBook(CStr(ado.Fields(1))) And Not xlApp Is Nothing Then
-                xlApp.DisplayAlerts = False
-                xlApp.Workbooks.Close                               ' Excelを閉じる
-                xlApp.DisplayAlerts = True
+    ListBox1.AddItem TextBox1.Text
+    TextBox1.Text = ""
+    SetListData
-            End If
+End Sub
+'''
+''' 削除ボタン
+'''
+Private Sub CommandButton5_Click()
+    Dim i As Integer
-            If Not ado Is Nothing Then Set ado = Nothing
+    For i = 0 To ListBox1.ListCount - 1
-            If Not xlApp Is Nothing Then Set xlApp = Nothing
+        If ListBox1.Selected(i) Then
-            MsgBox "処理を中断しました。", vbInformation, "処理中断"
+            ListBox1.RemoveItem (i)
-            Exit Sub
+            Exit For
         End If
-        xlApp.Visible = False                                       ' 非表示
-        xlApp.ActiveWorkbook.PrintOut                               ' 印刷
-        xlApp.DisplayAlerts = False
-        xlApp.Workbooks.Close                                       ' Excelを閉じる
-        xlApp.DisplayAlerts = True
-        Sleep 1                                                     ' CPU使用率考慮
-        ado.MoveNext
-    Loop
-    ado.Close
-    Set xlApp = Nothing
-    Set ado = Nothing
-    Set Fso = Nothing
-    MsgBox "印刷ジョブに登録しました。", vbInformation, "処理終了"
-    Exit Sub
-ErrorHandler:
-    If Not ado Is Nothing Then Set ado = Nothing
-    If Not xlApp Is Nothing Then Set xlApp = Nothing
-    MsgBox Err.Number & ":" & Err.Description, vbCritical & vbOKOnly, "例外発生"
-End Sub
-'''
-''' キャンセルボタン
-'''
-Private Sub CommandButton4_Click()
-    IsCancel = True
-End Sub
-'''
-''' 閉じるボタン
-'''
-Private Sub CommandButton2_Click()
-    Unload UserForm1
-End Sub
-'''
-''' 追加ボタン
-'''
-Private Sub CommandButton3_Click()
-    Dim i As Integer
+    Next
+    SetListData
+End Sub
+'''
+''' ゼロ埋め処理
+'''
+Private Function padZero(n As Integer, keta As Integer)
+    padZero = Right(n + 10 ^ keta, keta)
+End Function
+'''
+''' Bookが開かれているか判別
+'''
+Private Function IsOpenBook(strFullPath As String) As Boolean
+    On Error Resume Next
+    Open strFullPath For Append As #1
+    Close #1
+    IsOpenBook = Err.Number > 0
+End Function
+'''
+''' 除外ファイル名登録
+'''
+Private Sub SetListData()
+    Worksheets(2).Columns("A").Delete
     For i = 0 To ListBox1.ListCount - 1
-      If ListBox1.List(i) = TextBox1.Text Then
+        Worksheets(2).Cells(i + 1, 1).Value = ListBox1.List(i)
-        MsgBox "既に登録済みです。", vbCritical & vbOKOnly, "重複エラー"
-        Exit Sub
-      End If
     Next
-    ListBox1.AddItem TextBox1.Text
+    ThisWorkbook.Save
-    TextBox1.Text = ""
-    SetListData
-End Sub
+End Sub
-'''
+'''
-''' 削除ボタン
+''' 登録ファイルチェック
-'''
+'''
-Private Sub CommandButton5_Click()
+Private Function IsOutPutFile(file As Object) As Boolean
-    Dim i As Integer
+    IsOutPutFile = True
     For i = 0 To ListBox1.ListCount - 1
-        If ListBox1.Selected(i) Then
+        If Dir(file) Like ("*" & ListBox1.List(i) & "*") Then
-            ListBox1.RemoveItem (i)
+            IsOutPutFile = False ' 除外ファイル名が含まれていた場合は登録フラグOFF
             Exit For
@@ -340,68 +412,8 @@
     Next
-    SetListData
-End Sub
-'''
-''' ゼロ埋め処理
-'''
-Private Function padZero(n As Integer, keta As Integer)
-    padZero = Right(n + 10 ^ keta, keta)
 End Function
-'''
-''' Bookが開かれているか判別
-'''
-Private Function IsOpenBook(strFullPath As String) As Boolean
-    On Error Resume Next
-    Open strFullPath For Append As #1
-    Close #1
-    IsOpenBook = Err.Number > 0
-End Function
-'''
-''' 除外文字列登録
-'''
-Private Sub SetListData()
-    Worksheets(2).Columns("A").Delete
-    For i = 0 To ListBox1.ListCount - 1
-        Worksheets(2).Cells(i + 1, 1).Value = ListBox1.List(i)
-    Next
-    ThisWorkbook.Save
-End Sub
 ```