森と泉ホームページ:エクセルで遊ぼう1 forest and spring:excel

製本(中とじ絵本づくり)　　　　　　　　　エクセルで遊ぼう　作画　製本　問題　作曲

絵本をホチキス止めで作ったんだけど、なんか迫力ないな。もっといい方法ないかなー。

わぁ、絵が大きい！　えっ？全ページがこうなの？　ホチキス止めなのに、すごいすごい。

簡単な中とじで製本できる絵本を作ろう。
中とじホチキス2発で製本でき、軽く、机の上に水平に開き、読みやすく、ダイナミックに大きな絵をすべての見開きに入れても真ん中の折れ目で絵柄のずれや欠けが少ない。
絵本だけでなく、マンガ、絵手紙や絵画作品集、写真集、旅行記、自分史、詩集、マニュアルなど絵を多用した冊子に最適です。コミケット等の同人誌もいいですね。自分で、いつでも好きなときに多種少量の製本ができる。

前準備

図とVBAステートメントを参考に、絵本画像処理.xlsmを作る。

絵本画像処理フォルダーをデスクトップなどに準備し、中に絵本画像処理.xlsm、空のoriginal／finishフォルダーを入れる。

原稿を準備し、スキャンする

絵本の大きさをA4サイズ等に揃えた（ここ大切）、表紙、内表紙、奥付け、本文の原稿を用意する。

絵本原稿を解像度一定(例：96dpi)でスキャンする。
　

エクセルでの操作

スキャンで得た画像データをoriginalフォルダーに入れる。

絵本画像処理.xlsmの各セルにデータを入れる。

セルB3は1または2を入れる（右とじ1、左とじ2）。

セルA5は表紙を入れる。

セルB5は内表紙を入れる。

セルB6から右回りに本文を入れる。

セルA7は最終本文を入れる。もし、なければ空白とする。

セルA6は奥付けを入れる。

コマンドボタンを押す。

finishフォルダーに画像データが出力される。

印刷

finishフォルダーの画像を全選択し、表紙画像の上(ここ大切)にマウスを載せ、右クリックする。

印刷を選択する。

すぐに印刷へ進まず、右下の「オプション」をクリック。

「プリンターのプロパティ」をクリック。

おなじみのプリンターの画面が出るので、ここで単純な「両面印刷」を指定し、印刷する。(ブックレット等は指定しないこと）

注意

まずは1部だけ印刷し、おかしい個所はないか確認しよう。。

original／finishフォルダーはバックアップを取り、いつも空にしておこう。

参考

・後から一部分を修正しようとペイントソフトなどで加工するといつのまにか解像度(dpi)が変化することがあるので注意。

・当画像処理では完成画像にグレーの輪郭が出る。「画像をフレームに合わせて印刷する」を選び、かつプリンターのプロパティで「中央合わせ」を選ぶとグレーの輪郭を消せる。

・処理時にエクセルをズームしていた場合、original画像に対してfinish画像のサイズが変化する。ズームが100%時は約1.37倍、50%時は約0.69倍、73%時は約1倍になる。

・Function savejpg中のステートメント10行目の".jpg"の部分を".png"や".bmp"等に変えることもできる。

Option Explicit

Dim w, h, t, z As Double
Dim migitoji, trimhosei As Boolean
Dim j As Integer
Dim f0, f00 As String

Sub 絵本画像処理()

Dim i As Integer
Dim f1, f2, p1, p2, g As String

Dim myshape As Shape
    For Each myshape In ActiveSheet.Shapes
        If myshape.Type <> msoFormControl Then
            myshape.Delete
        End If
    Next

z = 0.5: trimhosei = False: Cells(4, 2) = ""
j = 0
If Cells(3, 2) = 1 Then
   migitoji = True
   Else
   migitoji = False
   End If
  
   f0 = ActiveWorkbook.Path & "\original\"
   f00 = ActiveWorkbook.Path & "\finish\"
    
For i = 5 To 104
    f1 = Cells(i, 1)
    f2 = Cells(i - 1, 2)

If (Left(f1 & f2 & " ", 1) = " " Or Left(f1 & f2 & " ", 1) = "　") Then
    For Each myshape In ActiveSheet.Shapes
        If myshape.Type <> msoFormControl Then
            myshape.Delete
        End If
    Next
    Exit Sub
ElseIf (Left(f2 & " ", 1) = " " Or Left(f2 & " ", 1) = "　") Then
    ActiveSheet.Pictures.Insert(f0 & f1).Select
    w = Selection.ShapeRange.Width
    h = Selection.ShapeRange.Height
    p1 = Selection.ShapeRange.Name
    Selection.ShapeRange.Top = (i - 5) * 500 + 140
    Selection.ShapeRange.Left = 200
    savejpg (p1)
ElseIf (Left(f1 & " ", 1) = " " Or Left(f1 & " ", 1) = "　") And i = 7 Then
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 880, (i - 6) * 500 + 140, _
        w, h).Select
    With Selection.ShapeRange.Fill
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .Solid
    End With
    Selection.ShapeRange.Line.Visible = msoFalse
    p1 = Selection.ShapeRange.Name
     ActiveSheet.Pictures.Insert(f0 & f2).Select
    p2 = Selection.ShapeRange.Name
    Selection.ShapeRange.Top = (i - 6) * 500 + 140
    Selection.ShapeRange.Left = 880
    ActiveSheet.Shapes.Range(Array(p1, p2)).Select
    Selection.ShapeRange.Group.Select
    g = Selection.ShapeRange.Name
    ActiveSheet.Shapes.Range(Array(p2)).Select
    Trim1 (w)
    savejpg (g)
    
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 200, (i - 5) * 500 + 140, _
        w, h).Select
    With Selection.ShapeRange.Fill
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .Solid
    End With
    Selection.ShapeRange.Line.Visible = msoFalse
    p1 = Selection.ShapeRange.Name
     ActiveSheet.Pictures.Insert(f0 & f2).Select
    p2 = Selection.ShapeRange.Name
    Selection.ShapeRange.Top = (i - 5) * 500 + 140
    Selection.ShapeRange.Left = 200
    ActiveSheet.Shapes.Range(Array(p1, p2)).Select
    Selection.ShapeRange.Group.Select
    g = Selection.ShapeRange.Name
    ActiveSheet.Shapes.Range(Array(p2)).Select
    Trim2 (w)
    savejpg (g)
