{hDIBはDIBのハンドルです Comの値によって行なわれる処理は以下の通りです
 1: 'シャープ' 2: 'ソフト' 3:'平均化'
 このままではシャープはかなり強目に処理されるので、弱く処理したい場合は
 別の処理が必要です。パレットを持つ画像は処理できません。}

procedure TForm1.Filter1(Com: Byte);
type
  TByteArray = array[0..9999] of Byte;
  PByteArray = ^TByteArray;
var
  pDIB,pSub: Pointer;
  nColors,x,y,w,h,T,yy: Integer;
  nDIB,i: Longint;
  R,G,B: PByteArray;
begin
  try
    pDIB:=GlobalLock(hDIB);
    with TBitmapInfoHeader(pDIB^) do begin
      w:=((biWidth*biBitCount+31) div 32)*4;
      h:=biHeight;
      nColors:=biClrUsed;
      if biBitCount <> 24 then nColors:=LongInt(1) shl biBitCount;
      nDIB:=SizeOf(TBitmapInfoHeader)+nColors*SizeOf(TRGBQuad);
    end;
  finally
    GlobalUnLock(hDIB);
  end;
  R:=AllocMem(((h+1)*(w div 3))*SizeOf(Byte));
  G:=AllocMem(((h+1)*(w div 3))*SizeOf(Byte));
  B:=AllocMem(((h+1)*(w div 3))*SizeOf(Byte));
  try
    pDIB:=GlobalLock(hDIB);
    pDIB:=PChar(pDIB)+nDIB;
    MainForm.Enabled:=False;
    yy:=(w-1) div 3+1;
    //データの読み込み
    i:=0;
    for y:=0 to h-1 do begin
      for x:=0 to (w-1) div 3 do begin
        B^[i]:=Byte(pDIB^);
        pDIB:=PChar(pDIB)+1;
        G^[i]:=Byte(pDIB^);
        pDIB:=PChar(pDIB)+1;
        R^[i]:=Byte(pDIB^);
        pDIB:=PChar(pDIB)+1;
        inc(i);
      end;
    end;
  finally
    GlobalUnLock(hDIB);
  end;
  try
    pSub:=GlobalLock(hDIB);
    pSub:=PChar(pSub)+nDIB;
    i:=0;
    //データの計算
    for y:=0 to h-1 do
    begin
      for x:=0 to (w-1) div 3 do
      begin
        if (y = 0) or (y = h-1) or (x = 0) or (x = (w-1) div 3) then
        begin
          Byte(pSub^):=B^[i];
          pSub:=PChar(pSub)+1;
          Byte(pSub^):=G^[i];
          pSub:=PChar(pSub)+1;
          Byte(pSub^):=R^[i];
          pSub:=PChar(pSub)+1;
        end
        else begin
          case Com of
            1: begin //シャープ
              T:=-B^[i+yy]-B^[i-1]+B^[i]*5-B^[i+1]-B^[i-yy];
              if T < 0 then T:=0;
              if T > 255 then T:=255;
              Byte(pSub^):=Byte(T);
              pSub:=PChar(pSub)+1;
              T:=-G^[i+yy]-G^[i-1]+G^[i]*5-G^[i+1]-G^[i-yy];
              if T < 0 then T:=0;
              if T > 255 then T:=255;
              Byte(pSub^):=Byte(T);
              pSub:=PChar(pSub)+1;
              T:=-R^[i+yy]-R^[i-1]+R^[i]*5-R^[i+1]-R^[i-yy];
              if T < 0 then T:=0;
              if T > 255 then T:=255;
              Byte(pSub^):=Byte(T);
              pSub:=PChar(pSub)+1;
            end;
            2: begin //ソフト
              Byte(pSub^):=(B^[i+YY-1]*8+B^[i+yy]*12+B^[i+yy+1]*8+B^[i-1]*12
                           +B^[i]*20+B^[i+1]*12+B^[i-yy-1]*8+B^[i-yy]*12
                           +B^[i+yy+1]*8) div 100;
              pSub:=PChar(pSub)+1;
              Byte(pSub^):=(G^[i+YY-1]*8+G^[i+yy]*12+G^[i+yy+1]*8+G^[i-1]*12
                           +G^[i]*20+G^[i+1]*12+G^[i-yy-1]*8+G^[i-yy]*12
                           +G^[i+yy+1]*8) div 100;
              pSub:=PChar(pSub)+1;
              Byte(pSub^):=(R^[i+YY-1]*8+R^[i+yy]*12+R^[i+yy+1]*8+R^[i-1]*12
                           +R^[i]*20+R^[i+1]*12+R^[i-yy-1]*8+R^[i-yy]*12
                           +R^[i+yy+1]*8) div 100;
              pSub:=PChar(pSub)+1;
            end;
            3: begin //平均化（平滑化）
              Byte(pSub^):=(B^[i]+B^[i]+B^[i-yy]
                           +B^[i+yy]+B^[i-1]+B^[i-yy-1]+B^[i+yy-1]+B^[i+1]
                           +B^[i-yy+1]+B^[i+yy+1]) div 10;
              pSub:=PChar(pSub)+1;
              Byte(pSub^):=(G^[i]+G^[i]+G^[i-yy]+G^[i+yy]+G^[i-1]+G^[i-yy-1]
                           +G^[i+yy-1]+G^[i+1]+G^[i-yy+1]+G^[i+yy+1]) div 10;
              pSub:=PChar(pSub)+1;
              Byte(pSub^):=(R^[i]+R^[i]+R^[i-yy]+R^[i+yy]+R^[i-1]+R^[i-yy-1]
                           +R^[i+yy-1]+R^[i+1]+R^[i-yy+1]+R^[i+yy+1]) div 10;
              pSub:=PChar(pSub)+1;
            end;
          end;
        end;
        inc(i);
      end;
    end;
  finally
    GlobalUnLock(hDIB);
  end;
  FreeMem(R,((h+1)*(w div 3))*SizeOf(Byte));
  FreeMem(G,((h+1)*(w div 3))*SizeOf(Byte));
  FreeMem(B,((h+1)*(w div 3))*SizeOf(Byte));
end;

  奇珍館<http://www.kh.rim.or.jp/~yun/> 12月６日 更新！
  画像処理ﾌﾘｰｿﾌﾄ GAZE Ver1.60[奇珍館にて公開中] JCC01421 ＹＵＮ

Original document by ＹＵＮ          氏 ID:(JCC01421)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。