' リサイズ用コードサンプル' Call img.Convert("image.tif", "-resize", "800", "work.bmp")
'
' 実サイズの標準値( ミリ )
nRealWidth = 251
nRealHeight = 181
Set fso = CreateObject("Scripting.FileSystemObject")
Set img = CreateObject("ImageMagickObject.MagickImage.1")
Dim Book ' 一つのブックを処理するインスタンス
Set Book = New ExcelAction
Call Book(ExcelApp,"パラメータのあるExcelのフルパス")
' デフォルトが非表示なので表示
Book.Visible( True )
' 二つ目のシートを使用する
Book.SelectSheetNo( 2 )
str = Book.GetCellActive(7,3)
n1 = CLng(str)
str = Book.GetCellActive(8,3)
n2 = CLng(str)
Book.Quit()
' 全てのプックを閉じてから、いずれかのインスタンスで終了する' ブックが一つの場合は、閉じる必要は無い( 閉じてから終了 )
Call CropImage( "元画像.拡張子", n1, n2 )
Wscript.Echo "処理が終了しました"
Function CropImage( strFileName, nRight, nLeft )
' 右からの切り取り位置' 左からの切り取り位置
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", _
aData(0)&"-h.png" )
' 画像上の左からの切り取り位置
nCrop2 = CLng(nWidth*nLeft/nRealWidth)
sParam2 = nCrop2 & "x" & nHeight & "+0+0"
Call img.Convert( _
"work.bmp", _
"-crop", _
sParam2, _
"+repage", _
aData(0)&"-f.png" )
' 画像上の中央の切り取り位置
sParam3 = nWidth-nCrop2-nCrop1 & "x" & nHeight & "+" & nCrop2 & "+0"
Call img.Convert( _
"work.bmp", _
"-crop", _
sParam3, _
"+repage", _
aData(0)&"-b.png" )
End Function
' ************************************************' クラス定義' ************************************************
Class ExcelAction
Public ExcelApp ' 共有
Public ExcelBook ' このインスタンス用
' ************************************************' コンストラクタのようなもの( New では呼ばれない )' ************************************************
Public Default Function InitSetting(ExcelApp,strPath)
If Not IsObject(ExcelApp) Then
Set Me.ExcelApp = CreateObject("Excel.Application")
else
Set Me.ExcelApp = ExcelApp
End If
Set ExcelApp = Me.ExcelApp
Set ExcelBook = ExcelApp.Workbooks.Open(strPath)
' アクティブなウィンドウを最大化
ExcelApp.ActiveWindow.WindowState = 2
' 警告メッセージを非表示
ExcelApp.DisplayAlerts = False
end function
' ************************************************' メソッド ( 表示・非表示の設定 )' ************************************************
Public Function Visible(bFlg)
Me.ExcelApp.Visible = bFlg
End Function
' ************************************************' Book を閉じる' ************************************************
Public Function Close()
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)
ExcelBook.Sheets(strSheetName).Select
End Function
' ************************************************' 番号よるシート選択' ************************************************
Public Function SelectSheetNo(No)
ExcelBook.Sheets(No).Select
End Function
' ************************************************' セルへのデータセット' ************************************************
Public Function SetCell(strSheetName, x, y, Data)
ExcelBook.Sheets(strSheetName).Cells(y, x) = Data
End Function
Public Function SetCellActive(x, y, Data)
ExcelBook.ActiveSheet.Cells(y, x) = Data
End Function
' ************************************************' セルからデータの取得' ************************************************
Public Function GetCell(strSheetName, x, y)
GetCell = ExcelBook.Sheets(strSheetName).Cells(y, x)
End Function
Public Function GetCellActive(x, y)
GetCellActive = ExcelBook.ActiveSheet.Cells(y, x)
End Function
End Class
' スクリプトが存在するディレクトリ' 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
ImageMagick で 画像を一括切り抜き処理 『VBScript/C++/PHP/バッチファイル』
※ コマンドラインで使用しないのであれば、2番目のチェックは必要ありません
以下が抽出用のソースコードです。
PNG ファイルのままではトリミングできないので、一括処理用に対象となる PNG ファイル
を一つのディレクトリにコピーして、以下の処理を実行しました。
これは、Windows に既に