ElseIf (Left(f1 & " ", 1) = " " Or Left(f1 & " ", 1) = "　") Then
    ActiveSheet.Pictures.Insert(f0 & f2).Select
    p1 = Selection.ShapeRange.Name
    Selection.ShapeRange.Top = (i - 6) * 500 + 140
    Selection.ShapeRange.Left = 880
    savejpg (p1)
Else
    ActiveSheet.Pictures.Insert(f0 & f1).Select
    p1 = Selection.ShapeRange.Name
    Selection.ShapeRange.Top = (i - 6) * 500 + 140
    Selection.ShapeRange.Left = 880
    ActiveSheet.Pictures.Insert(f0 & f2).Select
    p2 = Selection.ShapeRange.Name
    Selection.ShapeRange.Top = (i - 6) * 500 + 140
    Selection.ShapeRange.Left = 880
    ActiveSheet.Shapes.Range(Array(p2, p1)).Select
    Selection.ShapeRange.Group.Select
    g = Selection.ShapeRange.Name
    ActiveSheet.Shapes.Range(Array(p2)).Select
    Trim1 (w)
    savejpg (g)
    ActiveSheet.Pictures.Insert(f0 & f1).Select
    p1 = Selection.ShapeRange.Name
    Selection.ShapeRange.Top = (i - 5) * 500 + 140
    Selection.ShapeRange.Left = 200
    ActiveSheet.Pictures.Insert(f0 & f2).Select
    p2 = Selection.ShapeRange.Name
    Selection.ShapeRange.Top = (i - 5) * 500 + 140
    Selection.ShapeRange.Left = 200
    ActiveSheet.Shapes.Range(Array(p2, p1)).Select
    Selection.ShapeRange.Group.Select
    g = Selection.ShapeRange.Name
    ActiveSheet.Shapes.Range(Array(p2)).Select
    Trim2 (w)
    savejpg (g)
   End If
   
  Next
  
End Sub
Function savejpg(g As String)
    j = j + 1
    Dim Shp
    Set Shp = ActiveSheet.Shapes(g)
    Dim Cht
    Set Cht = ActiveSheet.ChartObjects.Add(150, 150, w, h)
    With Cht
        Shp.CopyPicture Format:=xlBitmap
        .Chart.Parent.Select
        .Chart.Paste
        .Chart.Export f00 & j & ".jpg"
        .Delete
    End With
End Function
Function Trim1(w As Double)
100 t = w * z
    If migitoji = True Then
    Selection.ShapeRange.PictureFormat.CropRight = 0
    Selection.ShapeRange.PictureFormat.CropLeft = t
    Else
    Selection.ShapeRange.PictureFormat.CropRight = t
    Selection.ShapeRange.PictureFormat.CropLeft = 0
    End If

If trimhosei = False Then
       z = z * 0.5 * w / (w - Selection.ShapeRange.Width)
       trimhosei = True
       GoTo 100
    End If
    
End Function

Function Trim2(w As Double)
100 t = w * z
    If migitoji = True Then
    Selection.ShapeRange.PictureFormat.CropRight = t
    Selection.ShapeRange.PictureFormat.CropLeft = 0
    Else
    Selection.ShapeRange.PictureFormat.CropRight = 0
    Selection.ShapeRange.PictureFormat.CropLeft = t
    End If

If trimhosei = False Then
       z = z * 0.5 * w / (w - Selection.ShapeRange.Width)
       trimhosei = True
       GoTo 100
    End If
    
End Function

中とじホチキス
文房具店で600円くらい。百均にもある。針は通常のものと同じ。