Dim fs
Dim fn
Dim outDir
Dim tgtDir
Dim ngFile
Dim log

'説明：デスクトップを整理するプログラム
'内容：デスクトップのファイル（フォルダ・ショートカット以外）を処理年月のフォルダに全部ぶっこむ
'エラー時：保管先に同名のファイルが既に存在する場合はエラー停止する（と思うｗ）

Dim WS
Set WS = CreateObject("WScript.Shell")

outDir = WS.SpecialFolders("desktop") & "\" '整理対象フォルダ
tgtDir = outDir '出力先

msgbox outDir
'----------------------------
'メイン処理
'----------------------------
'対象フォルダの設定
setTarget

'対象フォルダを年月毎にフォルダ移動
createDir

'ファイル移動
moveFile

'処理結果
log = log & "ファイル整理完了"
WScript.Echo log

'----------------------------
'対象ディレクトリのファイルを出力先フォルダに一括で移動
Sub moveFile
	On Error Resume Next
	Dim objFileSys
	Dim objFolder
	Dim objFile
	Dim fList

	'ファイルシステムを扱うオブジェクト
	Set objFileSys = CreateObject("Scripting.FileSystemObject")
	Set objFolder = objFileSys.GetFolder(outDir)
	Set fs = WScript.CreateObject("Scripting.FileSystemObject")

	For Each objFile In objFolder.Files
		'取得したファイル名を表示
		fList = fList & objFile.Name & vbCrlf

		' 対象ファイルにこのスクリプトが含まれている場合除外
		If objFile.Name <> WScript.ScriptName Then
			'ファイル移動
			log = log & "move " & outDir & objFile.Name & "→" & tgtDir & objFile.Name & vbCrlf
			fs.MoveFile outDIr & objFile.Name , tgtDir & objFile.Name
		End If
	Next
End Sub

'----------------------------
Sub setTarget
	If strFormattedDate = "" Then
		'yyyy/mm/dd hh:mm:ss 形式で現在日付を取得
		strFormattedDate = Now()
	End If

	'yyyy/mm.dd hh:mm:ss から yyyy/mmのみ抽出
	strFormattedDate = Left(strFormattedDate, 7)

	'/を削除してyyyymmに編集
	strFormattedDate = Replace(strFormattedDate, "/", "")

	'yyyymmdd 形式の文字列をダイアログに表示
	tgtDir = tgtDir & strFormattedDate & "\"
End Sub

'----------------------------
Sub createDir
	On Error Resume Next
	Dim str_path
	Set objFs = CreateObject("Scripting.FileSystemObject")

	'フォルダを作成する
	str_path = objFS.CreateFolder(tgtDir)
End Sub