| |
つづき
以下を標準モジュールに記述して下さい
Option Explicit
' アクティブなウィンドウのハンドルを取得する関数の宣言
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Public Function GetFolderPath() As String
Dim strTitle As String
Dim objFolder As Object
Dim hWnd As Long
Dim strTmpPath As String
Const BIF_RETURNONLYFSDIRS = &H1
Const ssfDESKTOP = &H0
Const CSIDL_WINDOWS = &H24
'アクティブなWindowのハンドルを取得
hWnd = GetForegroundWindow
' 表示タイトルを指定
strTitle = "フォルダを選択して下さい"
' フォルダ選択ダイアログを表示
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(hWnd, strTitle, _
BIF_RETURNONLYFSDIRS, CSIDL_WINDOWS)
' フォルダを選択したときは
If Not (objFolder Is Nothing) Then
' 選択フォルダを表示
With objFolder
' 親フォルダが存在するときは
If Not (.ParentFolder Is Nothing) Then
' 選択フォルダのフルパスを表示
strTmpPath = .Items.Item.Path
' 親フォルダのときは
Else
' フォルダ名を表示
strTmpPath = .Title
End If
End With
' Folderオブジェクトを破棄
Set objFolder = Nothing
End If
If strTmpPath <> "" And Right(strTmpPath, 1) <> "\" Then
strTmpPath = strTmpPath & "\"
End If
GetFolderPath = strTmpPath
End Function
Public Function FilesList(ByVal strFolderPath As String, _
ByVal strSearchFile As String, _
Optional lngSubDir As Long = -1) As Variant
Dim i As Long
Dim j As Long
Dim strFolders() As String
Dim strFILENAME As String
Dim strFileNames() As String
'パスの最後に\を付加
If Right(strFolderPath, 1) <> "\" Then
strFolderPath = strFolderPath & "\"
End If
'フォルダのListを作成
ReDim strFolders(0)
'探し始めるフォルダを代入
strFolders(0) = strFolderPath
'フォルダをリストアップ
If lngSubDir <> 0 Then
GetFolders strFolderPath, strFolders(), _
UBound(strFolders) + 1, lngSubDir
End If
j = 0
ReDim strFileNames(1, j)
For i = 0 To UBound(strFolders)
'ディレクトリ内の全ての標準ファイルを列挙
strFILENAME = Dir(strFolders(i) & strSearchFile)
Do Until strFILENAME = ""
ReDim Preserve strFileNames(1, j)
strFileNames(0, j) = strFolders(i)
strFileNames(1, j) = strFILENAME
j = j + 1
strFILENAME = Dir
Loop
Next i
FilesList = strFileNames()
End Function
Public Function FoldersList(ByVal strFolderPath As String, _
Optional lngSubDir As Long = -1) As Variant
' strFolderPath: 探し始めるフォルダ名
' lngSubDir: 探す階層数
Dim strFolders() As String
'パスの最後に\を付加
If Right(strFolderPath, 1) <> "\" Then
strFolderPath = strFolderPath & "\"
End If
ReDim strFolders(0)
'探し始めるフォルダを代入
strFolders(0) = strFolderPath
'フォルダをリストアップ
If lngSubDir <> 0 Then
GetFolders strFolderPath, strFolders(), _
UBound(strFolders) + 1, lngSubDir
End If
FoldersList = strFolders()
End Function
Private Sub GetFolders(ByVal strFilesPath As String, _
strDirList() As String, _
lngNextData As Long, _
lngSubDir As Long)
Dim i As Long
Dim j As Long
Dim lngNow As Long
Dim strFILENAME As String
'結果用配列の書き込み位置を取得
i = lngNextData
'サブディレクトリの結果リストと、一時的なリストを作成
strFILENAME = Dir(strFilesPath, vbDirectory)
Do Until strFILENAME = ""
'現在のディレクトリと親ディレクトリを無視
If strFILENAME <> "." And strFILENAME <> ".." Then
'ディレクトリ以外を無視
If GetAttr(strFilesPath & strFILENAME) _
And vbDirectory Then
ReDim Preserve strDirList(i)
'結果リストに追加
strDirList(i) = strFilesPath & strFILENAME & "\"
i = i + 1
End If
End If
strFILENAME = Dir
Loop
j = lngNextData
lngNextData = i
'ディレクトリの階層を一つ下げる
lngSubDir = lngSubDir - 1
'指定階層数になるまで再帰、lngSubDir < 0 の時は最終階層まで再帰
If lngSubDir > 0 Or lngSubDir < 0 Then
'各ディレクトリを再帰的に処理
For i = j To lngNextData - 1
lngNow = lngSubDir
GetFolders strDirList(i), strDirList(), _
lngNextData, lngNow
Next i
End If
End Sub
Public Sub DeleteRows(rngTop As Range)
Dim lngDelEnd As Long
Dim lngDelTop As Long
With rngTop
lngDelEnd = .Offset(65536 - .Row, 6).End(xlUp).Row - .Row
If lngDelEnd < 1 Then
Exit Sub
End If
End With
lngDelTop = 1
With rngTop
Range(.Offset(lngDelTop), .Offset(lngDelEnd)).EntireRow.Delete
End With
End Sub
Public Sub DataSheetSort(rngTop As Range)
With rngTop.CurrentRegion
.Sort Key1:=.Item(1, 7), Order1:=xlAscending, _
Key2:=.Item(1, 6), Order2:=xlAscending, _
Key3:=.Item(1, 1), Order2:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
End With
End Sub
Public Sub BookOpen(ByVal strTarget As String)
If Dir(strTarget) <> "" Then
Workbooks.Open (strTarget)
End If
End Sub
Public Sub IndeFormShow()
ActiveCell.Activate
UserForm1.Show
End Sub
以下をThisWorkBookのコードモジュールに記述して下さい
Private Sub Workbook_Open()
IndeFormShow
End Sub
|
|
Hirofumi
- 05/4/16(土) 12:20 -
