ソース掲示板




すべてから検索

キーワード   条件 表示 現行ログ 過去ログ トピックス 名前 本文

  メンテナンス 前画面に戻る

対象スレッド 件名: Excelに書かれたデータを元に画像を加工する ( バージョンアツプ版 )
名前: lightbox
処理選択
パスワード

件名 Excelに書かれたデータを元に画像を加工する ( バージョンアツプ版 )
名前 lightbox
コメント
ログ出力やら、エラー処理やら、Excel のシートを二つ使った
パラメータ取得の実際に処理したコードですので、仕様さえ一致させれば動作します

@DIV
' スクリプトが存在するディレクトリ
' FileSystemObject を使わないで取得
strCurPath = WScript.ScriptFullName
aPath = Split( strCurPath, "\" )
strCurPath = ""
For i = 0 to Ubound(aPath)-1
	strCurPath = strCurPath & aPath( i )
	if i <> Ubound(aPath)-1 then
		strCurPath = strCurPath & "\"
	end if
Next

' 1) このスクリプトを加工前の画像と同じディレクトリに置きます。
' 2) パラメータを持つ Excel のフルパス( フルパスで書きます )
' strParamBook = "C:\Documents and Settings\lightbox\My Documents\_0904\パラメータ.xls"
' テスト用の Excel をカレントディレクトリに置いています
strParamBook = strCurPath & "\パラメータ.xls"
' 3) 分割された画像を作成するディレクトリ( このスクリプトからの相対パス )
strResultPath = "..\partImage\"

' 実サイズの標準値( ミリ ) : B5 は 182mm×257mm
nRealWidth = 251
nRealHeight = 181
' ********************************************************

' リサイズ用コードサンプル
' Call img.Convert("image.tif", "-resize", "800", "work.bmp")
'

' ImageMagick を使う為のオブジェクト
Set img = CreateObject("ImageMagickObject.MagickImage.1")

Dim ExcelApp ' Excel オブジェクト
Dim Book ' 一つのブックを処理するインスタンス

Set Book = New ExcelAction
Call Book(ExcelApp, strParamBook)
if Book.ErrFlg then
	' Excel を開く事ができなかった
	Book.Quit
	Wscript.Quit
end if

' デフォルトが非表示なのでテスト中は表示
' Book.Visible( True )

' 1つ目のシートを使用する
Book.SelectSheetNo( 1 )
if Book.ErrFlg then
	Book.Quit
	Wscript.Quit
end if

' **********************************************************
' L カラム( 12番目 ) を順に検索して、空白でなかったら( 
' 級とページを取得する
' G カラム( 7番目 ) が空白になったら終了
' **********************************************************

nY = 2
strKyu = ""
Do
	' 表題がなくなったらデータは終わり
	strCell = ""
	nEndLimit = 0
	Do While strCell = ""
		strCell = Book.GetCellActive(7,nY)
		if strCell = "" then
			nEndLimit = nEndLimit + 1
			if nEndLimit > 10 then
				Book.Quit
				Wscript.Echo "処理が終了しました"
				Wscript.Quit
			end if
			nY = nY + 1
		end if
	Loop

	Book.Log("表題:"&strCell)

	' ファイル名
	strFile = Book.GetCellActive(12,nY)

	' ファイル名発見
	if strFile <> "" then
		strKyu = Book.GetCellActive(13,nY)
		strPage = Book.GetCellActive(14,nY)

		' 2つ目のシートを使用する
		Book.SelectSheetNo( 2 )
		if Book.ErrFlg then
			Book.Quit
			Wscript.Quit
		end if

		nRow = 3	' 切り取りシートの開始位置
		Do
			' 級
			strCell1 = Book.GetCellActive(1,nRow)
			if strCell1 = "" then
				Exit Do
			end if
			' ページ
			strCell2 = Book.GetCellActive(2,nRow)
			if strCell1 = strKyu and strCell2 = strPage then
				str = Book.GetCellActive(7,nRow)
				' 右から
				n1 = CLng(str)
				' 左から
				str = Book.GetCellActive(8,nRow)
				n2 = CLng(str)
				' 最後の引数は、出力ディレクトリ( カレントに出力するには、"" を指定 )
				Book.LogPath = strResultPath
				Call CropImage( strFile, n1, n2, Book.LogPath )
				Exit Do
			end if

			nRow = nRow + 1
		Loop

		' 1つ目のシートに戻す
		Book.SelectSheetNo( 1 )
	end if

	nY = nY + 1
Loop

Function CropImage( strFileName, nRight, nLeft, dirString )
' 右からの切り取り位置
' 左からの切り取り位置

	Dim pic,aData

	aData = Split( strFileName, "," )

	' BMP化( 参考データ : 3872 x 2688 )
	Call img.Convert(strFileName, "work.bmp")

	Set pic = LoadPicture("work.bmp")

	nWidth = CLng(CLng(pic.Width) * 567 / 15000)
	nHeight = CLng(CLng(pic.Height) * 567 / 15000)

	Set pic = Nothing
	pic = Empty

	' 画像上の右からの切り取り位置
	nCrop1 = CLng(nWidth*nRight/nRealWidth)
	sParam1 = nCrop1 & "x" & nHeight & "+" & ( nWidth - nCrop1 ) & "+0"

	Call img.Convert( _
		"work.bmp", _
		"-crop", _
		sParam1, _
		"+repage", _
		dirString&aData(0)&"-h.png" )

	Book.Log(aData(0)&"-h.png を作成しました")

	' 画像上の左からの切り取り位置
	nCrop2 = CLng(nWidth*nLeft/nRealWidth)
	sParam2 = nCrop2 & "x" & nHeight & "+0+0"

	Call img.Convert( _
		"work.bmp", _
		"-crop", _
		sParam2, _
		"+repage", _
		dirString&aData(0)&"-f.png" )


	Book.Log(aData(0)&"-f.png を作成しました")

	' 画像上の中央の切り取り位置
	sParam3 = nWidth-nCrop2-nCrop1 & "x" & nHeight & "+" & nCrop2 & "+0"

	Call img.Convert( _
		"work.bmp", _
		"-crop", _
		sParam3, _
		"+repage", _
		dirString&aData(0)&"-b.png" )

	Book.Log(aData(0)&"-b.png を作成しました")

End Function

' ************************************************
' クラス定義
' ************************************************
Class ExcelAction

	Public ExcelApp		' 共有
	Public ExcelBook	' このインスタンス用
	Public Fs		' ログ出力用
	Public ErrFlg		' エラーフラグ
	Public ErrDescription	' エラーメッセージ
	Public LogPath		' ログの出力ディレクトリ( 最後に \ をつける )

' ************************************************
' コンストラクタのようなもの( New では呼ばれない )
' ************************************************
	Public Default Function InitSetting(ExcelApp,strPath)

		Me.ErrFlg = false

		If Not IsObject(Me.Fs) Then
			Set Me.Fs = CreateObject( "Scripting.FileSystemObject" )
		end if

		If Not IsObject(ExcelApp) Then
			Set Me.ExcelApp = CreateObject("Excel.Application")
			Set ExcelApp = Me.ExcelApp
		else
			Set Me.ExcelApp = ExcelApp
		End If

		on error resume next
		Set ExcelBook = ExcelApp.Workbooks.Open(strPath)
		if Err.Number <> 0 then
			Me.ErrFlg = True
			Me.ErrDescription = Err.Description
			Log( "InitSetting:"&Err.Description )
			Exit Function
		end if
		on error goto 0

		' アクティブなウィンドウを最大化
		ExcelApp.ActiveWindow.WindowState = 2
		' 警告メッセージを非表示
		ExcelApp.DisplayAlerts = False

	end function
 
' ************************************************
' メソッド ( 表示・非表示の設定 )
' ************************************************
	Public Function Visible(bFlg)

		Me.ErrFlg = false

		Me.ExcelApp.Visible = bFlg

	End Function

' ************************************************
' Book を閉じる
' ************************************************
	Public Function Close()

		Me.ErrFlg = false

		If TypeName(ExcelBook) = "Workbook" Then
			' 保存した事にする
			ExcelBook.Saved = True
		End If
		ExcelBook.Close()
		Set ExcelBook = Nothing
		ExcelBook = Empty

	End Function

' ************************************************
' Excel 本体の終了
' ************************************************
	Public Function Quit()

		If IsObject(ExcelBook) Then
			If TypeName(ExcelBook) = "Workbook" Then
				' 保存した事にする
				ExcelBook.Saved = True
			End If
		End if
		If IsObject(ExcelApp) Then
			ExcelApp.Quit
			Set ExcelApp = Nothing
		End If
		ExcelApp = Empty

	End Function

' ************************************************
' シート名によるシート選択
' ************************************************
	Public Function SelectSheet(strSheetName)

		Me.ErrFlg = false

		on error resume next
		ExcelBook.Sheets(strSheetName).Select
		if Err.Number <> 0 then
			Me.ErrFlg = True
			Me.ErrDescription = Err.Description
			Log( "SelectSheet:"&Err.Description )
			Exit Function
		end if
		on error goto 0

	End Function

' ************************************************
' 番号よるシート選択
' ************************************************
	Public Function SelectSheetNo(No)

		Me.ErrFlg = false

		on error resume next
		ExcelBook.Sheets(No).Select
		if Err.Number <> 0 then
			Me.ErrFlg = True
			Me.ErrDescription = Err.Description
			Log( "SelectSheetNo:"&Err.Description )
			Exit Function
		end if
		on error goto 0

	End Function

' ************************************************
' セルへのデータセット
' ************************************************
	Public Function SetCell(strSheetName, x, y, Data)

		Me.ErrFlg = false

		on error resume next
		ExcelBook.Sheets(strSheetName).Cells(y, x) = Data
		if Err.Number <> 0 then
			Me.ErrFlg = True
			Me.ErrDescription = Err.Description
			Log( "SetCell:"&Err.Description )
			Exit Function
		end if
		on error goto 0

	End Function
	Public Function SetCellActive(x, y, Data)

		Me.ErrFlg = false

		on error resume next
		ExcelBook.ActiveSheet.Cells(y, x) = Data
		if Err.Number <> 0 then
			Me.ErrFlg = True
			Me.ErrDescription = Err.Description
			Log( "SetCellActive:"&Err.Description )
			Exit Function
		end if
		on error goto 0

	End Function

' ************************************************
' セルからデータの取得
' ************************************************
	Public Function GetCell(strSheetName, x, y)

		Me.ErrFlg = false

		on error resume next
		GetCell = ExcelBook.Sheets(strSheetName).Cells(y, x)
		if Err.Number <> 0 then
			Me.ErrFlg = True
			Me.ErrDescription = Err.Description
			Log( "GetCell:"&Err.Description )
			Exit Function
		end if
		on error goto 0

	End Function
	Public Function GetCellActive(x, y)

		Me.ErrFlg = false

		on error resume next
		GetCellActive = ExcelBook.ActiveSheet.Cells(y, x)
		if Err.Number <> 0 then
			Me.ErrFlg = True
			Me.ErrDescription = Err.Description
			Log( "GetCell:"&Err.Description )
			Exit Function
		end if
		on error goto 0

	End Function

	Public Function Log(str)

		Dim obj

		Set obj = Me.Fs.OpenTextFile( LogPath&"ExcelAction.log", 8, True )
		obj.WriteLine( Now&":"&str )
		obj.Close()

	End Function

End Class
@END