月別アーカイブ: 2025年8月

解答欄(矩形)検出器を改良しました!

AnswerAreaLocator 実行時の画面


この Blog の過去記事で紹介している手書き答案の採点補助プログラム AC_Reader では、スキャナーでスキャンして Jpeg 形式で保存した試験の解答用紙画像から、解答欄の座標を取得するプログラムを外部的に呼び出して利用しています。

この解答欄の座標を取得するプログラムは、OpenCV の矩形検出機能を使って、その目的を実現しているのですが(掲載しておいてこんなことを言うのもナンですが)、必ずしも意図した通りに動かない場合がありました。

今回、その「いつか直そうと思っていた部分を手直し」して、前よりは少しは意図した通りに動くかな? みたいなプログラムが出来た気がするので、「デジタル採点 All in One」なる大それた名前を付けて世に出してしまったプログラム集のバージョンアップ版として公開させていただきます。

プログラムの名前も、よりわかりやすいものに変更( AnswerAreaLocator.exe )しました(が、単体での使用は事故防止のため非推奨です)。あくまでも AC_Reader.exe から呼び出しての動作が基本ですが、たぶん、以前のモノより、期待通りに動作するものと思われます。万一にでも、バージョンアップしてくれないかなーと思われていた方が「もし、いてくださったら」のお話ではありますが・・・

今回の記事では、そのバージョンアップ内容(正しくは不具合のお詫びとその修正内容)をご紹介させていただきます。

【もくじ】

1.GUIが使いやすくなりました!
2.画像の傾きに強くなりました!
3.ほぼ採点する順番に解答欄を検出できるようになりました!
4.マウスのアイコンがデフォルト状態に戻るようになりました!
5.必要なフォルダがない場合には警告を表示するようになりました!
6.常に最大化して実行する設定にしてやっぱりやめました!
7.最大化から非最大化した際に画面中央にフォームを表示します!
8.ダウンロードのご案内
9.まとめ
10.お願いとお断り

1.GUIが使いやすくなりました!

以前のユーザーインターフェイスは、次のようなものでした。

「画像の傾きを補正する機能を重視」した結果、操作方法がわかりにくい設計となっておりました。


新しいプログラムのユーザーインターフェイスです。基本的に、左から右へ操作していただければ作業がスムースに進むように改良しました。

画像の傾きの補正機能は残しましたが、使用しなくても動作するように修正しました。


スキャナーでスキャンした画像のすべてが、目視状態で明らかに傾いて(左右いずれかの方向に回転して)いる場合がありますので、画像の回転を行って、傾きを補正する機能は残しましたが、機能の実装方法そのものを見直し、負の数で左へ回転/正の数で右へ回転、Prev ボタンで効果を確認、UnDo ボタンでやり直し、実行ボタンで全画像に修正を適用というように簡略化しました。

また、矩形検出「する/しない」の境界を決める閾値も、以前は面積を利用するようにしていましたが、新しいプログラムでは、検出限界とする幅もしくは高さをピクセル単位で指定できるように変更しました。使っていただければ、お分かりいただけると思うのですが、例えば以下のような場合、自動的に小さな矩形を最初から無視しますので、より解答欄の矩形だけを検出する方向に進化できたのではないかと思います。

矩形検出を実行した段階で設問番号の「1」を囲む矩形は検出対象から自動的に外されます。


また、これは以前と同じですが、「6文字で答えよ」と文字数を指定して解答させたい場合は、検出したい矩形の外枠を実線で、内部を点線として予め解答欄を作成(描画)しておくことで、後から手動で範囲指定をやり直さなくとも、取得したい解答欄そのものを自動的に取得できます。

点線は、目視で線がつながっていないことが確認できれば大丈夫(検出されません!)。


ちなみに、点線は、誰もが使っているであろう「あのソフトウェア」で描いたものです。上の図の点線は、下の赤枠内の点線を利用して描画しました。

ちなみに実線は、赤枠の4つ下の実線です。


それから、間違っていたらごめんなさい。赤枠の1つ上の細かな(?)点線は、要注意の線です。私の見間違いかもしれませんが、以前、この線を利用する中で「とても不思議な現象に出会った」ことがあり、それ以来、この線は簡易的な利用にとどめ、本格的な何か(色を変えたりみたいな)には利用しないようにしています。詳しくは書きませんが、いろいろワケありの線のようです・・・

また、GUI で、ブロックと表現している部分の考え方ですが、これは採点する順番に解答欄座標を並べることができるように、解答用紙を幾つかのブロックに分けて、そのブロック内で横書き答案であれば「左 → 右」かつ「上 → 下」へ、国語で使われる縦書き答案であれば「上 → 下」かつ「右 → 左」へ、解答欄の座標を検出します。

上のような場合には、「2」ブロックを指定します。

2.画像の傾きに強くなりました!

以前のバージョンで、最も対応困難であったのが「スキャンした画像の傾き」です。

以前の勤務先で使用していた複合機では、気になるほどスキャンした画像が傾くことなどなかったのですが、今の勤務先で使用している複合機のスキャナーは(同じメーカーさんの同じ型番の製品ですが)、スキャンすると画像がことごとく右肩上がりになるこの固体特有のクセがあり、サービスマンの方に修正を依頼しても「これはちょっと難しいですね・・・」と断られてしまった経緯もあって、自分では紙送りローラーのクリーニングくらいしかできませんので、たいへん困っておりました。

もちろん、傾きと言っても、わずか 0.1° 程度の傾きですので、私以外に誰一人、問題にする人なんていませんが・・・

私はものすごく気になるのです!

