'Excelシート情報出力



'D&Dされたファイルを開く



Option Explicit

'On Error Resume Next



'ドラック＆ドロップされたファイル名を表示する



'引数を取得

Dim args

Dim arg

Dim strArg

Dim argNum



Set args = WScript.Arguments



'引数の数を確認

argNum = args.Count



'引数が１つもなければ

If argNum = 0 Then

	

	'スクリプトを終了

	Wscript.Echo "このツールの上に対象のファイルをドラック＆ドロップして下さい。"

	WScript.Quit

	

End If



'変数定義

Dim objFSO      'FileSystemObject

Dim objRE       '文字検索用



Dim strToolFolder

Dim strDataFullPath

Dim strDataFolder

Dim strDataFile

Dim strExtName





'csvファイル操作のためのファイルシステムオブジェクトの作成

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")



'各ファイルのパスを取得

strToolFolder = objFSO.getParentFolderName(WScript.ScriptFullName)



'引数を確認－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

'最初の引数の値を変数に格納

strDataFullPath = args(0)

strDataFolder = objFSO.getParentFolderName(args(0))

strDataFile = objFSO.getFileName(args(0))

strExtName = objFSO.GetExtensionName(args(0))



'拡張子が「csv」でない場合

If (strExtName <> "xlsx") and (strExtName <> "XLSX") Then

	'スクリプトを終了

	MsgBox "対象外のファイルが含まれています。" & vbCrLf & vbCrLf & _

			"正しいファイルをドラック＆ドロップして下さい。", 48, "ツール"

	WScript.Quit

End If



'MsgBox "フォルダパス：" & strDataFolder & vbCrLf & vbCrLf & _

'		"ファイル名：" & strDataFile & vbCrLf & vbCrLf





'Excel操作

Dim oXlsApp



' Excel起動

Set oXlsApp = CreateObject("Excel.Application")

If oXlsApp Is Nothing Then

	' Excel起動失敗

	MsgBox "Excel起動失敗"

Else

	' Excel起動成功

	' --Excel表示（falseにすると非表示にできる）

	oXlsApp.Application.Visible = true

	' --3秒待つ

	WScript.Sleep(3000)

	

	'対象ファイルを開く

	Dim objInputFile

	' --ブックを開く

	Set objInputFile = oXlsApp.Application.Workbooks.Open(strDataFullPath)

	

	

	'出力用ファイルを開く

	Dim objOutputFile

	' --ブックの追加

	Set objOutputFile = oXlsApp.Application.Workbooks.Add()





	'データを出力用ファイルに書き出す

	'シートを追加する

	Dim i

	For i = 2 To objInputFile.Sheets.Count

		objOutputFile.Sheets.Add()

	Next

	

	

	For i = 1 To objInputFile.Sheets.Count

		objOutputFile.Sheets(i).Name = objInputFile.Sheets(i).Name

		'objOutputFile.Sheets(i).Cells(i, 1) = objInputFile.Sheets(i).Name

		Get_SheetFormatCondition objInputFile.Sheets(i),objOutputFile.Sheets(i)

	Next

	

	

	' --3秒待つ

	WScript.Sleep(10000)

	' --Excel終了

	

	

	'出力ファイルを保存

	'現在日時を取得

	Dim strNow

	Dim strCDate

	Dim strCTime

	

	strNow = Replace(Left(Now(),10), "/", "") & Replace(Replace(Right(Now(),8)," ","0"), ":", "")

	'Wscript.Echo strNow

	strCDate = Left(strNow,8)

	strCTime = Right(strNow,6)

	

	objOutputFile.SaveAs strDataFolder & "シート情報" & strCDate & "_" & strDataFile

	oXlsApp.Quit





	' --Excelオブジェクトクリア

	Set oXlsApp = Nothing

	Set objInputFile = Nothing



End If







'条件付き書式取得

Function Get_SheetFormatCondition(ACsheet,SH1)

	

	'Dim ACsheet

	'Dim SH1

	Dim i

	Dim m_FCs 'As FormatCondition

	'ACsheet = ActiveSheet.Name

	'Set SH1 = Worksheets.Add

	Dim tmp(5) 'As String

	tmp(0) = "タイプ"

	tmp(1) = "条件"

	tmp(2) = "範囲"

	tmp(3) = "背景色"

	tmp(4) = "フォントスタイル指定"

	tmp(5) = "フォントの色インデックス"

	SH1.Range("A1:F1") = tmp

	

	'////ここから条件付き書式の・・・/////

	i = 1

	For Each m_FCs In ACsheet.Cells.FormatConditions

		i = i   1

		'm_FCsにそれぞれの条件情報が順番に代入される

		

		SH1.Cells(i, 1) = "'" & m_FCs.Type

		SH1.Cells(i, 2) = "'" & m_FCs.Formula1

		SH1.Cells(i, 3) = "'" & m_FCs.AppliesTo.Address

		SH1.Cells(i, 4) = "'" & m_FCs.Interior.Color

		SH1.Cells(i, 5) = "'" & m_FCs.Font.FontStyle

		SH1.Cells(i, 6) = "'" & m_FCs.Font.ColorIndex

		

	Next



End Function