なぜか? というと・・・ 私の神経が細やかとか、そんな問題ではなく、どちらかと言えば、私は神経が少し足りないんじゃないかと思うことの方が多いくらいです・・・。その証拠に『点くのが遅い蛍光灯のようなお子さんですね!』と小学校時代、担任の先生から言われたと母親が語っておりましたし、私はその時、多分言葉の意味そのものが理解できず、おそらく褒められたに違いないと勘違いして、むしろ、喜んでいたのではないか? とも思います。ヽ(=´▽`=)ノ

とにかく、これまでの矩形検出プログラムで解答欄矩形の座標を検出して、採点する順番になるように並び替える際、横書き答案であれば「 Y 座標の値が小さいものから順に、左から右へ並べ替える」アルゴリズムを採用しているため、解答用紙の画像が左へ傾いていると、座標原点 0,0 が左上であるため、右側の解答欄ほど Y 座標の値が小さくなり、検出した座標を並び替える際に「上から下へ」の順番はなんとか守れても、「左から右へ」が「右から左へ」と、「一部の解答欄座標の並びが逆転」してしまうわけです。

この修正が大変な手間で・・・

( AC_Reader を使ってくださる方のお手伝いをする際に、いつも、そう感じ・・・ )

ほんとうに、申し訳なく・・・

私自身の心情など、この際、極めて、どうだっていいコト・・・ では、ありますが・・・

私といっしょに暮らしているヒトは、とてもやさしくて、かわいい、イイひとなのですが、極々稀に、ブチ切れると、ながーい間、沈黙した挙句・・・ 私は、完全に悪くないと思えてならないときでも・・・

おまえが、わるい。

必ず、そう言います。

控えめに「そうなの?」と尋ねることにしているのですが、返事は決まって

だって、そうじゃん!

この言葉を聞いた時の心境が、まさに、この場合のそれで・・・。みなさんに、どうにかして、ご理解いただきたい私自身の偽りのない心情なのです・・・

ほんとうに、良かれと信じて、精一杯、その時の自分にある、全身全霊の、すべての力を使って書いた・・・と、そう信じて疑わないプログラム。・・・なのですが・・・

それは・・・悪気なんて全然なく、きみのために良かれと思ってやったこと・・・

でも、その プログラム には、不具合があった・・・。

でも、きみは、なぜか、怒っている・・・。

悪いのは ・・・。

そう、ほんとうに、精一杯、がんばって、「書いたのは間違いない」んだけど・・・ 。

そう、ほんとうに、きみとケ〇カなんて、したくなかった・・・。

だけど・・・ だから・・・

間違ったのは僕なんです。
みんな僕が悪いんです。

一緒に暮らしているヒトと、ケ〇カするといつも、そんな気持ちになります。

で、そんな時、「今日の晩御飯、なぁに?」って彼女に尋ねると・・・

へびとカエル

彼女は、必ずそう答えるのです・・・ 実際に、それが出てきたことは幸いにしてありませんが。

そのように悪いのは私だと理解していますので、以前のプログラムでは、解答欄座標を検出する前に、全画像を傾きがなくなる方向に回転させて、傾きを修正してから解答欄矩形の座標を検出するように手順を工夫していたのです。それは、それで「ない」知恵を絞って考えた自分的には限界とも思える方法だったのですが、この修正を行っても 100 %スムースに作業できるとは到底思えず、(あのプログラム、検出して並び変えた結果の一部は必ず修正が必要な状態なのではなかろうか・・・ある程度はちゃんと動くと思うんだけど・・・、ちょっとでも傾きがあると・・・うーん、困ったぁ)と、思い出す度に同じ思いが込み上げてきて、日々、後悔と、反省と、絶大なる心配とを、交互に繰り返しておりました。

いつか、なんとかしなければ・・・

そう思いながらも、よい方法が思いつかず、更新が先延ばしになってしまいました。お使いいただけた皆さまに、伏してお詫び申し上げます。ほんとうに、すみませんでした。

今回の更新では、正直に言いますと当初、得られた解答欄矩形の座標から、水平方向の直線を複数本検出して、その傾きの平均値を計算し、全自動で画像の傾きを修正する方向でプログラムの修正作業を進めたのです・・・が、残念ながら、現在の私の力では、自分自身が満足できる結果を出すことは出来ませんでした。

そこで、全自動での修正を断念し、画像の傾きを補正する部分と解答欄矩形を検出する部分、両方のアルゴリズムを(自分の力の及ぶ限りの範囲ではありますが)全面的に見直すことにしました。

そこで思いついたのが、横並びの解答欄を「行」のように見なし、Y 方向に「多少のマージン」を設定することで、検出した解答欄座標を理想通りに並べ替えて表示できるのではないかということです。さらに、これが出来れば、解答用紙画像の多少の傾きなど問題ではなくなるはずです。この考えを基にしてスクリプトを書き替えること2度、3度、ようやく思った通りに解答欄矩形の座標を並べ替えて出力できるようになりました。少なくても、私のテストした範囲では、採点する順番で解答欄座標の並び替え出力に成功するようになった・・・と思えるプログラムに改良することが出来ました☆

もちろん、国語の試験で利用される縦書き答案についても、縦並びの解答欄を「列」のように見なし、やはり「多少のマージン」を設定することで、画像が少しくらい傾いていても基本「右から左」かつ「上から下」へという順番で検出した解答欄座標を並べ替えて表示できるように、こちらもプログラムを修正できました。

以下は、Delphi に埋め込んで使用している「横書き答案の解答欄座標を検出して、採点順に並べ替える」 Python Script です(ダウンロードしていただいた Zip ファイルのサイズが大きいのも、展開に時間がかかるのも、Python 用の OpenCV をバックグラウンドで動作させているためです)。

  import cv2
  import numpy as np

  def imread_unicode(path):
      with open(path, "rb") as f:
          data = f.read()
      img_array = np.frombuffer(data, np.uint8)
      return cv2.imdecode(img_array, cv2.IMREAD_COLOR)

  def deskew_image(gray):
      edges = cv2.Canny(gray, 50, 150, apertureSize=3)
      lines = cv2.HoughLines(edges, 1, np.pi / 180, 150)
      if lines is None:
          return gray
      horizontal_angles = []
      for rho, theta in lines[:, 0]:
          angle_deg = (theta * 180 / np.pi)
          if (angle_deg < 10) or (angle_deg > 170):
              adjusted_angle = angle_deg if angle_deg < 90 else angle_deg - 180
              horizontal_angles.append(adjusted_angle)
      if len(horizontal_angles) < 5:
          return gray
      mean_angle = np.mean(horizontal_angles)
      if abs(mean_angle) < 0.3:
          return gray
      (h, w) = gray.shape
      center = (w // 2, h // 2)
      M = cv2.getRotationMatrix2D(center, mean_angle, 1.0)
      rotated = cv2.warpAffine(gray, M, (w, h), flags=cv2.INTER_LINEAR, borderValue=255)
      return rotated

  def detect_inner_boxes(image_path):
      img_color = imread_unicode(image_path)
      if img_color is None:
          raise FileNotFoundError(f"画像が見つかりません: {image_path}")
      img_gray = cv2.cvtColor(img_color, cv2.COLOR_BGR2GRAY)
      thresh = cv2.adaptiveThreshold(
          img_gray, 255,
          cv2.ADAPTIVE_THRESH_GAUSSIAN_C,
          cv2.THRESH_BINARY_INV,
          15, 10
      )
      contours, _ = cv2.findContours(thresh, cv2.RETR_TREE, cv2.CHAIN_APPROX_SIMPLE)
      boxes = []
      for cnt in contours:
          x, y, w, h = cv2.boundingRect(cnt)
          if w > ' + cmbThreshold.Text + ' and h > ' + cmbThreshold.Text + ':
              boxes.append((x, y, w, h))
      inner_boxes = []
      for i, box in enumerate(boxes):
          x1, y1, w1, h1 = box
          rect1 = (x1, y1, x1 + w1, y1 + h1)
          contains_other = False
          for j, other in enumerate(boxes):
              if i == j:
                  continue
              x2, y2, w2, h2 = other
              rect2 = (x2, y2, x2 + w2, y2 + h2)
              if rect1[0] <= rect2[0] and rect1[1] <= rect2[1] and rect1[2] >= rect2[2] and rect1[3] >= rect2[3]:
                  contains_other = True
                  break
          if not contains_other:
              inner_boxes.append(box)

      if not inner_boxes:
          return []
      y_tolerance = max(5, int(np.median([h for (_,_,_,h) in inner_boxes]) * 0.5))
      inner_boxes.sort(key=lambda b: b[1])
      sorted_boxes = []
      current_row = []
      current_y = None
      for b in inner_boxes:
          x, y, w, h = b
          if current_y is None:
              current_y = y
              current_row.append(b)
          elif abs(y - current_y) <= y_tolerance:
              current_row.append(b)
          else:
              current_row.sort(key=lambda b: b[0])
              sorted_boxes.extend(current_row)
              current_row = [b]
              current_y = y
      if current_row:
          current_row.sort(key=lambda b: b[0])
          sorted_boxes.extend(current_row)
      inner_boxes = sorted_boxes
    
      for idx, (x, y, w, h) in enumerate(inner_boxes, start=1):
          var1.Value = str(x) + "," + str(y) + "," + str(x + w) + "," + str(y + h)
      return inner_boxes

  if __name__ == "__main__":
      image_path = r"' + 'CutImage0' + IntToStr(i) + '.jpg' + '"
      boxes = detect_inner_boxes(image_path)

横書き答案で、ブロックの指定が2以上である場合がありますので、この処理を for ループの中に埋め込んでいます。また、この横書きでブロックの指定が2以上である答案の場合には、2ブロック目に検出した座標の値のx座標を一律補正するような処理も Delphi 側で必要ですが、核心部分はなんと言っても、上のスクリプトです。思えば、ここに至るまで、はや幾年月・・・

横書き用が出来てしまえば、あとはそれを縦書き用に書き換えるだけです。「縦書き答案用のスクリプト」は次の通りです。

  import cv2
  import numpy as np

  def imread_unicode(path):
      with open(path, "rb") as f:
          data = f.read()
      img_array = np.frombuffer(data, np.uint8)
      return cv2.imdecode(img_array, cv2.IMREAD_COLOR)

  def detect_inner_boxes(image_path):
      img_color = imread_unicode(image_path)
      if img_color is None:
          raise FileNotFoundError(f"画像が見つかりません: {image_path}")
      img_gray = cv2.cvtColor(img_color, cv2.COLOR_BGR2GRAY)
      thresh = cv2.adaptiveThreshold(
          img_gray, 255,
          cv2.ADAPTIVE_THRESH_GAUSSIAN_C,
          cv2.THRESH_BINARY_INV,
          15, 10
      )

      contours, _ = cv2.findContours(thresh, cv2.RETR_TREE, cv2.CHAIN_APPROX_SIMPLE)

      boxes = []
      for cnt in contours:
          x, y, w, h = cv2.boundingRect(cnt)
          if w > ' + cmbThreshold.Text + ' and h > ' + cmbThreshold.Text + ':
              boxes.append((x, y, w, h))

      inner_boxes = []
      for i, box in enumerate(boxes):
          x1, y1, w1, h1 = box
          rect1 = (x1, y1, x1 + w1, y1 + h1)
          contains_other = False
          for j, other in enumerate(boxes):
              if i == j:
                  continue
              x2, y2, w2, h2 = other
              rect2 = (x2, y2, x2 + w2, y2 + h2)
              if rect1[0] <= rect2[0] and rect1[1] <= rect2[1] and rect1[2] >= rect2[2] and rect1[3] >= rect2[3]:
                  contains_other = True
                  break
          if not contains_other:
              inner_boxes.append(box)

      if not inner_boxes:
          return []
      x_tolerance = max(5, int(np.median([w for (_,_,w,_) in inner_boxes]) * 0.5))
      inner_boxes.sort(key=lambda b: b[0], reverse=True)
      sorted_boxes = []
      current_col = []
      current_x = None
      for b in inner_boxes:
          x, y, w, h = b
          if current_x is None:
              current_x = x
              current_col.append(b)
          elif abs(x - current_x) <= x_tolerance:
              current_col.append(b)
          else:
              current_col.sort(key=lambda b: b[1])
              sorted_boxes.extend(current_col)
              current_col = [b]
              current_x = x
      if current_col:
          current_col.sort(key=lambda b: b[1])
          sorted_boxes.extend(current_col)
      inner_boxes = sorted_boxes

      for (x, y, w, h) in inner_boxes:
          var1.Value = str(x) + "," + str(y) + "," + str(x + w) + "," + str(y + h)

      return inner_boxes

  if __name__ == "__main__":
      image_path = r"CutImage01.jpg"
      detect_inner_boxes(image_path)

こちらについては「横書き答案」とは異なり、私が想定した範囲では「現状」ブロックに分割しての処理の必要性が感じられませんでしたので、Loop での処理は考慮しておりません。

3.ほぼ採点する順番に解答欄を検出できるようになりました!

極端な例として(いくらなんでも、これはないと思いますが)-1.00° ほど故意に画像を傾けて実験してみました。

「回転」に負の数を指定すると画像は左へ回転します。


左へ -1.00° 故意に回転させた画像に対して、解答欄座標の検出を行ってみた結果です。画像がどういう状態であろうと、傾きがあろうと、なかろうと、それに関係なく、プログラムが解答欄矩形の座標を左から右へ、そして上から下へ認識してくれたなら、夢はほんとうになります。

この夢は・・・

他の誰かが、既に実現した夢でもかまいません。私にとっては、まだ、成し遂げていない夢ですから。たとえ、だれひとり、この夢の成就を待っていてくれる人など、いなくても・・・

人の夢と書いて、「儚い」と読むそうですが、これほど、私の思いに重なる言葉はありません・・・。

僕の書いた・・・ プログラムは、僕の夢の結晶。

だから・・・ 人の夢の結晶が、たとえ「儚い」ものであっても・・・

うん。「儚い」ものでしか、なくても・・・

そこに込めた様々な願いと祈りは・・・

僕にとっての「ほんとう」です。

だから僕は、心から、それを いとしく おもいます。

プログラムは修正なしで、「解答欄 エ」よりY座標が大きい「解答欄 ア」を最初の座標に選んでいます。
設問番号「1」部分の矩形は、閾値の設定により検出対象外となっています。
この場合の座標原点は、左上が(0,0)です。


これだけの傾きがあっても、今回修正したプログラムは、ようやく長い間この胸に思い描き続けた夢の通りに動いてくれるようになりました。今回、全自動での補正(修正)処理は実現できませんでしたが、自分的には、この結果から見て・・・おそらく、今後、手動での傾きの補正処理はほぼ不要になるのではないか? と考えます。この実験結果より、「My 解答欄矩形の検出プログラムは、これまで内在していた不具合を一掃できるレベルに到達できた」と判断していいかも・・・と、ようやく思えた次第です。

ものすごく、遠いむかしに、断層を解析し、それを形成した応力場を描くプログラムを書いたことがあります。その際に非常に苦しんだのが PC の座標設定と、中学・高校以来慣れ親しんだ数学的な座標設定の相違でした。

当初、私は「座標原点は数学で学んだのと同じ X 軸と Y 軸の交点の位置にある」というように思い込んで、先人の書いたコードを読んでいましたので・・・

( 座標原点は、いったい、どこなんだ? )

と、大混乱。ようやく「座標原点は左上にある」と理解してからも、なお・・・

( 原点を移動して、解析図を描画するためには、ナニを、どう修正すればいい? )

あの時、大いに悩んだ経験が今回大いに役立ちました☆

ただ・・・、余弦定理の力を初めて知って、私に魂が震えるような感動の経験を与えてくれた・・・

あの断層解析プログラムは、
まだ1度も使っていません☆

が。

まぁ、作るのが楽しかった ♪ から、全然、自分的には「いい」のでありますが・・・

今後、断層解析の科学論文、書くことも、あり得ないし・・・

今はただ・・・ 青春を「理科」に賭けた思い出だけが、懐かしい。

*(^_^)* ♪

4.マウスのアイコンがデフォルト状態に戻るようになりました!

「当たり前のことじゃないか? なにバカなことを言ってるんだ」

そう言われても仕方がないことなので、こちらについても心からお詫びするしかないのですが・・・

実は、これも前から気になっていたことなのですが・・・、これまでのプログラムでは解答欄矩形の座標を取得後、時々、マウスのカーソルの形状が「上下左右の四方を向いた矢印」になり、デフォルトの「左斜め上を向いた白い矢印」に戻らなくなってしまう現象が、時々発生しておりました。

もちろん、ずっと気にはしていたのですが、でも、「何とかしなきゃ」と思いながらも、気づけばこちらも放置したままになってしまいました。理由は2つあって、1つはカーソルの形状が変化するだけで機能的な部分には(実用上何も)問題が生じなかった(つまり、見た目だけの問題であると認識していた)こと、2つめはそもそも「どこをどうしたら直せるのか」それがよくわからなかった・・・というのが私の中での、ほんとうです。

こんな不出来なプログラムを、耐え難きを・・・堪えて、それでもお使い下さった皆さま、ほんとうに、ありがとうございます。この件につきましても、ここであらためて、こころからお詫び申し上げます。重ね重ねではありますが、誠に、誠に申し訳ありませんでした。

今回の見直しにあたって、ようやく本気で「このままではいけない!」と思い、まず、その原因を探るところから修正作業を始めることにしました。まず、「いつ・どこで・何をするとカーソルの形状が変化したまま、元に戻らなくなるのか」それを明らかにする必要があります。私は、問題を再現すべくプログラムを様々に操作してみました。なかなか思った通りに問題が再現できず、ちょっと時間がかかりましたが、ようやく(変な言い方ですが)思った通りに問題を再現することが出来るようになりました。明らかになった問題発生に至るまでの操作は、次の通りです。

解答欄矩形の座標を取得すると表示されるラバーバンドの中をポイントすると、マウスカーソルの形状が次のように変化します。

この上下左右の四方を向いた矢印から成るカーソルは、
「サイズ変更カーソル」(Resize Cursor)という名前のようです。


この状態で、下向きの矢印キーを押し下げると TMemo 内のカーソルが次の座標に移動し、それに合わせてラバーバンドの位置が次の解答欄矩形上に移動します。

TMemo にフォーカスがあり、カーソルは2行目に移動します。
プログラムは2行目の座標を読み取り、その位置に赤い矩形を表示します。


この時、困ったことが起きます。ラバーバンドの外に出たらデフォルト状態に戻るはずのマウスカーソルの形状変化が起きず、その形状は「サイズ変更カーソル状態のまま」になってしまいます。下図はその状態をハードコピーしたものです。

マウスカーソルがデフォルトの白い矢印に戻りません!


ただし、機能的には何の問題もなく、このままの状態でボタンクリック等、通常通りの操作が可能です。このことが、この問題への対応がここまで遅れた原因の1つとなりました。

通常通り操作できますが、あまり気分がよくありません。


ここで、マウスカーソルをもう一度ラバーバンド内に戻してあげると、マウスカーソルの形状はデフォルトの白い矢印に戻るのですが、いちいちそんな操作はやってられません。

ラバーバンド内の左側領域をポイントするとデフォルト状態に戻ります。


この後、マウスカーソルをラバーバンド内から再度外に出します。カーソルの形状はデフォルト状態のままですが、再度、ラバーバンド内にカーソルを戻すとその形状は「サイズ変更」状態に変化し、ラバーバンドの外へ出すとデフォルト状態に戻ります。つまり、カーソルを動かすのではなく、カーソルを固定したまま、ラバーバンドの方を動かすと問題が発生することがわかりました。

マウスカーソルの形状は、デフォルト状態に戻りました。


詳しい原因はまだわかりませんが、とにかく、問題の核心部分がマウスカーソルの形状の制御にあることは明らかですので、次にそれがどのように実現されているのか、確認してみることにしました。

ラバーバンドを表示する部分のプログラムは、Mr.XRAYさんの TplResizeImage クラス(コンポーネント)を使わせていただき、Pen の太さと色を私が追加で指定しています。

この TplResizeImage.pas を開いて、じっくり読んでみます。すると、マウスの形状の制御は FSelected という Bool 型の変数で行われていて、これが True のとき、形状がサイズ変更カーソル(crSizeAll)になり、False のとき、デフォルト(crDefault)になることがわかりました。以下、その制御部分の抜粋です。

  TplResizeImage = class(TImage)
  private
    FSelected        : Boolean;

  ・・・

      if FSelected then begin
        Screen.Cursor := crSizeAll;
      end else begin
        Screen.Cursor := crDefault;
      end;

で、次の手続きで、マウスがコントロールから離れたらカーソルの形状をデフォルトに戻す設定になっていることもわかりました。

//=============================================================================
//  TplResizeImageクラス
//  CM_MOUSELEAVEメッセージ処理
//  マウスがコントロールから離れたらカーソルの形をデフォルトに戻す
//=============================================================================
procedure TplResizeImage.CMMouseleave(var Message: TMessage);
begin
  inherited;
  if not FSelected then exit;
  Screen.Cursor := crDefault;
  FResizeState  := irsNone;
end;

これより「マウスがコントロールから離れた」ことが確認できないところから問題が起きているのではないかと、ようやく、問題の原因らしきものが見えてきました。

どうしたらいいか、ひたすら考えます。すると、コメント文の中に次の一文が・・・

  //SetBoundsを実行すると,Resizeメソッドが自動実行される
  SetBounds(ALeft, ATop, Width, Height);

で、その Resize 部分を読んでみると・・・

procedure TplResizeImage.Resize;
var
  ALeft        : Integer;
  ・・・
begin
  ・・・
  SetBounds(ALeft, ATop, AWidth, AHeight);
  ・・・
end;

解答欄矩形の幅や高さが変わった場合は、必ず Resize が呼ばれます。そこで、ここに保険のような感じで、マウスのカーソルを元に戻す処理を追加しました。

//=============================================================================
//  TplResizeImageクラス
//  TImageのResizeメソッド
//  リサイズが発生すると自動的に呼ばれる
//=============================================================================
procedure TplResizeImage.Resize;
var
  ALeft        : Integer;
  ・・・ 省略 ・・・
begin
  ・・・ 省略 ・・・

  //サイズ変更後も必ずカーソルを戻す
  Screen.Cursor := crDefault;

  inherited Resize;
end;

これで解答欄矩形の幅や高さが変わった場合には、Resize 手続きが呼ばれ、マウスカーソルの形状が必ずデフォルト状態に戻ります。ただ、問題は幅や高さが変わらない場合です。幅や高さが変わらない解答欄は実際たくさんありますから、ここは手抜きをせず絶対にきちんと対応しなくてはなりません。

ただ、上に示したように Resize 手続きの中で SetBounds しているので、Resize 手続きは座標を入れ替える度に必ず呼ばれるような気もするのですが、より確実な方法を設定しておきたいと思い、カーソルの移動に使用している矢印キーの OnKeyDown イベントが使えないかと考えました。

考えました・・・が ・・・、よくよくコードを見ると、

TplResizeImage = class(TImage)

KeyDown は TWinControl 由来のイベントですが、TplResizeImage は TImage( = TGraphicControl )で親が違います。結論だけ言えば、 TImage はフォーカスを受け取れません。したがって KeyDown イベントは書いても無駄です・・・

と、ここで・・・

それなら、逆に、Form の方で KeyDown イベントを拾えばいいのではないか? と、ようやく気づき、

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN] then
    Screen.Cursor := crDefault;
end;

さらに、より確実に動作するよう OnKeyUp イベントにも同じ処理を記述します。

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN] then
    Screen.Cursor := crDefault;
end;

で、Form が他のコントロールより先にキーボードイベントを取得できるように FormCreate 手続きで、KeyPreview: = True を設定しておきます。

procedure TForm1.FormCreate(Sender: TObject);
begin
  KeyPreview:=True;
end;

これで完璧かと思いましたが、Application.OnMessage を使ってグローバルに押されたキーを監視し、矢印キーが押された場合にはマウスのカーソルをデフォルトに戻す処理も追加しておくことにしました。こちらは構造的な意味でも、保守性を高める意味でも Form のメンバーとして記述します。こうしておけば、何年か経って今日の作業内容を完全に忘れてしまった場合でも、Private 宣言部分を参照すれば、何を設定したのかがわかり、メンテナンスしやすいコードにすることができます。

私は、そのような意味から、手続きだけでなく関数も Form のメンバーとして記述するようにしています。むかしは何でもかんでも Form のメンバーにしていたのですが、この Blog を書くようになってから、他から呼び出す必要のない手続きや関数は、「ネストされた手続き(Nested Procedure)」 または 「ネストされた関数(Nested Function)」 として記述することも多くなりました。コードを読むのと、( Blog の記事用に)コピペするのが楽だからというのが、その主な理由です。

type
  TForm1 = class(TForm)
    ...
  private
    //Application.OnMessage を使ったグローバルキー監視
    procedure AppMessageHandler(var Msg: TMsg; var Handled: Boolean);
  end;

で、Shift + Ctrl + C で手続きを作成し、実装します。

procedure TForm1.AppMessageHandler(var Msg: TMsg; var Handled: Boolean);
begin
  case Msg.message of
    WM_KEYDOWN, WM_KEYUP:
      case Msg.wParam of
        VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN:
          Screen.Cursor := crDefault;
      end;
  end;
end;

最後に、FormCreate で登録しました。

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnMessage := AppMessageHandler;
end;

これで Form がアクティブ(フォーカスがある)な時も、非アクティブ(フォーカスがない)な時も、常にマウスのカーソルをリセットできるようになったはずです。

実行して確認しました!

ラバーバンドの内部をポイントして、カーソルを「サイズ変更型」に変えます。


下向きの矢印キーを押し下げます。ラバーバンドは次の解答欄へ移動します。マウスカーソルの位置はそのままですが、その形状は・・・

マウスカーソルはデフォルトの白い矢印に無事戻るようになりました☆


余談ですが、このマウスカーソルの形状も含めて画面のハードコピーを取るのはどうしたらいいものかと、今回、少し悩んでしまいました。Windows11の機能のみで行うなら、拡大鏡を固定(?)にして PrintScreen を実行すれば出来るみたいなことを AI が言ってましたが、せっかく Delphi があるんだし、ヒマもあったので、マウスカーソルの形状も含めて画面のハードコピーを取るプログラムを自分で書いてしまいました。後日、機会がありましたら、この Blog でご紹介したいと思います。

5.必要なフォルダがない場合には警告を表示するようになりました!

この解答欄矩形の座標検出プログラムは、ユーザー目線で見ると、ただ1枚の画像だけを扱うプログラムのように見えると思うのですが、実はそうではありません。

画像の傾きを補正して解答欄矩形の座標を取得する機能を追加した段階で、傾きの補正を行った場合には、すべての画像に対して傾き補正を行って上書き保存する処理がどうしても必要になり、採点作業に必要な全画像を処理できるように(1つ前のバージョンで)プログラムを修正しました。

詳しく説明すると、手書き答案の採点補助プログラム( AC_Reader )側では、採点前の真っ新な解答用紙画像と、採点データ(採点記号や得点等)を書き込んだ採点済み解答用紙画像の2種類の画像を使用していますので、傾き補正を行った場合は、両方の画像データを補正して上書き保存する必要が生じるわけです。

今回、全面的にプログラムの見直しを行ったわけですが、その中で、あろうことか、採点済み解答用紙画像を保存しておくフォルダ(フォルダ名: MarkedAnswerSheet )が必ず存在しているという前提でコードを書いていることが判明しました。

もちろん、AC_Reader 側で(正規の・・・というか、私が決めた流れで)画像変換を行って、AC_Reader からこの解答欄矩形の座標を検出するプログラムを呼び出して作業を行う場合は何の問題も生じませんが、単にスキャンした画像を1枚だけ保存した任意のフォルダを指定して、このプログラムを直接単体で実行した場合、採点済み解答用紙画像を保存するフォルダがそもそもありませんから、最初に行う解答用紙画像の選択段階で「確実にエラーが発生」します。

このエラー(というか、正しくは不幸な事故)を防止するために、修正する前のバージョンでも、このプログラムを単体で起動した場合にはパスワードの入力を求めるように設定して、事故を防止する方策としていたわけですが、今回の見直し作業の中で、テスト用の解答用紙画像を作成し、種々の確認作業を行ったところ、作った本人が採点済み解答用紙画像を保存するフォルダの準備を失念してしまい、初めて内在していたこの欠陥に気づいた次第です。

どぉしてこんなにバカなのか・・・

そこで次のように、採点済み解答用紙画像を保存するフォルダがなかった場合には警告を表示するようにプログラムを修正しました。

  //読み込むデータのあるフォルダへのPathを取得して表示
  SrcPath:=ExtractFilePath(imgPath)+'MarkedAnswerSheet';

  //フォルダの存在を確認 -> ない場合は警告してExitする
  if not System.SysUtils.DirectoryExists(SrcPath) then
  begin

    strMsg:='動作に必要なフォルダがありません!'+#13#10+
      'AC_Readerで「画像変換」を行ってから、再度実行してください。'+#13#10+#13#10+
      '処理を中止します。';
    Application.MessageBox(PChar(strMsg), PChar('エラー'), MB_ICONERROR);

    ・・・ 省略 ・・・
    Image1.Picture.Assign(nil);
    Exit;
  end;

5.の記事を書いた真意ですが、このプログラムを単体で起動するとパスワード入力を求められますので、「フリーソフトと言いながら、ふざけんな!」と気分を悪くされた方も、もしかしたらいらっしゃるかもしれないと思い、なぜ、パスワード入力が必要なのか、その本当の理由を記した次第です。

6.常に最大化して実行する設定にしてやっぱりやめました!

解答欄矩形を示すラバーバンドの位置を解答欄上に正しく表示するには、画面は常に最大化して表示する必要があります(最大化表示していないと解答欄矩形とラバーバンドがずれて表示されます)。

こちらの問題も修正しようかとも思いましたが、このプログラムを実行する場合、画面は最大化して作業するのが最も効率がよく、何か他の画面と並べて作業する必要性もないので、Form は常に最大化して表示する設定とし、通常 Form の右上にある最大化及び最小化ボタンは表示しないようにプログラムを変更しました。

また、通常の場合、最大化状態で Form のタイトルバーをクリックしてアクティブにし、そのままタイトルバーをドラッグ&ドロップすると Window 内の任意の位置へ、設計時の大きさになった Form を移動できますが、上記の理由から、この時やはりラバーバンド位置が解答欄矩形からズレます。これを防止するため、Form のタイトルバーをクリックしてドラッグ&ドロップする機能は無効化しました。

この Form の設定に使用したコードは、以下の通りです。

  private
    //最初に1回だけ設定を実行するための確認フラグ
    F_FormActivated: Boolean;

    //タイトルバーは残したまま「最大化解除できない」ように設定
    procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
    procedure WMNCLButtonDown(var Msg: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;

procedure TForm1.FormCreate(Sender: TObject);
begin

  //Formの最大化ボタン及びドラッグ&ドロップを制御(禁止)する
  F_FormActivated := False;
  //最大化して表示する
  Form1.WindowState := wsMaximized;
  //ここで実行するとFormがタスクバーを覆い隠してしまう -> FormActiveで実行する
  //BorderIcons := [biSystemMenu, biMinimize];

end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  if not F_FormActivated then
  begin
    BorderIcons := [biSystemMenu];
    F_FormActivated := True;
  end;
end;

procedure TForm1.WMNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
  if Msg.HitTest = HTCAPTION then
    Exit; // タイトルバーをドラッグしても動かせない
  inherited;
end;

procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
  // 「元に戻す」「サイズ変更」を禁止
  if (Msg.CmdType = SC_RESTORE) or (Msg.CmdType = SC_SIZE) then
  begin
    Exit;
  end;
  inherited;
end;

・・・と、ここまで修正(?)したのですが。

ちょっと待て!
おまえ、逃げてない?

・・・ みたいな声が聴こえた気がして。(。>__<。)

「このプログラムを実行する場合、画面は最大化して作業するのが最も効率がよく、何か他の画面と並べて作業する必要性もない」

それって、言い訳じゃない?

なので、上のような現実逃避的「逃げの一手」みたいな卑怯な方法を取らず、やっぱり、ここも

ちゃんとする!

ことにしました。

取りあえず、上で行った設定を全部解除して・・・

画面を最大化せずに、プログラムを実行してみます。これまで、そのようなことをしたことがなかった(してみようとも思わなかった)ので、こんな欠陥が内在していることに、やはり気づかなかったのです。画面を非最大化した状態で、このプログラムを実行されました皆々さまには、大変なご迷惑をお掛けしたことと思います。こちらにつきましても、心より、こころよりお詫び申し上げます。

1つ前のバージョンを「非最大化」して実行すると・・・(後ろは Delphi の IDE です)

ラバーバンドの描画位置がズレてしまいます・・・


そこで最大化した場合でも、非最大化した場合でも、ラバーバンドが同じ位置に描画されるようにコードを修正しました。次がその修正したつもりのコードです。

procedure TForm1.Memo2Click(Sender: TObject);
var
  i:integer;
  p1,p2:TPoint;

  function RemoveToken(var s:string;delimiter:string):string;
  var
    p:Integer;
  begin
    p:=Pos(delimiter,s);
    if p=0 then Result:=s
    else Result:=Copy(s,1,p-1);
    s:=Copy(s,Length(Result)+Length(delimiter)+1,Length(s));
  end;

  function GetTokenIndex(s:string;delimiter:string;index:Integer):string;
  var
    i:Integer;
  begin
    Result:='';
    for i:=0 to index do
      Result:=RemoveToken(s,delimiter);
  end;

begin

  if not EditTF then
  begin

    //座標を取得
    i:=Memo2.Perform(EM_LINEFROMCHAR, Memo2.SelStart, 0);

    //エラー対策
    if Memo2.Lines[i]='' then Exit;

    x1:=StrToInt(GetTokenIndex(Memo2.Lines[i],',',0));
    y1:=StrToInt(GetTokenIndex(Memo2.Lines[i],',',1));
    x2:=StrToInt(GetTokenIndex(Memo2.Lines[i],',',2));
    y2:=StrToInt(GetTokenIndex(Memo2.Lines[i],',',3));

    if Assigned(plImage1) then begin
      FreeAndNil(plImage1);
    end;

    //コンポーネントを生成し,イベントを定義し,位置を指定して画像を表示
    plImage1:= TplResizeImage.Create(Self);
    plImage1.Parent:= ScrollBox1;
    plImage1.TransEvent:= True;

    //画像内座標
    p1 := Point(x1, y1);
    p2 := Point(x2, y2);
    //クライアント座標 -> スクリーン座標(Image1基準)
    p1 := Image1.ClientToScreen(p1);
    p2 := Image1.ClientToScreen(p2);
    //スクリーン座標 -> フォームのクライアント座標(Form基準)
    p1 := Form1.ScreenToClient(p1);
    p2 := Form1.ScreenToClient(p2);
    //ラバーバンドの座標を設定(フォームのクライアント座標で配置)
    plImage1.SetBounds(p1.X, p1.Y, p2.X - p1.X, p2.Y - p1.Y);

    //SelectedプロパティをTrueにするとラバーバンドとグラブハンドルが表示される
    plImage1.Selected := True;
    plImage1.BringToFront;

  end;

end;

上記コードを実行してみた結果です。最初に画面を最大化して表示した場合・・・

解答欄矩形に対して、ラバーバンドがわずかではありますが右下へズレています。


続けて、非最大化( Window 右上の「最大化ボタン」をクリック)した場合です。最大化ボタンを押して非最大化するというのも、なんともおかしな表現ですが、再度、このボタンをクリックすれば最大化されるので、やはりこれは最大化ボタンでいいのかな?

やはり微妙にズレてはいますが、位置的には先ほどと同じところに描画されています。
なので、半歩前進というところでしょうか?
背景は Delphi の IDE です。


この微妙なズレは、なぜ生じたのでしょうか? コードを追いかけてみます。

(1)OpenCV の矩形検出機能で読み取った解答欄矩形の座標を TMemo から読み込む。
(2)座標をカンマで切り分けて変数に代入。
(3)Image1.ClientToScreen( ) で、TImage の画像内座標をスクリーン座標に変換。
(4)Form1.ScreenToClient( ) で、スクリーン座標をフォームのクライアント座標に変換。
(5)plImage1.SetBounds( )で、ラバーバンドの描画位置を指定。
(6)plImage1.Selected := True で、ラバーバンドを描画。

どこにもおかしなところはない気がします。OpenCV が正しく読み取って保存したはずの解答欄矩形の座標の数値が間違っているとは到底思えませんし・・・

何が原因かと言えば、SetBounds 関数に渡した値がズレの原因であることは間違いありません。

SetBounds 関数に渡した値がズレの原因・・・

SetBounds 関数に渡した値がズレの原因・・・

SetBounds 関数に渡した値がズレの原因・・・

では、SetBounds 関数は、何の座標系に基づいてラバーバンドを表示しているのか・・・というと、座標系をフォームのクライアント座標に変換して渡しているから、フォームのクライアント座標で描画・・・ した結果・・・ それがちょっとズレてしまう・・・

・・・ってコトは、もしかして、僕は・・・変換すべき座標系を間違えて・・・渡して・・・ る?

    //コンポーネントを生成し,イベントを定義し,位置を指定して画像を表示
    plImage1:= TplResizeImage.Create(Self);
    plImage1.Parent:= ScrollBox1;
    plImage1.TransEvent:= True;

あ”!

そうだ! 解答用紙の画像はデカいから絶対にスクロールが必要で・・・

スクロールの設定でも、いつか、さんざん悩んだけれど。

plImage1 の親は、Form1 じゃなくて・・・

ScrollBox1 ・・・

plImage1 を Image1 の上に重ねて表示したいわけだから、この場合、plImage1.Parent := Image1; とするのが最も自然・・・なんだけれど、Image1 は TGraphicControl なので、子コントロールを持てないから、plImage1 の親は Image1 の親、つまり、ScrollBox1 にしてたんだ・・・。

だから、ラバーバンド( plImage1 )は ScrollBox の座標系で描画しないといけない・・・

ここまでわかれば、もう、必要ない気がするけど、念のため、確認。

    //親を確認
    ShowMessage(plImage1.Parent.Name);

表示されたのは・・・(当たり前ですが)


これでズレた原因がはっきりしました。ScrollBox のクライアント座標でラバーバンドを描画すれば、先ほどの微妙なズレは解消されるはずです。

    p1 := Point(x1, y1);
    p2 := Point(x2, y2);
    // クライアント座標 -> スクリーン座標(Image1基準)
    p1 := Image1.ClientToScreen(p1);
    p2 := Image1.ClientToScreen(p2);
    // スクリーン座標 -> plImage1 の親(ScrollBox1)のクライアント座標に変換
    p1 := plImage1.Parent.ScreenToClient(p1);
    p2 := plImage1.Parent.ScreenToClient(p2);
    // ラバーバンド表示(親のクライアント座標系で配置)
    plImage1.SetBounds(p1.X, p1.Y, p2.X - p1.X, p2.Y - p1.Y);

コードを修正して、実行してみました。最初に、全画面表示の場合です。

ラバーバンドは、解答欄矩形の上に完全に重なって描画されました!


続いて、非全画面表示の場合です。

こちらもOK!


たったひとつ、だけ・・・ ですが、今回も、よくなれた気がします!

7.最大化から非最大化した際に画面中央にフォームを表示します!

上の6.の記事を書いている時に、もうひとつ気になることが出来てしまいました。それは何かというと、最大化状態から非最大化した際に、Form の右側が画面の外にはみ出した状態で表示されてしまうことです。

「最大化」ボタンはちらっと見えていますが、「閉じる」ボタンは完全に見えません・・・


詳しいことはわかりませんが、この表示位置は私の方で何かした覚えがありませんので、おそらく OS 側で決めているのではないか・・・と思うのですが、やはり、これは何とかしたいところです。

私は普段は「1366×768」サイズに設定したモニターを使ってプログラムを書いています。職場ではもっと高解像度のモニターを与えられていますが、もともと大きさ的に限界のあるノート PC のモニターに必要以上の解像度設定は不要だと思います。若い方ならいざ知らず、年寄りには小さな画面&高解像度のモニター環境は厳しすぎる気がします。

ちなみに、このプログラムを書くために使用している Panasonic CF-QV は「2880×1920」の解像度が「推奨」設定されています。この高解像度モニターを「1366×768」という「低」解像度に落として使う私は、何か、もったいないコトをしているのでしょうか?

Word や Excel の使用が主、つまりビジネス用途である場合、コストパフォーマンス的にも、バッテリー効率の面から見ても、文字サイズや視認性の点でも、「普通に使いやすい・無理してない」という感覚的な面からも、汎用モニターにおける最適な画面解像度はやはり「1366×768」であると私的には思えてなりませんので、あくまでも独断ですが、私はこのサイズで収まるように GUI を作成しています。

ですので、この解答欄矩形の座標を検出するプログラムも、設計時の Form の幅は・・・

「1364」ピクセル!


Windows がその気になれば、ギリ! 幅1366 ピクセルの画面内に収めて、全体が見えるように表示できるはずなのですが、現実には右側が切れて表示されてしまいます。

自分でなんとかするしか、なさそうです。

で、どうしたか、というと・・・

  private
    { Private 宣言 }

    //「最大化->元に戻す」で画面の中央に表示
    FPrevWindowState: TWindowState;  //Window の状態を取得する
    procedure AdjustFormPosition;  //Form の表示位置を設定

グローバル変数と手続きをひとつずつ宣言して、Shift + Ctrl + C で手続きを実装。

で、通常状態に戻ったときに Form を中央に表示する AdjustFormPosition 手続きは・・・

procedure TForm1.AdjustFormPosition;
var
  WorkArea: TRect;
begin
  //フォームが属しているモニタのワークエリアを取得(マルチモニタ対応)
  WorkArea := Monitor.WorkareaRect;

  //横方向の調整
  if Width < (WorkArea.Right - WorkArea.Left) then
    Left := WorkArea.Left + ((WorkArea.Right - WorkArea.Left) - Width) div 2
  else
    //はみ出す場合は左端に寄せる
    Left := WorkArea.Left;

  //縦方向の調整
  if Height < (WorkArea.Bottom - WorkArea.Top) then
    Top := WorkArea.Top + ((WorkArea.Bottom - WorkArea.Top) - Height) div 2
  else
    //はみ出す場合は上端に寄せる
    Top := WorkArea.Top;

end;

FormCreate 時に、Form の状態を取得しておきます。

procedure TForm1.FormCreate(Sender: TObject);
begin
  //「最大化->元に戻す」で画面の中央に表示
  FPrevWindowState := WindowState;

あとは、Form の OnResize イベントで、前回が最大化で、今回が通常状態なら、Form を中央に表示する処理を行うように設定。

procedure TForm1.FormResize(Sender: TObject);
var
  //for 高さの調整
  MemoHight, btnHight:integer;
begin
  //VCLの高さを調整
  ・・・ 省略 ・・・

  //「最大化->元に戻す」で画面の中央に表示
  //ユーザーが普通にフォームをドラッグして幅や高さを変えた場合を除外
  if (FPrevWindowState = wsMaximized) and (WindowState = wsNormal) then
    AdjustFormPosition;
  FPrevWindowState := WindowState;  //最新の状態を保存
end;

実行して、非最大化時の動作を確認します。

Form は、画面の中央に表示されました!


できたー☆

予定した(と言うか、気がついた)修正作業は、全部、無事完了しました!

どなた様も、お待ちになってないことと思いますが・・・

8.ダウンロードのご案内

今回、全面的に不具合を修正しました、この「解答欄矩形の座標を検出するプログラム」と、先日この Blog でご紹介した「自動採点機能みたいなモノを搭載した手書き答案の採点補助プログラム(こちらも様々に内在していた不具合を修正し、Version 3.1.0 としました)」及び「マークシートリーダー」、「採点結果通知表並びに成績一覧表作成プログラム」他を1つにまとめた zip ファイルを下記リンク先からダウンロードすることができます。

使用方法につきましては、下記リンク先の過去記事をご参照ください。

高解像度ディスプレイで、プログラムを実行される場合は、次のリンク先の記事の内容も必要に応じてご参照ください。

解答欄矩形の座標を検出するプログラムの操作方法の詳しい解説は(旧版用ですが基本的な操作方法はほとんど同じです)次のリンク先記事をご参照ください。

9.まとめ

あらためて今回の記事の内容を振り返り、これほど多くの不具合が内在していたことに気づかないまま、解答欄矩形の座標検出プログラムを掲載してしまっていたことを、心より深くお詫び申し上げます。

今回の見直しによって多くの問題点を洗い出し、修正することができましたが、もしかすると、まだ発見できていない不具合が残っている可能性も否定できません。

今後、不具合が判明した際には、速やかにこのブログ上でご報告し、修正済みのプログラムが整い次第、あらためてご案内させていただく所存です。今後とも何卒よろしくお願いいたします。

10.お願いとお断り

このサイトの内容を利用される場合は、自己責任でお願いします。記載した内容(プログラムを含む)を利用した結果、利用者および第三者に損害が発生したとしても、このサイトの管理者は一切責任を負えません。予め、ご了承ください。

高解像度画面で使いやすくするには?

元々、物理的な大きさに制約のあるノートPCなどでは、モニターの解像度が高くなればなるほど、文字は小さくなり、少なくとも私にとっては「使いやすい」とは言い難い環境になります。

高解像度画面での表示例(2880×1920)
私には、文字が小さすぎて詠めません!


この Blog の過去記事で紹介しているデジタル採点関連のアプリケーションは、横1366 × 縦 768 のディスプレイ解像度での利用を前提に開発しておりますので、高解像度環境で使用される場合には、以下の方法で GUI が適切な大きさで表示されるよう、高 DPI 設定を変更してからお使いいただけますよう、お願い申し上げます。

【もくじ】

1.高 DPI 設定の変更方法 その1(exe のプロパティを表示)
2.高 DPI 設定の変更方法 その2(高DPI設定を変更)
3.高 DPI 設定の変更方法 その3(アプリケーションを起動して確認)
4.補足( DPI 非依存の設計でも発生する問題と対応方法)
5.お願いとお断り

1.高 DPI 設定の変更方法 その1(exe のプロパティを表示)

拡張子が exe の実行形式ファイルを右クリックすると表示されるサブメニューから、プロパティを選んでクリックしてください。

プロパティをクリックします。


お使いの PC の設定によっては、ファイルの拡張子が表示されない場合もあると思います。その場合は、エクスプローラーの画面上部にある「表示」をクリックすると表示されるサブメニューのいちばん下にある「表示」をクリック( or ポイント)し、横に表示されるサブメニューの「ファイル名拡張子」をクリックしてチェックマークを付けると拡張子が表示されます。

青い枠内をクリックすると図のように「大きい縮小版を使って項目を表示」する設定になります。

2.高 DPI 設定の変更方法 その2(高DPI設定を変更)

プロパティの画面が表示されたら、上部のタブの左から2番目にある「互換性」タブをクリックし、表示された画面の「設定」グループにある「高 DPI 設定の変更」ボタンをクリックします。


「〇〇〇.exe の高 DPI 設定」というタイトルの画面が表示されたら、画面下部の「高 DPI スケール設定の上書き」グループの「高い DPI スケールの動作を上書きします。」のチェックボックスをクリックしてチェックし、さらに、その下の「拡大縮小の実行元:」のコンボボックスの選択肢から「システム」をクリックして選択してください。

最初に「チェック」を入れ、次に「選択」の順です。


画面は、次の状態になります。「OK」ボタンをクリックしてください。

「OK」をクリックして、この画面を閉じます。


元の画面が表示されますので、

「適用」ボタンをクリックしてから、
「OK」ボタンをクリックしてください。

3.高 DPI 設定の変更方法 その3(アプリケーションを起動して確認)

高 DPI 設定の変更がアプリケーションに適用されたことを、実際にアプリケーションを起動して確認してください。

高解像度画面( 2880 × 1920 )で、「高 DPI 設定の変更」を行った場合の表示例。
「高 DPI 設定の変更」を行わない場合には読めなかった文字が読めるようになりました!


解像度 1366 × 768 での表示例です。上の高解像度での表示に比べ、縦・横とも狭くなっていますが、表示内容は同じです。

AC_Reader は、解像度 1366 × 768 での使用を前提に開発&動作確認を行っています。

4.補足( DPI 非依存の設計でも発生する問題と対応方法)

この解説を書いていて、初めて気がついたのですが、Form の Scaled プロパティを False に設定し、さらに、アプリケーション全体がDPIスケーリングを無視する( DPI 非依存の設計となる)ように .dpr ファイルを開き※1、Application.Initialize の前に SetProcessDPIAware 関数呼び出し※2 を記述して、実行形式ファイル( exe )を作成した場合でも、画面表示方法の設定によっては表示の一部が読めなくなる等の問題が発生することがわかりました。

※1 Delphi IDE の「プロジェクト」メニューから「ソースの表示」を選択すると編集可能になります。
※2 uses に Winapi.Windows が必要なので追加します。

SetProcessDPIAware 関数とは?

Windowsでは、画面の解像度や物理サイズに応じて、UIを自動的に拡大・縮小する「DPIスケーリング」が行われます。
SetProcessDPIAware 関数は、Windows APIの関数で、「このアプリケーションはDPIスケーリングを自分で管理するから、OS側で勝手に拡大・縮小しないでください」と宣言するために使用します。

Delphiでアプリケーション設計時に Form の Scaled プロパティを False に設定していても(デフォルト設定はなぜか True になっているため)、OSがスケーリングを行うと、「ボタンやラベルの位置がズレる・アイコンがぼやける・マウス座標が合わない・描画が乱れる(特に Panel や Canvas)」といった問題が発生します。

SetProcessDPIAware 関数を使うことで、Windowsはスケーリングを一切行わなくなりますので、アプリケーションの描画はピクセル単位で正確に行われるようになり、Delphi側で設計した通りのサイズ・位置・座標が保たれます。

・・・と、思っていたのですが実際にはそうでもないようです(私の知識不足による間違いかもしれません)。

以下、上記の内容を加えた .dpr ファイルです。

program AC_Reader;

{$R *.dres}

uses
  {$IFDEF EurekaLog}
  {$ENDIF EurekaLog}
  Vcl.Forms,
  Unit03_JPEGConvert in 'Unit03_JPEGConvert.pas' {FormConvert},
  Vcl.Themes,
  Vcl.Styles,
  Winapi.Windows,  //SetProcessDPIAware を使うために追加
  UnitSplash in 'UnitSplash.pas' {SplashForm},
  UnitCollaboration in 'UnitCollaboration.pas' {FormCollaboration},
  UnitNoExcel in 'UnitNoExcel.pas' {frmNoExcel};

{$R *.res}

begin
  SetProcessDPIAware;  //DPIスケーリングを自分で管理する( DPI非依存の設計にする)
  Application.Initialize;
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TFormCollaboration, FormCollaboration);
  Application.Run;
end.

上の内容でコンパイルして作成したアプリケーションを、実際に高解像度画面( 2880 × 1920 )で実行して確認すると・・・(「高 DPI 設定の変更」なし・「ディスプレイの拡大縮小」は 100 % とした場合です)

TPanel 上に作成した GUI の文字が大きく表示されています。


画面全体では・・・

文字が小さすぎて、私には読めませんが「表示が乱れている」ことは、なんとなくわかります・・・


右上部分を拡大すると・・・

CheckBox のキャプションが大きく表示され、読めなくなっています。


アプリケーション設計時に Form の Scaled プロパティを False に設定し、SetProcessDPIAware 関数を dpr ファイルに記述しても、実行時の設定が「高 DPI 設定の変更」なし・ディスプレイの拡大縮小 100 %であった場合に生じるこの問題への正しい対応方法はまったくわかりません(正直に言って、この解像度で GUI を再作成するしかないのではないか?と思いました)。現在、私にある知識と技術で対応可能な限界が見えたように思います。

ただ、この記事でご紹介した上記1~3の手順で「高 DPI 設定の変更」を行って、「高い DPI スケールの動作を上書きします。」のチェックボックスをチェックし、さらに「拡大縮小の実行元:」で「システム」を設定すれば、解像度( 1366 × 768 )で設計した通りの画面が表示されるようになりました(下図)。ですので、これがこの問題への「正しい対応方法(?)」なのかもしれません。

高解像度画面( 2880 × 1920 )で、「高 DPI 設定の変更」を行った場合の表示例


画面の右側部分を拡大すると・・・

設計通りの画面表示となり、作業するのに特に支障はなさそうです。


以上の理由から、高解像度モニター( 2880 × 1920 など)を使用して、当 Blog の過去記事でご紹介したアプリケーションを実行される場合には、大変お手数をおかけし、恐縮ですが、アプリケーションを実行される前に、この記事でご紹介した「高 DPI 設定の変更」を必ず行っていただけますよう、お願い申し上げます。

5.お願いとお断り

このサイトの内容を利用される場合は、自己責任でお願いします。記載した内容(プログラムを含む)を利用した結果、利用者および第三者に損害が発生したとしても、このサイトの管理者は一切責任を負えません。予め、ご了承ください。

PDFファイルの向きを変更したい!

複合機のスキャナーで A3 縦型の原稿をスキャンすると、A3 横置きの PDF ファイルとして出力・・・ つまり、縦型原稿は「横向きに回転された状態でデータ化」されます。

A3 縦置き原稿をそのまま(横向きにしないで)スキャンできる(一般ピーポーが使用できる)複合機は、僕が知る限り、多分ないんじゃないか・・・と思います。表示した際の見た目を A3 縦置きにしたい場合は、後で回転させれば事が足りるわけで、A3 縦でも横でもスキャンできるスキャナーは、普通に考えて、その必要性が感じられません。

ただ、その「回転のひと手間」が問題となる場合を除いては・・・

この PDF ファイルを「そのまま印刷して利用する」のであれば、もちろん何も問題など生じませんが、紙媒体でなく、そのまま電子データとして、例えば、重い障害のある方が iPad の Goodnotes で読み込んで利用するような場合、正しい方向に戻す(=回転させる)ひと手間が(その方から見れば余計に)必要です。

たかが「ひと手間」ですが、この「ひと手間」が「ある」と「ない」とでは、当該 PDF ファイルを受け取った方の「気持ち」は大きく違ってくるのではないでしょうか?

しかも、それが毎回のことになると・・・

そのような観点から、手軽に PDF ファイルの向きを変換して、その状態を保存できるプログラムがないかと探してみたのですが、Web 上にデータをアップロードする必要があったり、例えその問題はクリアできても通信環境によっては、変換に「ちょっと我慢できないくらいの時間」を要したり、はたまたローカル環境 Only で作業できたとしても「単に向きを変換」するだけの工程の手順が、正直、とても使いにくいと感じてしまったり・・・、

「ただ向きを変える」それだけのことで、探し当てたどの方法を使っても、こんなにイライラするのであれば、(自分の知識と技術だけで PDF ファイルの向きを変更するプログラムなど、間違っても書けるわけがありませんので)サードパーティー製(?)ソフトウェアを使わせていただいて PDF ファイルを好きな向きに変更して保存できるプログラムを、自分で書けばいいのではないか? と思った次第です。

幸いなことに、僕の隣には Delphi がいてくれます。無料で使える Python 環境でも、この目標は実現できるともちろん感じましたが、こと GUI を用いて、誰に対しても優しいプログラムを書くなら、やっぱり Delphi です。それより、何より、エラーが出ないプログラム書くなら、絶対 Delphi です。

そんな理由から、PDF ファイルの向きの変換に特化したプログラムを書くことにしました!

【もくじ】

1.PDFtk Server
2.GUI を設計
3.ShellExecute で回転を実行
4.Path の表示方法を改良
5.CreateProcess で回転を実行
6.回転の実際
7.プログラムのダウンロード
8.お願いとお断り

1.PDFtk Server

自分の技術では PDF ファイルの内容をどうこうすることは到底できません。中身がどうなっているのかも、以前、ちょっとだけ勉強したことはあるのですが、今は全部忘れました。でも、他人様のお作りになられたとても良い Tool がたくさん公開されています。PDF ファイル操作のユーティリティは多数ありますが、あれこれダウンロードして実際に試用させていただき、今回は PDFtk Server を使わせていただくことにしました。

この PDFtk Server ですが、プラットフォームは、Windows、macOS、Linux に対応しており、PDF ファイルのマージ・分割・回転・その他、幅広い PDF 操作をコマンドラインで実行できる ユーティリティであるとのこと。

この「コマンドラインで実行」する部分を「 GUI 」から実行できるように、Delphi の力を借りて、インターフェイスを作ります。ただ、問題はライセンスです。

PDFtk Server のライセンスは、GNU GPL バージョン2 なので、非商用の個人利用であれば無償で使用可能です。ただし、GPLの下では自分のソフトウェアに PDFtk Server を同梱して、そのソフトウェアを配布する場合には、ソースコードの公開義務などが適用されますので、今回作成するソフトウェアでは PDFtk Server が動作に必要なことを明示して、利用者の責任で PDFtk Server のダウンロードをしていただき、プログラムの動作に必要な環境の整備を行ってもらう形をとりたいと思います。

2.GUI と Path の表示

Delphi の VCL を使えば、(慣れも必要ですが)ほんの数分で次のようなグラフィカル・ユーザー・インターフェイス(GUI)の作成が可能です(図は、プログラム実行時のものです)。

デフォルトでは、Form は最大化して表示されるようにしましたので、手動で幅と高さを変更しました。


操作方法は、回転させたい PDF ファイルを選択して、回転方向を選ぶ(オプションボタンをクリックする)だけです。回転を実行するボタンをクリックしなくても、回転方向を選んだだけで即回転が実行される機能を実現するチェックボックスも用意しました。

【注意】このプログラムは、ページを指定しての回転は実行することができません。

当初、回転した状態のプレビューを表示するような方向性も考えたのですが、たった3パターンの回転しかありませんし、ファイルの保存にもそれほど時間はかからない(何百ページもあるような PDF 文書はそもそも想定外で動作確認しておりませんので、それが必要な場合は利用者様各自の責任で検証作業を行っていただき、その結果に応じました運用をお願い申し上げます)ので、やや乱暴かもしれませんが、プログラムはオプションボタンをクリックするごとに回転を実行し、ファイルを固有の名称で(上書き)保存してしまう仕様としました。

責任逃れというわけではありませんが、処理が継続中であることを示すため、回転処理の手続き実行中は、マウスカーソルが待機状態になるよう try 文を入れてあります。

※ このプログラムでは、諸般の事情から try 文の中で待機状態を設定しています。

procedure TForm1.Button2Click(Sender: TObject);
begin
  //カーソルを待機状態に変更
  Screen.Cursor := crHourGlass;
  try 
    //処理を実行
    ・・・
  finally
    //カーソルを元の状態に変更
    Screen.Cursor := crDefault;
  end;
end;

オプションボタンをクリックした際の手続きは・・・

procedure TForm1.RadioGroup1Click(Sender: TObject);
begin
  Button2.Enabled:=True;
  if CheckBox1.Checked then
  begin
    Button2.Click;
  end;
end;

「回転実行」ボタン(=Button2)をクリックしたことにしてしまっています。

3.ShellExecute で回転を実行

で、最初に書いた PDF ファイルの回転手続きは・・・

  private
    { Private 宣言 }
    strSrcPDFName, strDstPDFName:string;
    PDFTK_PATH:string;
    //長いPath文字列の途中部分を省略して表示(どのコントロールでも使える汎用版に書き直したコード)
    function FitPathWithMiddleEllipsis(const FilePath: string; AFont: TFont; MaxWidth: Integer): string;

procedure TForm1.Button2Click(Sender: TObject);
var
  InputFile, OutputFile, RotateArg, strCommandLine: string;
begin

  PDFTK_PATH := ExtractFilePath(Application.ExeName)+'pdftk.exe';

  if not FileExists(PDFTK_PATH) then
  begin
    StatusBar1.SimpleText := 'pdftk.exe が見つかりません';
    Exit;
  end;

  InputFile := strSrcPDFName;
  if not FileExists(InputFile) then
  begin
    StatusBar1.SimpleText := 'PDFファイルが存在しません';
    Exit;
  end;

  case RadioGroup1.ItemIndex of
    0: RotateArg := 'west';  // 270°
    1: RotateArg := 'south'; // 180°
    2: RotateArg := 'east';  // 90°
  else
    StatusBar1.SimpleText := '回転方向を選択してください';
    Exit;
  end;

  //OutputFile := strDstPDFName;
  OutputFile := ChangeFileExt(strDstPDFName, '') + '_'+RotateArg+'.pdf';
  strDstPDFName:= OutputFile;

  //コマンド生成
  strCommandLine := Format('"%s" "%s" cat 1-end%s output "%s"', [
    PDFTK_PATH, InputFile, RotateArg, OutputFile
  ]);

  //実行(ダブルクオートでコマンド全体を囲む)
  if ShellExecute(0, 'open', 'cmd.exe', PChar('/C "' + Command + '"'), nil, SW_HIDE) <= 32 then
  begin
    StatusBar1.SimpleText := 'pdftk の実行に失敗しました';
  end else begin
    //長いPath文字列の途中を省略して表示(Create時にStatusBar1.SimplePanel:=True;あり)
    StatusBar1.SimpleText := FitPathWithMiddleEllipsis(
      OutputFile, StatusBar1.Font, StatusBar1.ClientWidth);

    //Application.ProcessMessages;
    Sleep(500); // 0.5秒待機
    //プレビューにPDFを表示(WebBrowser経由)
    WebBrowser1.Navigate('file:///' + StringReplace(OutputFile, '\', '/', [rfReplaceAll]));
  end;
end;

0.5 秒ほど待機時間を入れて、プレビューが失敗しないようにしています。なので、ちょっと処理が重たい感じにはなっちゃってますが、自分的には許容範囲かと・・・。

4.Path の表示方法を改良

この手続きの中で「長い文字列の途中を省略して表示」する FitPathWithMiddleEllipsis 関数を使っていますが、これは前回の記事でご紹介したものをさらに改良したものです。

前回の記事で使った FitPathWithMiddleEllipsis 関数は、TEdit と TLabel のみに対応したものでしたが、今回は StatusBar1 の SimpleText に Path 文字列を表示したかったので、次のように設計を変更し、汎用性を高めた新しい FitPathWithMiddleEllipsis 関数を使いました。

どのように汎用性を高めたかと言うと、つまり、やりたいことは「コントロールの表示幅に合わせた省略文字列を作る」ことだけ!なので、必要なのは「表示フォントと表示幅」です。そのため引数で指定するのは TControl ではなく、(「表示したい文字列」に加え)「Canvas.Font」と「最大幅(ピクセル)」にして、これを(関数側で用意した Canvas へ)渡すようにすれば、コントロール種別への依存をなくせます。こうすればどんな UI コントロールにもこの関数を適用できます。

前回、この関数は単一の手続き内から呼び出せる形式としましたが、今回は複数の手続きから呼び出して利用できるよう、Form のメンバーとして作成しました。

  private
    { Private 宣言 }
    ・・・
    //長いPath文字列の途中部分を省略して表示(どのコントロールでも使える汎用版」に書き直したコード)
    function FitPathWithMiddleEllipsis(const FilePath: string; AFont: TFont; MaxWidth: Integer): string;

関数を Private 部に宣言して、Shift+Ctrl+Cを押して、次の内容を記述します。

function TForm1.FitPathWithMiddleEllipsis(const FilePath: string; AFont: TFont;
  MaxWidth: Integer): string;
var
  Bitmap: TBitmap;
  Canvas: TCanvas;
  Ellipsis: string;
  DirPart, FilePart, DrivePart: string;
  Parts: TArray<string>;
  i, LeftCount, RightCount: Integer;
  TestPath: string;

  function MeasureTextWidth(const S: string): Integer;
  begin
    Result := Canvas.TextWidth(S);
  end;
begin
  Bitmap := TBitmap.Create;
  try
    Canvas := Bitmap.Canvas;
    Canvas.Font.Assign(AFont);

    Ellipsis := '...'+PathDelim;

    //全部入る場合
    if MeasureTextWidth(FilePath) <= MaxWidth then
      Exit(FilePath);

    //ファイル部分とディレクトリ部分を分離
    FilePart := ExtractFileName(FilePath);
    DirPart  := ExtractFilePath(FilePath);
    DrivePart := ExtractFileDrive(FilePath);

    //パスのディレクトリ部分を分解(ドライブ部分は除外)
    Parts := DirPart.Substring(Length(DrivePart) + 1).Split([PathDelim], TStringSplitOptions.ExcludeEmpty);

    //初期状態は全部表示
    TestPath := IncludeTrailingPathDelimiter(DirPart) + FilePart;

    //左右を削っていくアプローチ
    LeftCount := 0; //先頭から残すディレクトリ数
    RightCount := Length(Parts); //後ろから残すディレクトリ数

    while (LeftCount < Length(Parts)) and (MeasureTextWidth(TestPath) > MaxWidth) do
    begin
      Inc(LeftCount);
      TestPath := DrivePart + PathDelim;

      if LeftCount > 0 then
        TestPath := TestPath + Parts[0] + PathDelim;

      if LeftCount < Length(Parts) then
        TestPath := TestPath + Ellipsis;

      if RightCount > 0 then
      begin
        for i := Length(Parts) - RightCount to High(Parts) do
          if i >= 0 then
            TestPath := TestPath + Parts[i] + PathDelim;
      end;

      TestPath := TestPath + FilePart;
      Dec(RightCount);
      if RightCount < 0 then RightCount := 0;
    end;

    //収まる長さで返す
    Result := TestPath;

    //それでも収まらなければ中央省略だけで返す
    if MeasureTextWidth(Result) > MaxWidth then
    begin
      Result := Copy(FilePath, 1, 1) + '...' + Copy(FilePath, Length(FilePath), 1);
    end;

  finally
    Bitmap.Free;
  end;
end;

で、TEdit に表示したい場合は・・・

Edit1.Text:= FitPathWithMiddleEllipsis(strSrcPDFName, Edit1.Font, Edit1.ClientWidth);

TStatusBar に表示したい場合は・・・

StatusBar1.SimpleText := FitPathWithMiddleEllipsis(
      strDstPDFName, StatusBar1.Font, StatusBar1.ClientWidth);

ちなみに、ここで使っている TStatusBar は、次のように FormCreate 手続きで SimplePanel := True に設定しています。

procedure TForm1.FormCreate(Sender: TObject);
begin
  StatusBar1.SimplePanel := True;
  //Formを最大化して表示(幅も最大化される)
  Form1.WindowState:=wsMaximized;
end;

SimplePanel := True としていない場合は・・・(この場合の動作は未確認です!)

StatusBar1.SimpleText := 
  FitPathWithMiddleEllipsis(strDstPDFName, StatusBar1.Font, StatusBar1.Panels[0].Width);

・・・でしょうか?

さらに(今回のプログラムでは使用していませんが)TLabel に表示したい場合は・・・

Label1.Caption := FitPathWithMiddleEllipsis(strDstPDFName, Label1.Font, Label1.Width);

この関数に「表示したい文字列」と「コントロールのFont」と「コントロールの幅」を引数として渡してあげれば(余程コントロールの幅が狭くならない限り)末尾のファイル名と拡張子が見えるように Path の途中を省略する形で、長い Path 文字列を表示してくれます。

実行してみました!

長い Path が途中 … と省略され、末尾のファイル名と拡張子部分は表示されています。


コントロールが異なると、パスの区切り文字の表記が¥マークと \(バックスラッシュ)になるのは、それぞれのコントールの Font の違いによるものと思われます・・・。

5.CreateProcess で回転を実行

プログラムの設計当初、PDF ファイルの回転処理は先に記載した通り ShellExecute で実行していたのですが、プログラムの動作検証を行った際、200ページ以上ある PDF ファイルを回転元ファイルに指定したら、回転に失敗してしまいました。

ShellExecute では、何が起きて回転に失敗してしまったのかが皆目わかりませんので、原因を究明すべく、回転処理の実行( PDFtk Server の呼び出しと実行部分)を CreateProcess に変更し、エラーが発生した場合はメッセージを PDFtk Server から取得して表示できるよう、次のようにプログラムを修正しました。

  private
    { Private 宣言 }
    //PDFtkでコマンドを実行
    function RunPdftk(const ExePath, Params: string; out OutputStr: string): Boolean;

procedure TForm1.Button2Click(Sender: TObject);
var
  InputFile, OutputFile, RotateArg: string;
  Params, Msg:string;
  strMsg: string;
begin

  //カーソルを待機状態に変更
  Screen.Cursor:=crHourGlass;

  //CreateProcessで実行

  try
    PDFTK_PATH := ExtractFilePath(Application.ExeName) + 'pdftk.exe';

    if not FileExists(PDFTK_PATH) then
    begin
      StatusBar1.SimpleText := 'pdftk.exe が見つかりません';
      Exit;
    end;

    InputFile := strSrcPDFName;
    if not FileExists(InputFile) then
    begin
      StatusBar1.SimpleText := 'PDFファイルが存在しません';
      Exit;
    end;

    case RadioGroup1.ItemIndex of
      0: RotateArg := 'west';  // 270°
      1: RotateArg := 'south'; // 180°
      2: RotateArg := 'east';  // 90°
    else
      StatusBar1.SimpleText := '回転方向を選択してください';
      Exit;
    end;

    OutputFile := ChangeFileExt(strDstPDFName, '') + '_' + RotateArg + '.pdf';
    strDstPDFName := OutputFile;

    //end%sが正しい(end %sとしないこと:半角スペースは不要)
    Params := Format('"%s" cat 1-end%s output "%s"', [
      InputFile, RotateArg, OutputFile
    ]);

    if RunPdftk(PDFTK_PATH, Params, Msg) then
    begin
      StatusBar1.SimpleText := FitPathWithMiddleEllipsis(
        OutputFile, StatusBar1.Font, StatusBar1.ClientWidth);

      if Msg.Trim <> '' then
      begin
        //ShowMessage('pdftk 出力: ' + Msg);
        //コピーできるメッセージを表示する
        strMsg:= 'pdftk 出力: ' + Msg + #13#10 + #13#10 +
        '"Copied to clipboard"';
        //Clipboard.AsText := strMsg;  // クリップボードにコピー
        Clipboard.AsText := Msg;
        //ShowMonospaceMessage(strMsg);
        //ShowMessage(strMsg);
        Application.MessageBox(PChar(strMsg), PChar('エラー'), MB_ICONERROR);
      end;

      Sleep(500);
      WebBrowser1.Navigate('file:///' + StringReplace(OutputFile, '\', '/', [rfReplaceAll]));
    end
    else
    begin
      StatusBar1.SimpleText := 'pdftk の実行に失敗しました';
      if Msg.Trim <> '' then
        ShowMessage('エラー詳細: ' + Msg);
    end;
  finally
    //名前を元に戻しておく!
    strSrcPDFName := OpenDialog1.FileName;
    strDstPDFName := StringReplace(strSrcPDFName, 'SrcPDF', 'DstPDF', [rfReplaceAll, rfIgnoreCase]);
    Screen.Cursor := crDefault;
  end;

end;

function TForm1.RunPdftk(const ExePath, Params: string;
  out OutputStr: string): Boolean;
var
  SI: TStartupInfo;
  PI: TProcessInformation;
  SA: TSecurityAttributes;
  StdOutRead, StdOutWrite: THandle;
  Buffer: array[0..1023] of Byte;
  BytesRead: DWORD;
  OutputBytes: TBytes;
  CmdLine: string;
begin
  //Result := False;
  OutputStr := '';

  if not FileExists(ExePath) then
    raise Exception.CreateFmt('実行ファイルが見つかりません: %s', [ExePath]);

  ZeroMemory(@SA, SizeOf(SA));
  SA.nLength := SizeOf(SA);
  SA.bInheritHandle := True;

  if not CreatePipe(StdOutRead, StdOutWrite, @SA, 0) then
    RaiseLastOSError;
  try
    try
      SetHandleInformation(StdOutRead, HANDLE_FLAG_INHERIT, 0);

      ZeroMemory(@SI, SizeOf(SI));
      SI.cb := SizeOf(SI);
      SI.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
      SI.wShowWindow := SW_HIDE;
      SI.hStdOutput := StdOutWrite;
      SI.hStdError := StdOutWrite;

      ZeroMemory(@PI, SizeOf(PI));

      CmdLine := Format('"%s" %s', [ExePath, Params]);

      if not CreateProcess(
        nil, PChar(CmdLine), nil, nil, True,
        CREATE_NO_WINDOW, nil, nil, SI, PI) then
        RaiseLastOSError;

      CloseHandle(StdOutWrite);

      SetLength(OutputBytes, 0);
      repeat
        if not ReadFile(StdOutRead, Buffer, SizeOf(Buffer), BytesRead, nil) then
          Break;
        if BytesRead > 0 then
        begin
          //W1024 符号付型と符号無し型の演算による、オペランドの拡張」と警告される
          //SetLength(OutputBytes, Length(OutputBytes) + BytesRead);
          //対策1:BytesRead を明示的に Integer にキャストする
          SetLength(OutputBytes, Length(OutputBytes) + Integer(BytesRead));
          //対策2:Length を NativeInt にキャストする(より安全か?)
          //SetLength(OutputBytes, NativeInt(Length(OutputBytes)) + NativeInt(BytesRead));

          //W1024 符号付型と符号無し型の演算による、オペランドの拡張」と警告される
          //Move(Buffer[0], OutputBytes[Length(OutputBytes) - BytesRead], BytesRead);
          //対策1:BytesRead を明示的に Integer にキャストする
          Move(Buffer[0], OutputBytes[Length(OutputBytes) - Integer(BytesRead)], BytesRead);
        end;
      until BytesRead = 0;

      WaitForSingleObject(PI.hProcess, INFINITE);
      CloseHandle(PI.hProcess);
      CloseHandle(PI.hThread);

      if Length(OutputBytes) > 0 then
        OutputStr := TEncoding.UTF8.GetString(OutputBytes);

      Result := True;

    except
      on E: Exception do
      begin
        OutputStr := E.Message;
        Result := False;
      end;
    end;
  finally
    CloseHandle(StdOutRead);
  end;
end;

PDFtk Server の実行は、RunPdftk 関数側で行っています。

こうして CreateProcess での PDFtk Server の呼び出しに実行方法を変更し、何か問題が発生した場合には PDFtk Server 側からのエラーメッセージを取得して表示するようにできました。早速、先ほど回転に失敗した巨大な PDF ファイルを再度指定して、回転を実行してみました。

【わかったこと その①】

1つめは、問題の発生というより、正しくは、エラーの「真」の原因です。

“OWNER PASSWORD REQUIRED” と書いてあります・・・。

ぎぎぎ

( 効果音的歯軋り )

僕は、ただ、PDF を回転させようと・・・ 思っただけ・・・ なのですが、さんざん・・・ ほんとに 散々 苦労してたどり着いた 真実 は・・・

想像を遥かに絶するものでありました。

回転対象の PDF ファイルには、なんとパスワードが設定・・・ されていて当然でした。

・・・ と言うのも、もっともな理由があります。

正直に言うと、PDF ファイルを回転させるという今回のプログラムの動作検証に際し、手近に巨大な PDF ファイルが「なかった」ので、Web から簡単に入手できる 巨大 PDF ファイルはないか?と考え、思いをめぐらしたところ、すぐに思いついたのが「もう10年以上愛用しているプリンターの取扱説明書」でありました・・・ ので、さっそく愛用の 〇〇〇 社製プリンターの取扱説明書を Web から笑顔でダウンロード(何回目かなー?)して、この回転実験に使ったまではよかったのですが・・・、10年も使ったんだから許してもらえるだろうとわけのわかんないことを言い訳に、ラクしようとしたバチが当たったようです( 思いついた時は・・・ 実に!いい思いつきだと思ったのですが )。やはり、その動機が不純すぎました。

でも・・・ よく考えればこの「オーナーパスワード設定」があるのは当然です。取扱説明書、『なんでもできますー!!』みたいに勝手に書き換えられたら、それこそたいへんなコトになりますから・・・。

いやはや、これはもう・・・

手の出しようがないエラーでした!!

ま、原因がわかれば、わからないよりイイです(T_T)

ほとんど、七転八倒+四苦八苦 & いつも四面楚歌ばかり聞こえる人生(=ほぼ被害妄想)ですが、その中で学んだ最重要事項『転んでもタダでは起きるな』を、ここでもまた実践するのみです。

ぐやぐや なんじをいかんせん・・・

よくよく考えれば・・・(よくよく考えなくても・・・)

【わかったこと その②】

今回はタマタマ「手の出しようがないエラー」だったからよかった ♪ ものの、これが「手の出しようがある」エラーだった場合、OK をクリックする前に、エラーメッセージを暗記するか、「文字列」として写し取る(=メモする)必要があります。しかし、紙等に写し取るのは(自分的には)激しく面倒ですし、それより何より、このエラーメッセージはドラッグ等して、そのままクリップボードへコピーすることが、ShowMessage 関数の仕様上、出来ません!!

ちなみに、暗記はさらに無理です。

(そうだ。そのままコピペできたら・・・)

それこそ、全プログラマーの悲願です。

そう・・・

The universal wish of programmers.

それはまた・・・

The ultimate goal of all programmers.

そして、それこそは・・・

Every programmer’s long-cherished dream !

まさに、それを実現するべき時こそ、『今』です。

で、つくったのがコレ!

TMemo を Form に置いて Align := alClient としているだけですが・・・


もちろん、OK その他のボタンは、見渡すかぎり、どこにもありません。が・・・ ボタンがないかわりに・・・

好きな範囲を指定して、右クリックでコピーできます!

Delphi すごぉーイ!

( GUI が作れる全言語で、問題なく作成可能と思われますが・・・ )

OK ボタンなんて、どうせあってもただクリックするだけなんですから、その代替機能は Form 右上の「閉じる」ボタンにおまかせして、それよりエラーの原因テキストのコピペが出来れば、この際よしとしようではありませんか、皆さん!

僕は、もちろん「よし」としました☆

次が、その「エラーの原因メッセージをコピーできるようにする」コードです(表示する Form の幅と高さも自動で調整して表示するようにしてありますが、必要に応じて手動でさらに調整することも可能です)。

  private
    { Private 宣言 }
    strSrcPDFName, strDstPDFName:string;
    PDFTK_PATH:string;
    //PDFにオーナーパスワードがかかっているか調べる関数
    function IsOwnerPasswordRequired(const PdfPath, PdftkPath: string; out Output: string): Boolean;

procedure TForm1.Button1Click(Sender: TObject);
var
  OwnerPwdNeeded: Boolean;
  strMsg: string;
  strOutPut: string;

  //コピー可能なエラーメッセージを表示
  procedure ShowMonospaceMessage(const Msg: string);
  var
    Form: TForm;
    Memo: TMemo;
    CharWidth, CharHeight, MaxLineLength, LinesCount, I: Integer;
    MarginWidth, MarginHeight: Integer;
    Canvas: TCanvas;
  begin
    Form := TForm.Create(nil);
    try
      Form.Caption := 'The Real Truth Behind The Error!';
      Form.Position := poScreenCenter;

      Memo := TMemo.Create(Form);
      Memo.Parent := Form;
      Memo.Align := alClient;
      Memo.Lines.Text := Msg;
      Memo.ReadOnly := True;
      Memo.Font.Name := 'Consolas';
      Memo.Font.Size := 10;

      Form.HandleNeeded;
      Canvas := Form.Canvas;
      Canvas.Font.Assign(Memo.Font);

      CharWidth := Canvas.TextWidth('M');
      CharHeight := Canvas.TextHeight('M');

      MaxLineLength := 0;
      for I := 0 to Memo.Lines.Count - 1 do
        if Length(Memo.Lines[I]) > MaxLineLength then
          MaxLineLength := Length(Memo.Lines[I]);

      LinesCount := Memo.Lines.Count;

      //必要に応じて手動で Form の幅と高さを調整
      MarginWidth := 100;
      MarginHeight := 40;

      Form.ClientWidth := CharWidth * MaxLineLength + 10;
      Form.ClientHeight := CharHeight * LinesCount + 10;

      Form.Width := Form.ClientWidth + MarginWidth;
      Form.Height := Form.ClientHeight + MarginHeight;

      Form.ShowModal;
    finally
      Form.Free;
    end;
  end;

begin

  //ここで待機状態にしてもカーソルがすぐ元に戻ってしまう。
  //Screen.Cursor := crHourGlass;

  try
    ・・・ イロイロ設定 ・・・
    if OpenDialog1.Execute then
    begin
      ・・・ イロイロ設定 ・・・
      Screen.Cursor := crHourGlass;
      Application.ProcessMessages;
      try
        OwnerPwdNeeded := IsOwnerPasswordRequired(strSrcPDFName, PDFTK_PATH, strOutPut);
        if OwnerPwdNeeded then
        begin
          Screen.Cursor := crDefault;  // 必ず戻す
          strMsg := 'このPDFにはオーナーパスワードが設定されています。' + sLineBreak +
            strOutPut + sLineBreak +
            '処理を中止します。';
          ShowMonospaceMessage(strMsg);
          Exit;
        end;
      except
        on E: Exception do
        begin
          Screen.Cursor := crDefault;  // 必ず戻す
          strMsg := 'エラー: ' + E.Message;
          ShowMonospaceMessage(strMsg);
          Exit;
        end;
      end;
      ・・・ イロイロ設定 ・・・
    end;

  finally
    Screen.Cursor := crDefault;
  end;
end;

function TForm1.IsOwnerPasswordRequired(const PdfPath, PdftkPath: string; out Output: string): Boolean;
var
  CmdLine: string;
begin
  Result := False;

  if not FileExists(PdfPath) then
    raise Exception.Create('PDFファイルが存在しません。');

  if not FileExists(PdftkPath) then
    raise Exception.Create('pdftk.exeが見つかりません。');

  //pdftkのdump_dataコマンドでPDF情報を取得
  CmdLine := Format('"%s" "%s" dump_data', [PdftkPath, PdfPath]);

  if RunCommandAndGetOutput(CmdLine, Output) then
  begin
    //オーナーパスワードが必要ならエラーメッセージに含まれることが多い
    if Pos('OWNER PASSWORD REQUIRED', UpperCase(Output)) > 0 then
      Result := True;
  end
  else
    raise Exception.Create('pdftkの実行に失敗しました。');
end;

まぁ、イロイロありましたが、エラーメッセージだけはコピペできるようになりました☆

てか、ここでふと思ったのですが、
何もそこまでしなくても、Clipboard.AsText を使って、単に

uses
  Vcl.Clipbrd;

  strMsg := 'このPDFにはオーナーパスワードが設定されています。' + sLineBreak +
    strOutPut + sLineBreak +
    'クリップボードにエラーの内容を送信して、処理を中止します。';
  Clipboard.AsText:= strMsg;        // クリップボードにコピー
  ShowMessage(strMsg);
  Exit;

・・・としておいて、これを実行すれば、


「OK」をクリックして、メモ帳に貼り付けてみました。

この仕様の方がより親切でしょうか?

より、短く・・・

Clipboard.AsText := strOutPut;

なら・・・

エラーの核心部分のみ表示することも可能かと。


Delphi 12 Athens 以降では、 MessageDlg 関数で「警告」と「エラー」以外のアイコンが表示されなくなってしまいました。この Blog の過去記事にも書きましたが、これは Microsoft 社の UI ガイドライン変更に準拠した仕様変更によるものらしいのですが、ある日、突然、それまでずっと使い続けてきた MessageDlg 関数から「 i 」などのアイコンが消えてしまったあの時の衝撃、何か大切なものを失ったような、たまらない寂寥感が胸に広がったことを今も MessageDlg という文字を見る度に思い出します。

別に Microsoft 様の UI ガイドライン変更に反旗を翻すというような大それた意図はなく、ただメッセージにアイコンを表示したくてたまらなかった僕は必死で MessageDlg 関数の代替手段を探し、Application.MessageBox 関数がまだ生きていることを知って狂喜乱舞したのでした。・・・なので、最終的には、やっぱりいちばんのお気に入り Application.MessageBox 関数で・・・

  strMsg := 'このPDFにはオーナーパスワードが設定されています。' + sLineBreak +
    strOutPut + sLineBreak +
    'クリップボードにエラーの内容を送信して、処理を中止します。';
  Clipboard.AsText := strOutPut;
  Application.MessageBox(PChar(strMsg), PChar('エラー'), MB_ICONERROR);

だから、これが、僕の本当の理想かな?

古い人間ですので、Win32 API が好きなんです。


・・・

最終的にと言いながら、独自性にこだわって、それでもやっぱり TMemo も 「コピー」ボタンも必要なんだという場合には・・・

    { Private 宣言 }
    strMsg: string;
    procedure GetErrorMessage(Sender: TObject);

implementation

uses
  Vcl.Clipbrd;

{$R *.dfm}

procedure TForm1.Button2Click(Sender: TObject);
var
  dlg: TForm;
  btnCopy, btnClose: TButton;
  memoMsg: TMemo;
begin

  //エラーメッセージ
  strMsg := 'Error: Failed to open PDF file:' + sLineBreak +
            'C:\Users\XXX\Win32\Release\SrcPDF\TEST.PDF' + sLineBreak +
            'OWNER PASSWORD REQUIRED, but not given (or incorrect)' + sLineBreak +
            'Done.  Input errors, so no output created.';

  dlg := TForm.Create(nil);
  try
    dlg.Caption := 'メッセージ';
    dlg.Width := 400;
    dlg.Height := 240;
    dlg.Position := poScreenCenter;

    memoMsg := TMemo.Create(dlg);
    memoMsg.Parent := dlg;
    memoMsg.Left := 20;
    memoMsg.Top := 20;
    memoMsg.Width := dlg.ClientWidth - 40;
    memoMsg.Height := 120;
    memoMsg.ReadOnly := True;
    memoMsg.ScrollBars := ssVertical;
    memoMsg.Lines.Text := strMsg;

    btnCopy := TButton.Create(dlg);
    btnCopy.Parent := dlg;
    btnCopy.Caption := 'コピー';
    btnCopy.Left := 80;
    btnCopy.Top := 160;
    btnCopy.OnClick := GetErrorMessage;

    btnClose := TButton.Create(dlg);
    btnClose.Parent := dlg;
    btnClose.Caption := '閉じる';
    btnClose.Left := 200;
    btnClose.Top := 160;
    btnClose.ModalResult := mrClose;

    dlg.ShowModal;
  finally
    dlg.Free;
  end;
end;

procedure TForm1.GetErrorMessage(Sender: TObject);
begin
  Clipboard.AsText := strMsg;
end;

上のようにすれば・・・


やっぱりアイコンがないと・・・ という場合は、さらに

uses
  Vcl.Clipbrd, Vcl.ExtCtrls;

procedure TForm1.Button3Click(Sender: TObject);
var
  dlg: TForm;
  btnCopy, btnClose: TButton;
  memoMsg: TMemo;
  imgIcon: TImage;
begin
  strMsg := 'Error: Failed to open PDF file:' + sLineBreak +
            'C:\Users\XXX\Win32\Release\SrcPDF\TEST.PDF' + sLineBreak +
            'OWNER PASSWORD REQUIRED, but not given (or incorrect)' + sLineBreak +
            'Done.  Input errors, so no output created.';

  dlg := TForm.Create(nil);
  try
    dlg.Caption := 'エラー';
    dlg.Width := 420;
    dlg.Height := 260;
    dlg.Position := poScreenCenter;

    //アイコン追加
    imgIcon := TImage.Create(dlg);
    imgIcon.Parent := dlg;
    imgIcon.Left := 20;
    imgIcon.Top := 20;
    imgIcon.Width := 32;
    imgIcon.Height := 32;
    imgIcon.Picture.Icon.Handle := LoadIcon(0, IDI_ERROR); // Windows標準エラーアイコン

    //メモ表示
    memoMsg := TMemo.Create(dlg);
    memoMsg.Parent := dlg;
    memoMsg.Left := imgIcon.Left + imgIcon.Width + 10;
    memoMsg.Top := 20;
    memoMsg.Width := dlg.ClientWidth - imgIcon.Width - 50;
    memoMsg.Height := 120;
    memoMsg.ReadOnly := True;
    memoMsg.ScrollBars := ssVertical;
    memoMsg.Lines.Text := strMsg;

    //コピーボタン
    btnCopy := TButton.Create(dlg);
    btnCopy.Parent := dlg;
    btnCopy.Caption := 'コピー';
    btnCopy.Left := 80;
    btnCopy.Top := 160;
    btnCopy.OnClick := GetErrorMessage;

    //閉じるボタン
    btnClose := TButton.Create(dlg);
    btnClose.Parent := dlg;
    btnClose.Caption := '閉じる';
    btnClose.Left := 200;
    btnClose.Top := 160;
    btnClose.ModalResult := mrClose;

    dlg.ShowModal;
  finally
    dlg.Free;
  end;
end;

上のコードを実行すれば・・・


なんだか、記事の内容が本来意図した方向とずいぶん逸れてしまいました。なので、このへんで元に戻ります。

6.回転の実際

はるか上の方で、すでに示していますが、実際に PDF の回転を行った様子です。
結論から言えば、「ただ、コレがしたかった・・・ だけ」なのですが、今回もまた、なんか凄くたくさんのことに出会った気がします・・・。

最初に、左へ回転した場合です。


次に、上下反転です。


最後に、右へ回転した場合です。


連続して回転させることは、このプログラムでは考えておりません。・・・と言うか、このプログラムの仕様上、その必要性がありません。また、元の PDF ファイルは、これまたプログラムの仕様上、無加工で Src フォルダに残っていますので、「元に戻す」処理も、このプログラムには、もちろんありません。

7.プログラムのダウンロード

あくまでも自分用に作ったものですが、PDFtk Server 関連のファイルを除いたプログラム一式を以下からダウンロードできます。なお、ダウンロードとご使用にあたっては、免責事項及び使用条件への同意が必要です。免責事項及び使用条件の詳細は付属の License.txt 及び Readme.txt をご覧ください。

また、動作には PDFtk Server が必要です。

PDFtk Server のダウンロードサイト :https://www.pdflabs.com/tools/pdftk-server/

上記 Web サイトより、ダウンロードした pdftk_server-2.02-win-setup.exe をダブルクリックして起動すると、デフォルト設定では C:\Program Files (x86)\PDFtk Server にインストールが行われます。

PDFtk Server の利用にあたり、動作やライセンス内容についての詳細は、必ず公式サイトおよびライセンス文書をご確認ください。

インストール後、C:\Program Files (x86)\PDFtk Server\bin にある pdftk.exe を PDF_Rotator.exe があるPDF_Rotator フォルダ内へコピーしてください。

【プログラムが正常動作するために必要なフォルダ構成です】

PDF_Rotator\
 ├ DstPDF
 ├ SrcPDF
 ├ PDF_Rotator.exe
 ├ pdftk.exe
 ├ License.txt
 └ Readme.txt

PDF_Rotator フォルダは、下記リンク先からダウンロードできる PDF_Rotator.zip を展開すると生成されます。

回転させたい PDF ファイルは必ず SrcPDF フォルダ内に準備してください。なお、プログラムは起動時に SrcPDF フォルダ及び DstPDF フォルダの有無を調査し、それらが存在しない場合は exe と同じ階層に自動的に SrcPDF フォルダ及び DstPDF フォルダを生成します。予めご承知おきください。

PDF_Rotator.exe をダブルクリックして起動後、回転させたい PDF ファイルを選択し、回転方向を指定してください。デフォルト設定では、回転方向の指定と同時に PDF ファイルの回転と保存が行われます。回転後の PDF ファイルは、左へ回転した場合は「元のファイル名_west.pdf」、上下反転した場合は「元のファイル名_south.pdf」、右へ回転した場合は「元のファイル名_east.pdf」のように北を上とした場合の方角が付加されて DstPDF フォルダ内に保存されます。

なお、プログラムの初回起動時には、Windows Defender SmartScreen による警告画面が表示されます。この警告画面に関する詳細は、当 Blog の次の過去記事をご参照ください。

8.お願いとお断り

このサイトの内容を利用される場合は、自己責任でお願いします。記載した内容(プログラムを含む)を利用した結果、利用者および第三者に損害が発生したとしても、このサイトの管理者は一切責任を負えません。予め、ご了承ください。

また、pdftk.exe 他、PDFtk Server 関連のファイルを同梱した状態での PDF_Rotator.exe の再配布を禁じます。PDF_Rotator.exe を再配布される場合は、PDFtk Server 関連のファイルはすべて削除し、PDF_Rotator.zip に添付した License.txt 及び Readme.txt を必ず添付してください。

MTSファイルをMP4に変換したい!

仕事で SD カードに保存した MTS ファイルを扱う機会が増えました。使い終わったら不要なファイルは即消去しますが、後日再び利用するものは、わりと自由に使える NAS に MTS 形式のままコピー(=保存)していた ・・・ のですが、さすがに数が増えてくると( このままでいいのかなー )みたいな気が。

ファイルサイズが 10 GB を超えてくると、SD カードから NAS へコピーするにしても時間がかかるし、再利用する際に使うのはノート PC なので、ファイル容量に見合うほど高画質でなくても構わないはずですし、それより何より、休日、何もすることがなくてヒマ なので、MTS 形式の動画ファイルを より容量の小さい MP4 形式に変換するプログラムを書いてみることにしました。

てか、何よりも、ほんとはずっと、前から、やってみたかった・・・こと。なので・・・ *(^_^)*♪

動作には別途 FFmpeg.exe が必要です。
( FFmpeg.exe は MTStoMP4.zip に同梱しておりません)

【もくじ】

1.MTS って何?
2.MP4 に変換
3.動作確認用のコード
4.プログレスバーも表示
5.文字列の一部を省略(…)して表示
6.プログラムのダウンロード
7.まとめ
8.お願いとお断り

1.MTS って何?

まずは、ここから勉強します。

ソニー・パナソニックが共同開発した高画質動画を効率よく記録するための仕様がAVCHD(Advanced Video Codec High Definition)で、この方式で記録された動画ファイルの実体が MTS ファイルなんだそうです。

MTS は、MPEG Transport Stream の略で、主にビデオカメラで録画した高画質動画を保存するためのファイルとして利用されており、このファイルの映像部分で使用される圧縮方式(コーデック)が高画質かつ高圧縮の H.264 であるとのこと。

一言で言うと、MTS は、H.264で圧縮された動画を保存する「入れ物(ファイル形式)」のひとつで、映像の他に音声や字幕などの情報も一緒に保存されているファイルコンテナ。

ファイルコンテナと言えば思い浮かぶのは、JR の貨物列車です。

MTS や MP4 の詳しい仕組みについては、まったくわかりませんが、貨物列車に様々な色や形のコンテナが積載されているように、映像や音声を各ファイルそれぞれの方法で乗っけていることだけは理解できます。その載せ方の工夫次第で、貨物の重さや列車の長さが変わってくるということなのでしょう。

2.MP4 に変換

もちろん、わざわざ自分でプログラムなんて書かなくても、MTS ファイルを MP4 ファイルに変換する方法はいくらでもあります。有名なところでは、無料で使える「HandBrake」がありますし、さらに身近なところでは、Windows10 / 11のフォトでも変換できるようです。

僕は HandBrake は実際に使ったことがありますが、フォトでの変換は試したことがありません。

今回やってみたかったのは、これまた有名な「 FFmpeg 」(動画処理のツール)を使ったファイルコンテナの変換プログラムの作成です。前にも書きましたが、どうせヒマだし、FFmpeg は以前にもいろんなところで使ったことがあって、「期待通りに動作した記憶しかない」ので、今回もきっとうまく行く♪と思えたことと、それより何より Delphi で「なんかしてないと落ち着かない」のです(=これはきっと、僕の心の病です)。

3.動作確認用のコード

最初の一歩は、FFmpeg のダウンロードと準備。

ダウンロードサイト : https://ffmpeg.org/download.html

上記リンク先の「Get packages & executable files」にある Windows のマーク上をポイント(or クリック)すると表示される「Windows builds from gyan.dev」のリンク先ページからダウンロードすればよいのですが、いろいろな FFmpeg があって迷いました。

まず、「git master builds」と「release builds」いずれを選択すればいいのか?

今回の使用目的は、最新の機能のテストとか、そんなんじゃなくて、とにかく安定して動作するバージョンが欲しいので、「release builds」の方を選択。

で、latest release を見ると、選択肢が4つ。

・ffmpeg-release-essentials.7z
・ffmpeg-release-essentials.zip
・ffmpeg-release-full.7z
・ffmpeg-release-full-shared.7z

Essentials は、Win7 以降の OS に対応した最小限の機能のみを搭載した軽量な FFmpeg で、Full は 全機能搭載のWin10 以降用、Full Shared は、Full の DLL 版とのこと。

ここで重要になってくるのがライセンスです。

FFmpeg は、ビルド種別によりそのライセンスが異なります。最もライセンス的に無難な選択は、LGPL v2.1+ が適用される「Release Essentials Build(LGPLビルド)」だと思います。

LGPL v2.1+は、「 FFmpeg を改変せずにそのまま使い、アプリとは動的リンク( exe を呼び出す方式)で接続( = ユーザーが FFmpeg を差し替えられるように設定)し、FFmpeg のライセンス表記を Readme.txt 等に表示」すれば商用利用も可能で、クローズドソースでも OK というライセンス形態なので、今回作成したいプログラムでは、勉強を兼ね、公開に耐えうる仕様とするため「ffmpeg-release-essentials.zip」をダウンロードして、アプリケーションの exe と同じ場所にffmpeg という名前のフォルダを作成し、zip ファイルを展開した内容を一式コピペして、プログラムから FFmpeg.exe を直接呼び出して利用したいと思います。

具体的なフォルダとファイルの構成(位置関係)は、次の通りです。

MTStoMP4\
 ├ Dst
 ├ FFmpeg\bin\ffmpeg.exe
 ├ Src
 ├ Readme.txt
 └ MTStoMP4.exe

早速、次の GUI を Delphi で作成しました。

「テスト」ボタンは動作確認用(動作確認後に削除する予定)。


実際には「変換実行」ボタンをクリックするとプログレスバーを表示して変換作業の進捗状況を可視化する予定なのですが、そこに行きつく前に FFmpeg の動画変換機能を使えるようにならないといけません。なので、取り敢えず、「テスト」ボタンを準備し、そのクリックイベントの中で、コマンドプロンプトを表示して変換の動作確認を行えるようなテスト用のプログラムを書いてみます。

まず、変換元のファイルを選択する部分(ファイル選択ボタンをクリックした場合)の手続きの作成から始めました。

Form 上に TOpenDialog をひとつ準備して、次のコードを書きます。変換元の MTS 形式の動画ファイルは、exe と同じ場所に Src という名前のフォルダを作成して、そこに保存しておく前提です。また、変換先のファイルは、こちらも exe と同じ場所に Dst という名前のフォルダを作成し、そちらへ拡張子に mp4 を指定して書き出すよう、予め、変換先ファイルパスとして準備( Label のキャプションとして表示)しておきます。このように設定したのは、FFmpeg は変換先ファイルの拡張子を見て自動的に出力フォーマットを判別する仕様だからです。

procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenDialog1.Filter := '動画ファイル (*.MTS;*.mp4;*.avi;*.mkv)|*.MTS;*.mp4;*.avi;*.mkv|すべてのファイル (*.*)|*.*';
  OpenDialog1.Title := '動画ファイルを選択してください';
  OpenDialog1.InitialDir:=ExtractFilePath(Application.ExeName)+'Src';
  if OpenDialog1.Execute then
  begin
    Edit1.Text:=OpenDialog1.FileName;
    Label1.Caption:=ExtractFilePath(Application.ExeName)+
      'Dst\'+ChangeFileExt(ExtractFileName(OpenDialog1.FileName), '')+'.mp4';
  end;
end;

上記コードの動作を確認します。実行時の画面は次の通りです。

思った通りに動作しました☆
まぁ、ここはそんなに難しいところではありませんが、「幸先よし」と感じます。


ただ、ちょっと気になったのが変換元ファイルの Path 文字列が長くて TEdit からはみ出している部分です。ここは後からなんとかしたいと思います。

変換に際して指定できるパラメータは3つです。

1つめが CRF 値です。CRF は Constant Rate Factor の略で、これは動画の品質を一定に保ちつつ、ファイルサイズを自動的に調整するために設定するパラメータで、0 ~ 51 までの数値で指定します。数値が小さいほど高画質ですがファイルサイズも大きくなり、数値が大きいほど低画質になりますがファイルサイズは小さくなります。デフォルトで使用する値は 23 のようです。

2つめがプリセット指定で、これは FFmpeg の H.264( libx264 )エンコーダーで使われる「圧縮処理の速度と効率のバランス」を設定するパラメータです。エンコードの速度(=処理時間)と圧縮効率(=ファイルサイズ)のトレードオフを制御します。

ultrafast → superfast → veryfast → faster → fast → medium(デフォルト) → slow → slower → veryslow → placebo の 10 段階の設定が可能で、より右側のパラメータほど処理速度が増加し、ファイルサイズは小さくなります(逆に言えば、左側のパラメータほど処理速度が速く、ファイルサイズは大きくなります)。すべてを試すヒマはないので、取りあえず medium で動作確認することにします。

3つめが AudioBitrate で、これは1秒あたりの音声のデータ量を指定する値です。もちろん、値が大きいほど音質が良くなりますが、ファイルサイズも大きくなります。単位は kbps(キロビット毎秒)です。

で、様々な問題点をクリアしながら最終的に完成したのが次のコードです。動作状況の確認が目的なので、ShellExecute 関数の引数には /K を指定してコマンドプロンプトが自動で閉じないようにしています。また、上記3つのパラメータはわかりやすさを優先し、コード内で直接「値」を指定しています。

procedure TForm1.ButtonXClick(Sender: TObject);
var
  FFmpegPath, Command: string;
  AudioBitrate, VideoCRF: Integer;
  strPreset: string;
  InputFile, OutputFile: string;
begin
  //明示的にエスケープ('ffmpeg\bin\ffmpeg.exe' の中の \b が「バックスペース」として扱われる危険を排除)
  FFmpegPath :=
    IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName)) + 'ffmpeg\\bin\\ffmpeg.exe';

  //もしくは PathDelim を使う
  //FFmpegPath := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName))
  //            + 'ffmpeg' + PathDelim + 'bin' + PathDelim + 'ffmpeg.exe';

  //ファイルパスを安全な形式(8.3形式)で取得
  InputFile := ExtractShortPathName(Edit1.Text);
  //ExtractShortPathName関数は存在しないファイルを指定すると空文字列を返すことに注意する。
  //変換先の mp4形式の動画ファイルはプログラムの実行後に生成され、実行時には存在しない!
  OutputFile := Label1.Caption;

  //CRF(0~51)
  VideoCRF := 23;

  //プリセット(ultrafast, superfast, medium, slow, veryslow など)
  strPreset := 'slow';

  //数値の変数(単位はkbps)
  AudioBitrate := 192;

  //-ac 2 を追加して、5.1ch → 2ch ステレオ に変換して出力
  //5.1ch(サラウンド)をうまく処理できない場合があるようです。
  //この場合、変換された mp4ファイルが無音になってしまいます(ハマりました)。
  Command := Format(
    '"%s" -i "%s" -map 0:v -map 0:a -vcodec libx264 -acodec aac -ac 2 -b:a %dk -crf %d -preset %s -y "%s"',
    [FFmpegPath, InputFile, AudioBitrate, VideoCRF, strPreset, OutputFile]
  );

  //コマンドはダブルクォートで囲む(コマンド全体を1つの文字列として渡す)
  ShellExecute(0, 'open', 'cmd.exe', PChar('/K "' + Command + '"'), nil, SW_SHOWNORMAL);

end;

特に、最後の ShellExecute 関数で、Command 部分をダブルクォートで囲む処理を忘れると・・・

My PC 環境では、上のようなエラーが発生します。


原因がわかってしまえば( なぁーんだ )みたいな問題ですが、(私は)なかなか原因がわからなくて、解決までにちょっと時間を要しました。Command 部分をダブルクォートで囲むのを忘れてもコンパイルは通るので、ここはコーディング上の要注意部分です。

また、実行パスに全角文字が含まれている場合でも動作することを確認しましたが、より安定した動作を実現するためには CreateProcess を使って直接実行した方が良いはずです。なので、本番の処理では CreateProcess を使う方法をとることにします(加えて、FFmpeg の処理の進捗状況をプログレスバーに表示する処理も実装しなければいけません)。

CreateProcess を使った場合の、単なる動作確認用コードは、次の通りです。

procedure TForm1.ButtonXXClick(Sender: TObject);
var
  FFmpegPath, CmdLine, InputFile, OutputFile: string;
  AudioBitrate, VideoCRF: Integer;
  strPreset: string;
  StartInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
begin
  //明示的にエスケープ('ffmpeg\bin\ffmpeg.exe' の中の \b が「バックスペース」として扱われる危険を排除)
  FFmpegPath := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName)) + 'ffmpeg\\bin\\ffmpeg.exe';

  //入力・出力ファイル
  InputFile := ExtractShortPathName(Edit1.Text);
  OutputFile := Label1.Caption;

  if (InputFile = '') or (OutputFile = '') then
  begin
    ShowMessage('入力または出力ファイルのパスが無効です');
    Edit1.SetFocus;
    Exit;
  end;

  //エンコード設定
  VideoCRF := 23;
  strPreset := 'slow';
  AudioBitrate := 192;

  //コマンドライン
  CmdLine := Format(
    '"%s" -i "%s" -map 0:v -map 0:a -vcodec libx264 -acodec aac -ac 2 -b:a %dk -crf %d -preset %s -y "%s"',
    [FFmpegPath, InputFile, AudioBitrate, VideoCRF, strPreset, OutputFile]
  );

  ZeroMemory(@StartInfo, SizeOf(StartInfo));
  StartInfo.cb := SizeOf(StartInfo);
  StartInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartInfo.wShowWindow := SW_SHOW;  // 非表示にするなら SW_HIDE

  ZeroMemory(@ProcInfo, SizeOf(ProcInfo));

  if not CreateProcess(
    nil,               //アプリケーション名(CmdLine 内に含まれるので nil)
    PChar(CmdLine),    //コマンドライン(実行ファイルと引数を含む)
    nil, nil,          //セキュリティ属性
    False,             //ハンドル継承
    CREATE_NEW_CONSOLE,  //新しいコンソールで実行
    nil,               //環境変数
    nil,               //カレントディレクトリ
    StartInfo,         //スタートアップ情報
    ProcInfo           //プロセス情報(プロセスIDなど)
  ) then
  begin
    ShowMessage('CreateProcess に失敗しました: ' + SysErrorMessage(GetLastError));
    Exit;
  end;

  //処理の終了まで待ってから後始末&その他の処理を実行する場合は有効化する
  //ただし、有効化すると、タイトルバーに「応答なし」と表示されるなど動作が重くなる気が。
  //FFmpegに処理を渡すだけなら待機不要とした方が軽快動作?
  //WaitForSingleObject(ProcInfo.hProcess, INFINITE);

  //後始末
  CloseHandle(ProcInfo.hProcess);
  CloseHandle(ProcInfo.hThread);
end;

【ご注意願います】

もくじの「5.文字列の一部を省略(…)して表示」の処理を実行(設定)した場合は、Edit1.Text や Label1.Caption の値を参照せず、グローバル変数に保存した省略のない Path 文字列を参照するようにコードを修正する必要があります(参考コードは後述)。どうか、ご注意ください。

4.プログレスバーも表示

FFmpegは実行中に、標準出力(stdout)や標準エラー(stderr)にログを出力するので、このログを利用して処理の進捗状況(フレーム数、時間、速度など)等を取得することが可能です。

なので、Delphi で CreateProcess を利用して FFmpeg を起動する際に、標準出力・標準エラーをパイプで受け取るように設定すれば、ログをリアルタイムで取得でき、これに基づいてプログレスバーで処理の進捗状況を表示することができます。

PC に詳しい方なら次のような画面が表示され、より詳細な変換処理の進捗状況が見えた方が安心かもしれませんが、この背景が真っ黒な画面にあまり馴染みのない方にとっては、この画面よりもプログレスバーに進捗状況が表示されるという、より単純な GUI による表示の方が安心できるのではないでしょうか?(私は、本質的に難しいことが苦手なので、そのように感じてしまいます)

CreateProcess でファイルコンテナの変換を実行中
(StartInfo.wShowWindow := SW_SHOW;)


なので、動作確認後は StartupInfo.wShowWindow := SW_HIDE を指定し、コマンドプロンプト画面は非表示に設定、その代わりにプログレスバーを表示して、変換処理の進捗状況を表示します。

(変換処理の進捗状況を表示する方法は後述)

StatusBar に ProgressBar を埋め込む方法もありますが・・・
それはスペース的に余裕のない場合のお話。


今回の場合、「終了」ボタンと「変換実行」ボタンの間が空いていますので、ProgressBar はここに設置することにします。

さて、問題は進捗状況を表示する機能の実装です。

調べて見ると、FFmpeg は進行状況(Duration: …, time=…など)を 標準エラー(stderr)に出力する仕様のようでした。この進行状況の出力先が標準エラー(stderr)となっている理由は、 FFmpeg は「標準出力(stdout)」を、エンコード結果(映像などのバイナリ)をパイプ出力する用途にも使うため、ここにログを混ぜると混乱が生じる恐れがあり、ログ類は意図的にすべて stderr に分離して出力する仕様となっているとのことでした。

また、デフォルト設定のままログを出力すると多くの情報が入り混じって流れてくるので、経過時間等の取得したい情報が探しにくくなってしまいます。

そこで、出力されるログを行単位で処理し、進捗状況を表示するためのキーワードを正確に検出できるようにしました。

具体的には、FFmpeg に渡すコマンドラインの中で -progress pipe:1 を指定して意図的にログ出力が標準出力( stdout )へ為されるようにして、ここに key=value 形式で送られてくるログ出力中の「out_time=」という文字列を探して経過時間の情報を得ています。

上記内容を実装する具体的手順です。

まず、パラメータ設定を含めて FFmpeg に渡すコマンドラインを作成する部分です。

  FFmpegPath:=IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName)) + 'ffmpeg\\bin\\ffmpeg.exe';

  //CRF(0~51)
  //VideoCRF:= 23;
  VideoCRF:=StrToInt(ComboBox1.Text);

  //プリセット
  //strPreset:= 'slow';
  strPreset:= ComboBox2.Text;

  //音声の処理
  //AudioBitrate:= 192;
  AudioBitrate:= StrToInt(ComboBox3.Text);

  //-ac 2 を追加して、5.1ch → 2ch ステレオ に変換して標準出力(stdout)に出力
  //InputFile, OutputFile はこの手続きを呼び出す際に指定
  CmdLine:= Format(
    '"%s" -i "%s" -map 0:v -map 0:a -vcodec libx264 -acodec aac -ac 2 -b:a %dk -crf %d -preset %s -y -progress pipe:1 "%s"',
    [FFmpegPath, InputFile, AudioBitrate, VideoCRF, strPreset, OutputFile]
  );


動作状況を確実に確認するため、Form に TMemo を1つ追加して、この TMemo にログ出力内容を表示してみます。次は、そのテストを行った際の画像です。

実際のプログラムでは TMemo への出力は行いませんが・・・。


ここで記録されたログの最初の方に MTS ファイルの再生(録画)時間が出力されています。実際に取得したログを下に示します。Duration 部分が再生(録画)時間です。

Input #0, mpegts, from 'C:\Users\XXX\Win32\Release\Src\SampleDoga.mts':  Duration: 00:18:58.21, start: 2165.015522, bitrate: 15843 kb/s

この再生(録画)時間の出力と out_time の値を利用して、プログレスバーに進捗状況を表示します。以下、プログレスバーに進捗状況を表示する部分のコードです。

  LogBuffer := '';
  DurationInSec := 0;

  repeat
    FillChar(Buffer, SizeOf(Buffer), 0);
    if ReadFile(StdOutRead, Buffer, SizeOf(Buffer) - 1, BytesRead, nil) and (BytesRead > 0) then
    begin
      LogBuffer := LogBuffer + string(Copy(Buffer, 0, BytesRead));

      //改行で分割して処理
      Lines := LogBuffer.Split([#10, #13], TStringSplitOptions.ExcludeEmpty);
      if Length(Lines) > 0 then
      begin
        for i := 0 to High(Lines) - 1 do
        begin
          Line := Trim(Lines[i]);

          //ログ出力内容を確認
          Memo1.Lines.Add(Line);

          if (DurationInSec = 0) and (Pos('Duration:', Line) > 0) then
          begin
            TotalDurationStr := Copy(Line, Pos('Duration:', Line) + 9, 12);
            DurationInSec := TimeStringToSeconds(Trim(TotalDurationStr));
          end;

          if Pos('out_time=', Line) > 0 then
          begin
            TimeStr := Copy(Line, Pos('out_time=', Line) + 9, 11);
            CurrentTimeInSec := TimeStringToSeconds(Trim(TimeStr));

            if DurationInSec > 0 then
            begin
              ProgressBar.Position := Min(100, Round((CurrentTimeInSec / DurationInSec) * 100));
              Application.ProcessMessages;
            end;
          end;
        end;
        LogBuffer := Lines[High(Lines)];
      end;
    end;
  until WaitForSingleObject(ProcessInfo.hProcess, 10) = WAIT_OBJECT_0;


上記コード内で、「時刻文字列を秒数 に変換」する TimeStringToSeconds 関数を呼び出していますが、この関数は以下のように、別に準備しておきます。

  function TimeStringToSeconds(const TimeStr: string): Double;
  var
    h, m, s: Integer;
    secFrac: Double;
    Parts: TArray<string>;
  begin
    Result := 0;
    Parts := TimeStr.Split([':']);
    if Length(Parts) < 3 then Exit;

    h := StrToIntDef(Parts[0], 0);
    m := StrToIntDef(Parts[1], 0);
    s := Trunc(StrToFloatDef(Parts[2], 0));
    secFrac := Frac(StrToFloatDef(Parts[2], 0));

    Result := h * 3600 + m * 60 + s + secFrac;
  end;


「変換実行」ボタンをクリックした際の手続き全体のコードです。

procedure TForm1.ButtonXClick(Sender: TObject);

  function TimeStringToSeconds(const TimeStr: string): Double;
  var
    h, m, s: Integer;
    secFrac: Double;
    Parts: TArray<string>;
  begin
    Result := 0;
    Parts := TimeStr.Split([':']);
    if Length(Parts) < 3 then Exit;

    h := StrToIntDef(Parts[0], 0);
    m := StrToIntDef(Parts[1], 0);
    s := Trunc(StrToFloatDef(Parts[2], 0));
    secFrac := Frac(StrToFloatDef(Parts[2], 0));

    Result := h * 3600 + m * 60 + s + secFrac;
  end;

  procedure RunFFmpegWithProgressBar(const InputFile, OutputFile: string; ProgressBar: TProgressBar);
  var
    SecurityAttr: TSecurityAttributes;
    StdOutRead, StdOutWrite: THandle;
    StartupInfo: TStartupInfo;
    ProcessInfo: TProcessInformation;
    Buffer: array[0..1023] of AnsiChar;
    LogBuffer: string;
    Lines: TArray<string>;
    Line: string;
    BytesRead: DWORD;
    DurationInSec, CurrentTimeInSec: Double;
    CmdLine: string;
    TotalDurationStr, TimeStr: string;
    FFmpegPath: string;
    AudioBitrate, VideoCRF: Integer;
    strPreset: string;
    i: Integer;
  begin

    //初期化
    ProgressBar.Min := 0;
    ProgressBar.Max := 100;
    ProgressBar.Position := 0;

    //パイプの準備
    SecurityAttr.nLength := SizeOf(SecurityAttr);
    SecurityAttr.bInheritHandle := True;
    SecurityAttr.lpSecurityDescriptor := nil;

    if not CreatePipe(StdOutRead, StdOutWrite, @SecurityAttr, 0) then
      RaiseLastOSError;

    ZeroMemory(@StartupInfo, SizeOf(StartupInfo));
    StartupInfo.cb := SizeOf(StartupInfo);
    StartupInfo.hStdError := StdOutWrite;
    StartupInfo.hStdOutput := StdOutWrite;
    StartupInfo.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
    StartupInfo.wShowWindow := SW_HIDE;

    //Pathを設定
    FFmpegPath:=IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName)) + 'ffmpeg\\bin\\ffmpeg.exe';

    //各パラメータの設定(値は参考)

    //VideoCRF:= 23;
    VideoCRF:=StrToInt(ComboBox1.Text);

    //プリセット(例: ultrafast, superfast, medium, slow, veryslow など)
    //strPreset:= 'slow';
    strPreset:= ComboBox2.Text;

    //AudioBitrate:= 192;
    AudioBitrate:= StrToInt(ComboBox3.Text);

    //-ac 2 を追加して、5.1ch → 2ch ステレオ に変換して出力(My環境ではこうしないと無音になる!)
    CmdLine:= Format(
      '"%s" -i "%s" -map 0:v -map 0:a -vcodec libx264 -acodec aac -ac 2 -b:a %dk -crf %d -preset %s -y -progress pipe:1 "%s"',
      [FFmpegPath, InputFile, AudioBitrate, VideoCRF, strPreset, OutputFile]
    );

    if not CreateProcess(nil, PChar(CmdLine), nil, nil, True,
      CREATE_NO_WINDOW, nil, nil, StartupInfo, ProcessInfo) then
    begin
      CloseHandle(StdOutRead);
      CloseHandle(StdOutWrite);
      RaiseLastOSError;
    end;

    CloseHandle(StdOutWrite);

    LogBuffer := '';
    DurationInSec := 0;

    repeat
      FillChar(Buffer, SizeOf(Buffer), 0);
      if ReadFile(StdOutRead, Buffer, SizeOf(Buffer) - 1, BytesRead, nil) and (BytesRead > 0) then
      begin
        LogBuffer := LogBuffer + string(Copy(Buffer, 0, BytesRead));

        //改行で分割して処理
        Lines := LogBuffer.Split([#10, #13], TStringSplitOptions.ExcludeEmpty);
        if Length(Lines) > 0 then
        begin
          for i := 0 to High(Lines) - 1 do
          begin
            Line := Trim(Lines[i]);

            //ログ出力内容を確認
            //Memo1.Lines.Add(Line);

            if (DurationInSec = 0) and (Pos('Duration:', Line) > 0) then
            begin
              TotalDurationStr := Copy(Line, Pos('Duration:', Line) + 9, 12);
              DurationInSec := TimeStringToSeconds(Trim(TotalDurationStr));
            end;

            if Pos('out_time=', Line) > 0 then
            begin
              TimeStr := Copy(Line, Pos('out_time=', Line) + 9, 11);
              CurrentTimeInSec := TimeStringToSeconds(Trim(TimeStr));

              if DurationInSec > 0 then
              begin
                ProgressBar.Position := Min(100, Round((CurrentTimeInSec / DurationInSec) * 100));
                Application.ProcessMessages;
              end;
            end;
          end;
          LogBuffer := Lines[High(Lines)];
        end;
      end;
    until WaitForSingleObject(ProcessInfo.hProcess, 10) = WAIT_OBJECT_0;

    CloseHandle(StdOutRead);
    CloseHandle(ProcessInfo.hProcess);
    CloseHandle(ProcessInfo.hThread);

  end;

begin

  //変換元ファイルの指定がない場合は、処理しない
  if Edit1.Text='' then
  begin
    Edit1.SetFocus;
    Exit;
  end;

  //プログレスバーを表示
  ProgressBar1.Visible:=True;
  try
    //MTS -> MP4変換
    RunFFmpegWithProgressBar(Edit1.Text, Label1.Caption, ProgressBar1);
  finally
    //非表示にする
    ProgressBar1.Visible:=False;
  end;

end;

私の手持ち機材で録画した MTS ファイルを MP4 ファイルへ変換する作業は、・・・ 安定動作するまでに様々な紆余曲折はありましたが、最終的に上のコードで問題なく動作するようになりました。・・・が、(日々進化する)使用機材とPC環境により、録画&録音の環境は、その利用者により当然異なると思います。

例えば、私の環境では、音声は 5.1ch → 2ch として「品質を低下」させないと生成された MP4 には音声が入らないというトラブル(?)がありました。

//-ac 2 を追加して、5.1ch → 2ch ステレオ に変換して出力
CmdLine:= Format(
      '"%s" -i "%s" -map 0:v -map 0:a -vcodec libx264 -acodec aac -ac 2 ・・・

ですので、上記コードがあらゆる録画&録音設定に対応できるものでは『ない』ことに十分ご留意いただけますよう、心からお願い申し上げます。万一、上記コードを流用される場合、環境によっては、様々な不具合が生じることが予想されます。その場合は、利用者各自の責任でコードに適切な修正または改良を加えていただけますよう、お願い申し上げます。

5.文字列の一部を省略(…)して表示

【追記_20250815】

この記事で紹介している「文字列の一部を省略(…)して表示」するコードの Path 版には、さらに改良したコードがあります。

Delphiでは(他の言語についてはさらに知りませんが)、TEditやTLabelに長い文字列を表示した時、コントロールの幅より文字列の長さが長いと文字列の後半が切れて表示されてしまいます。そうならないように自動的に長い文字列の中央よりの一部を … のように省略して表示する機能はデフォルトの状態では準備されていないようです(間違っていたらすみません)。

この機能を実装してみました。設定可能なコントロールは TEdit と TLabel です。コンポーネント化する方法もあるかと思いますが、より簡単に、関数として実装しました。

最初に、非 Path 文字列用の場合です。

文字列の中央部分を省略して表示します。


次に、フォルダ名部分はなるべく残す Path 文字列専用バージョンです。

Path 文字列の先頭の方を省略して表示します。


TEdit のText や TLabel の Caption を参照したい場合に備えて、省略していない Path 文字列をグローバル変数に保存しておきます。必要な場合は Edit1.Text や Label1.Caption ではなく、グローバル変数から Path 文字列を取得して利用します。コードは次の通りです。

  private
    { Private 宣言 }
    //省略していない Path 文字列をグローバル変数に保存
    SrcFileName, DstFileName:string;

implementation

uses
  Winapi.ShellAPI,
  System.Math;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  SelectedFile: string;
  strMsg: string;

  //表示する文字列の長さの自動調整
  //非Path用
  function FitTextWithMiddleEllipsis(TargetControl: TControl; const Text: string): string;
  var
    Bitmap: TBitmap;
    Canvas: TCanvas;
    MaxWidth: Integer;
    LeftPart, RightPart: string;
    Ellipsis: string;
    i, j: Integer;
    CharWidth: Double;
    InitKeep: Integer;
  begin
    Bitmap := TBitmap.Create;
    try
      Canvas := Bitmap.Canvas;

      if TargetControl is TLabel then
        Canvas.Font := TLabel(TargetControl).Font
      else if TargetControl is TEdit then
        Canvas.Font := TEdit(TargetControl).Font
      else
        raise Exception.Create('Font にアクセスできないコントロールです。');

      MaxWidth := TargetControl.Width;
      Ellipsis := '...';

      //全部入るならそのまま返す
      if Canvas.TextWidth(Text) <= MaxWidth then
        Exit(Text);

      //1文字あたりの平均幅を計算
      if Length(Text) > 0 then
        CharWidth := Canvas.TextWidth(Text) / Length(Text)
      else
        CharWidth := Canvas.TextWidth('W');

      // 残せる文字数を幅から概算(両端合計)
      InitKeep := Trunc((MaxWidth - Canvas.TextWidth(Ellipsis)) / CharWidth);

      // 左右で半分ずつ残す
      if InitKeep < 2 then InitKeep := 2; //最低1文字ずつ残すため
      i := InitKeep div 2;
      j := Length(Text) - (InitKeep - i) + 1;

      //徐々に調整して収まる長さを探す
      while (i >= 1) and (j <= Length(Text)) do
      begin
        LeftPart := Copy(Text, 1, i);
        RightPart := Copy(Text, j, Length(Text) - j + 1);
        Result := LeftPart + Ellipsis + RightPart;

        if Canvas.TextWidth(Result) <= MaxWidth then
          Exit(Result);

        Dec(i);
        Inc(j);
      end;

      //最後の手段:1文字ずつ残す
      if Length(Text) >= 2 then
        Result := Copy(Text, 1, 1) + Ellipsis + Copy(Text, Length(Text), 1)
      else
        Result := Ellipsis;

    finally
      Bitmap.Free;
    end;
  end;

  //Path用
  function FitPathWithMiddleEllipsis(TargetControl: TControl; const FilePath: string): string;
  var
    Bitmap: TBitmap;
    Canvas: TCanvas;
    MaxWidth: Integer;
    Ellipsis: string;
    DirPart, FilePart, DrivePart: string;
    Parts: TArray<string>;
    i, LeftCount, RightCount: Integer;
    TestPath: string;

    function MeasureTextWidth(const S: string): Integer;
    begin
      Result := Canvas.TextWidth(S);
    end;

  begin
    Bitmap := TBitmap.Create;
    try
      Canvas := Bitmap.Canvas;

      if TargetControl is TLabel then
        Canvas.Font := TLabel(TargetControl).Font
      else if TargetControl is TEdit then
        Canvas.Font := TEdit(TargetControl).Font
      else
        raise Exception.Create('Font にアクセスできないコントロールです。');

      MaxWidth := TargetControl.Width;
      Ellipsis := '...\';

      //全部入る場合
      if MeasureTextWidth(FilePath) <= MaxWidth then
        Exit(FilePath);

      //ファイル部分とディレクトリ部分を分離
      FilePart := ExtractFileName(FilePath);
      DirPart  := ExtractFilePath(FilePath);
      DrivePart := ExtractFileDrive(FilePath);

      //パスのディレクトリ部分を分解(ドライブ部分は除外)
      Parts := DirPart.Substring(Length(DrivePart) + 1).Split([PathDelim], TStringSplitOptions.ExcludeEmpty);

      //初期は全部表示してみる
      TestPath := IncludeTrailingPathDelimiter(DirPart) + FilePart;

      //左右を削っていくアプローチ
      LeftCount := 0; // 先頭から残すディレクトリ数
      RightCount := Length(Parts); // 後ろから残すディレクトリ数

      while (LeftCount < Length(Parts)) and (MeasureTextWidth(TestPath) > MaxWidth) do
      begin
        //最初の方のディレクトリを省略(中央に Ellipsis)
        Inc(LeftCount);
        TestPath := DrivePart + PathDelim;

        if LeftCount > 0 then
          TestPath := TestPath + Parts[0] + PathDelim;

        if LeftCount < Length(Parts) then
          TestPath := TestPath + Ellipsis;

        if RightCount > 0 then
        begin
          for i := Length(Parts) - RightCount to High(Parts) do
            if i >= 0 then
              TestPath := TestPath + Parts[i] + PathDelim;
        end;

        TestPath := TestPath + FilePart;
        Dec(RightCount);
        if RightCount < 0 then RightCount := 0;
      end;

      //収まる長さで返す
      Result := TestPath;

      //それでも収まらなければ中央省略だけで返す
      if MeasureTextWidth(Result) > MaxWidth then
      begin
        Result := Copy(FilePath, 1, 1) + '...' + Copy(FilePath, Length(FilePath), 1);
      end;

    finally
      Bitmap.Free;
    end;
  end;

begin
  OpenDialog1.Filter := 'MTS ファイル (*.MTS)|*.MTS|すべてのファイル (*.*)|*.*';
  OpenDialog1.Title := 'MTS 形式の動画ファイルを選択してください';
  //ofFileMustExist:ファイルが存在していなければ選択できない
  //ofHideReadOnly:読み取り専用チェックボックスを非表示にする
  OpenDialog1.Options := [ofFileMustExist, ofHideReadOnly];
  OpenDialog1.InitialDir:=ExtractFilePath(Application.ExeName)+'Src';

  if OpenDialog1.Execute then
  begin
    //ShowMessage('選ばれたファイルは: ' + OpenDialog1.FileName);
    //拡張子をチェック
    SelectedFile := OpenDialog1.FileName;
    //拡張子を小文字で取得して比較
    if not SameText(ExtractFileExt(SelectedFile), '.mts') then
    begin
      strMsg:='選択されたファイルは .MTS ファイルではありません。処理を中止します。';
      Application.MessageBox(PChar(strMsg), PChar('エラー'), MB_ICONERROR);
      Edit1.Text:='';
      Button1.SetFocus;
      Exit; // 以降の処理をキャンセル
    end;

    //変数内には正しい文字列が保存されている
    SrcFileName:=OpenDialog1.FileName;
    DstFileName:=ExtractFilePath(Application.ExeName)+'Dst\'
      +ChangeFileExt(ExtractFileName(OpenDialog1.FileName), '')+'.mp4';

    //短く表示_非Path用
    //Edit1.Text:= FitTextWithMiddleEllipsis(Edit1, SrcFileName);
    //Label1.Caption:= FitTextWithMiddleEllipsis(Label1, DstFileName);

    //短く表示_Path表示用に特化
    Edit1.Text:= FitPathWithMiddleEllipsis(Edit1, SrcFileName);
    Label1.Caption:= FitPathWithMiddleEllipsis(Label1, DstFileName);

  end;
end;

6.プログラムのダウンロード

FFmpeg 関連のファイルの除いたプログラム一式を以下からダウンロードできます。なお、ダウンロードとご使用にあたっては、免責事項及び使用条件への同意が必要です。免責事項及び使用条件の詳細は付属の License.txt をご覧ください。

また、動作には FFmpeg が必要です。

FFmpeg のダウンロードサイト : https://ffmpeg.org/download.html

ダウンロードするファイルは、次のいずれかを推奨します。ご自身の環境で展開しやすい方を選択してください。

・ffmpeg-release-essentials.7z
・ffmpeg-release-essentials.zip

MTStoMP4.zip を展開(解凍)した後、以下のようなフォルダ・ファイル構成となるようにダウンロードした FFmpeg.exe を配置してください。

MTStoMP4\
 ├ Dst
 ├ FFmpeg\bin\ffmpeg.exe
 ├ Src
 ├ License.txt
 └ MTStoMP4.exe

MP4 形式に変換する MTS 形式の動画ファイルは必ず Src フォルダ内に準備してください。

なお、プログラムの初回起動時には、Windows Defender SmartScreen による警告画面が表示されます。この警告画面に関する詳細は、当 Blog の次の過去記事をご参照ください。

7.まとめ

このプログラムは変換元の MTS ファイルを選択後、オプションを指定して「変換実行」ボタンをクリックすることで動作します。複数の MTS ファイルを同時に指定して、MP4 変換することはできません。

このプログラムを用いて大きさ 2.09 GB(=2135.36 MB)の MTS 形式の動画ファイルを MP4 形式に変換してみました。なお、各パラメータですが、CRF 値は「23」、Preset は「Medium」、AudioBitRate は「128」を指定しました。生成された MP4 形式の動画の大きさは 287 MB でしたので、削減量は 1848.36MB 、削減率は 約86.6% になります。My NotePC ( Panasonic CF-QV )で生成された MP4 ファイルを視聴しましたが、自分個人の感想として、気になるレベルでの画質や音質の劣化はないように思えました(私の矯正視力は両眼とも 1.5、人間ドックでの聴力検査結果は正常範囲です)。

8.お願いとお断り

このサイトの内容を利用される場合は、自己責任でお願いします。記載した内容(プログラムを含む)を利用した結果、利用者および第三者に損害が発生したとしても、このサイトの管理者は一切責任を負えません。予め、ご了承ください。

また、FFmpeg.exe 他、FFmpeg 関連のファイルを同梱した状態での MTStoMP4.exe の再配布を禁じます。MTStoMP4.exe を再配布される場合は、FFmpeg関連のファイルはすべて削除し、MTStoMP4.zip に添付した License.txt を必ず添付してください。