unit uSysCol;
{
}
interface
uses Windows, SysUtils
  , CalcAnsiScript
  , uAnsiCharTools
  ;


{(*} //以下が設定　h:の先頭文字が!なら色反転対象でない
type   TColNmTbl = record c: integer;n, h: Ansistring; end;
const ColorNameM = 20;
const ColNmTbls: array [0..ColorNameM] of TColNmTbl =
  {00}((c: COLOR_WINDOW{                }; n: 'COLOR_WINDOW'{               }; h: ' 5ウィンドウの背景 関連付けられている前景色はCOLOR_WINDOWTEXTされ、COLOR_HOTLITE')
  {01}, (c: COLOR_WINDOWTEXT{           }; n: 'COLOR_WINDOWTEXT'{           }; h: ' 8ウィンドウ内のテキスト 関連付けられている背景色がCOLOR_WINDOW')
  {02}, (c: COLOR_HIGHLIGHT{            }; n: 'COLOR_HIGHLIGHT'{            }; h: '13コントロールで選択されている項目 関連付けられている前景色がCOLOR_HIGHLIGHTTEXT')
  {03}, (c: COLOR_HIGHLIGHTTEXT{        }; n: 'COLOR_HIGHLIGHTTEXT'{        }; h: '14コントロールで選択されている項目のテキスト 関連付けられている背景色がCOLOR_HIGHLIGHT')
  {04}, (c: COLOR_3DFACE{               }; n: 'COLOR_3DFACE'{               }; h: '153 Dとダイアログ ボックスの背景の面の色')
  {05}, (c: COLOR_GRAYTEXT{             }; n: 'COLOR_GRAYTEXT'{             }; h: '17灰色:無効のテキスト 現在のディスプレイ ドライバーが単色の灰色をサポートしていない場合、この色は 0 に設定')
  {06}, (c: COLOR_BTNTEXT{              }; n: 'COLOR_BTNTEXT'{              }; h: '18プッシュ ボタン上のテキスト 関連付けられている背景色がCOLOR_BTNFACE')
  {07}, (c: COLOR_HOTLIGHT{             }; n: 'COLOR_HOTLIGHT'{             }; h: '26ハイパーリンクまたはホット トラックアイテムの色 関連付けられている背景色がCOLOR_WINDOW')
  {08}, (c: COLOR_CAPTIONTEXT{          }; n: 'COLOR_CAPTIONTEXT'{          }; h: ' 9キャプション、サイズ ボックス、スクロール バーの矢印ボックス内のテキスト 関連付けられている背景色がCOLOR_ACTIVECAPTION')
  {09}, (c: COLOR_ACTIVEBORDER{         }; n: 'COLOR_ACTIVEBORDER'{         }; h: '!10    アクティブなウィンドウの境界線')
  {10}, (c: COLOR_INACTIVEBORDER{       }; n: 'COLOR_INACTIVEBORDER'{       }; h: '!11    非アクティブなウィンドウの境界線')
  {11}, (c: COLOR_APPWORKSPACE{         }; n: 'COLOR_APPWORKSPACE'{         }; h: '!12    複数のドキュメント インターフェイスMDI) アプリケーションの背景色')
  {12}, (c: COLOR_BTNFACE{              }; n: 'COLOR_BTNFACE'{              }; h: '!15  ')
  {13}, (c: COLOR_INACTIVECAPTIONTEXT{  }; n: 'COLOR_INACTIVECAPTIONTEXT'{  }; h: '!19    非アクティブなキャプションのテキストの色 関連付けられている背景色がCOLOR_INACTIVECAPTION')
  {14}, (c: COLOR_INFOTEXT{             }; n: 'COLOR_INFOTEXT'{             }; h: '!23    ヒント コントロールのテキストの色 関連付けられている背景色がCOLOR_INFOBK')
  {15}, (c: COLOR_INFOBK{               }; n: 'COLOR_INFOBK'{               }; h: '!24    ヒント コントロールの背景色 関連付けられている前景色がCOLOR_INFOTEXT')
  {16}, (c: COLOR_3DSHADOW{             }; n: 'COLOR_3DSHADOW'{             }; h: '!16    3Dの影の色 光源から離れたエッジの場合')
  {17}, (c: COLOR_3DHILIGHT{            }; n: 'COLOR_3DHILIGHT'{            }; h: '!20    3Dの強調表示の色 光源に面するエッジの場合')
  {18}, (c: COLOR_3DDKSHADOW{           }; n: 'COLOR_3DDKSHADOW'{           }; h: '!21    3Dの濃い影')
  {19}, (c: COLOR_3DLIGHT{              }; n: 'COLOR_3DLIGHT'{              }; h: '!22    3Dの明るい色 光源に面するエッジの場合')
  {20}, (c: COLOR_DESKTOP{              }; n: 'COLOR_DESKTOP'{              }; h: '! 1 デスクトップ')
  {21});
const ColTbls: array [0..21] of record c: integer;n: Ansistring; end  =
  {00}((c:$000000;n:'clBlack')
  {01},(c:$000080;n:'clMaroon')
  {02},(c:$008000;n:'clGreen')
  {03},(c:$008080;n:'clOlive')
  {04},(c:$800000;n:'clNavy')
  {05},(c:$800080;n:'clPurple')
  {06},(c:$808000;n:'clTeal')
  {07},(c:$808080;n:'clGray')
  {08},(c:$C0C0C0;n:'clSilver')
  {09},(c:$0000FF;n:'clRed')
  {10},(c:$00FF00;n:'clLime')
  {11},(c:$00FFFF;n:'clYellow')
  {12},(c:$FF0000;n:'clBlue')
  {13},(c:$FF00FF;n:'clFuchsia')
  {14},(c:$FFFF00;n:'clAqua')
  {15},(c:$C0C0C0;n:'clLtGray')//clSilveralias
  {16},(c:$808080;n:'clDkGray')//clGrayalias
  {17},(c:$FFFFFF;n:'clWhite')
  {18},(c:$C0DCC0;n:'clMoneyGreen')
  {19},(c:$F0CAA6;n:'clSkyBlue')
  {20},(c:$F0FBFF;n:'clCream')
  {21},(c:$A4A0A0;n:'clMedGray')
  );
  {*)}
type
{
TAnsiCalculateにシステムカラーの入出力を追加する
#scol という行コマンドを追加する
    # scolのみなら　現在の設定値が読まれ
    # scol name で SysColorにname.scolを設定する
    # scol + name で name.scolに現在の設定値を書き出す
    # scol - name で name.scolを削除する
    COLOR_xxxに代入した時は実際の変更はスクリプト終了時に一括して行う（毎回するとちらつきが大きい為）
    また、小数点以下は代入により丸められている
    }
    TuSysColor = class(TCalcuAddition)
    ColBuf
      , ColNo: array[0..ColorNameM] of DWORD;
    ColBufSz: integer;
  public
 //  function CallFunc(const lab: AnsiString; Labels: TAMyCalLabel): boolean ;override;
    function ExeLabel(const lab: AnsiString; var ret: Extended; cmd: TGetLabelCmd): boolean; override;
    procedure StartEndScript(n: Integer); override; //0:start 1:end;
    function LineCmd(const lab: AnsiString; var p: PChar): boolean; override; //#で始まる行コマンド
  end;


function readFileStr(fname: ansistring): ansistring;
implementation

function Color2Str(c: longint): string;
var
  i: integer;
begin
    //  if ColorToIdent(c, Result) then exit;
  for i := Low(ColTbls) to High(ColTbls) do
    if c = ColTbls[i].c then
    begin
      Result := ColTbls[i].n;
      exit;
    end;
  Result := format('$%6.6X', [c]);
end;

function ColorCode(s: ansistring): longint;
var
  i, OX: integer;
begin
  OX := 0;
  if s[1] in ['~', '!'] then
  begin
    OX := $FFFFFF;
    Delete(s, 1, 1);
    s := Trim(s);
  end;
  for i := Low(ColTbls) to High(ColTbls) do
    if SameText(s, ColTbls[i].n) then
    begin
      Result := ColTbls[i].c xor OX;
      exit;
    end;
  if s[1] in ['$', '0'..'9'] then
  begin
    Result := StrToInt(s) xor OX;
    exit;
  end;
  raise Exception.Create(s + ':名前がない');
end;


{ TuSysColor }



function TuSysColor.ExeLabel(const lab: AnsiString; var ret: Extended; cmd: TGetLabelCmd): boolean;
var
  i, j: integer;
begin
  Result := True;
  for i := Low(ColTbls) to High(ColTbls) do
    if SameText(lab, ColTbls[i].n) then
    begin
      if cmd = glGetData then begin
        ret := ColTbls[i].c;
        exit;
      end;
      owner.Err(lab + ':const');
    end;

  for i := Low(ColNmTbls) to High(ColNmTbls) do
    if SameText(lab, ColNmTbls[i].n) then
      case cmd of
        glSetData: begin
            for j := 0 to ColBufSz - 1 do
              if ColNo[j] = ColNmTbls[i].c then begin
                ColBuf[j] := round(ret);
                exit;
              end;
            ColNo[ColBufSz] := ColNmTbls[i].c;
            ColBuf[ColBufSz] := round(ret); ;
            Inc(ColBufSz);
            exit;
          end;
        glGetData: begin //既に代入していたら
            for j := 0 to ColBufSz - 1 do
              if ColNo[j] = ColNmTbls[i].c then begin
                ret := ColBuf[j];
                exit;
              end;
            ret := GetSysColor(ColNmTbls[i].c);
            exit;
          end;
        glPrePP: begin
            owner.Err('++/-- ng ' + lab);
            exit;
          end;
      end;
  Result := False;
  exit;
end;

//LazarusのDelphi変換でGetFileSizeを無条件にFileSizeに変換するバグの回避

function ExtGetFileSize(hFile: THandle; lpFileSizeHigh: Pointer): DWORD; stdcall; external kernel32 name 'GetFileSize';

function readFileStr(fname: ansistring): ansistring;
var
  hin: THandle;
  rsize: DWORD;
begin
  Result := '';
  rsize := 0;
  hin := CreateFile(pansichar(fname), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL, 0);
  if hin <> INVALID_HANDLE_VALUE then try

    SetLength(Result, ExtGetFileSize(hin, nil));
    windows.ReadFile(hin, pansichar(Result)^, Length(Result), rsize, nil);
  finally CloseHandle(hin);
  end;
end;

procedure writeFileStr(fname, s: ansistring);
var
  hin: THandle;
  rsize: DWORD;
begin
  rsize := 0;
  hin := CreateFile(pansichar(fname), GENERIC_WRITE, FILE_SHARE_WRITE, nil, CREATE_ALWAYS,
    FILE_ATTRIBUTE_NORMAL, 0);
  if hin <> INVALID_HANDLE_VALUE then try
    windows.Writefile(hin, pansichar(s)^, Length(s), rsize, nil);
  finally CloseHandle(hin);
  end;
end;




function getWin32Find(const fname: ansistring): TWin32FindData;
var
  h: THandle;
begin
  h := FindFirstFile(pansichar(fname), Result);
  if h = INVALID_HANDLE_VALUE then
  begin
    Result.cFileName[0] := #0;
  end
  else Windows.FindClose(h);
end;

function SysColorTxt(): ansistring;
var
  s: ansistring;
  i, c, sz: integer;
begin
  Result := '';
  for i := LOw(ColNmTbls) to High(ColNmTbls) do
  begin
    c := GetSysColor(ColNmTbls[i].c);
    s := ColNmTbls[i].n;
    sz := length(s);
    while sz < 24 do
    begin s := s + ' '; Inc(sz); end;
    s := s + '=' + Color2Str(c);
    sz := length(s);
    while sz < 40 do
    begin s := s + ' '; Inc(sz); end;
    s := addS([s + '//', cvU(ColNmTbls[i].h)]);
    if i <> High(ColNmTbls) then s := addS([s, #13#10]); //CR+LFを追加する
    Result := addS([Result, s]);
  end;
end;


//初期化

function TuSysColor.LineCmd(const lab: AnsiString; var p: PChar): boolean;
var
  c, fname, s: string;
begin
  Result := False;
  if SameText(lab, 'h') or (lab = '') then //helpの時は処理してもfalseを返す
  begin
    owner.MsgOutLn(cvU(
      '#scolのみなら　現在の設定値が読まれ'#13#10 +
      '#scol name で  SysColorにname.scol.txtを設定する'#13#10 +
      '#scol +name で nameに現在の設定値を書き出す'#13#10 +
      '#scol -name で nameを削除する'));

  end;
  if not SameText(lab, 'scol') then exit;
  Result := True;
  c := '';
  if p^ in ['+', '-'] then begin c := p^; inc(p); end;
  CAnsiSkipBlank(p); //空白は開けてもよい
  fname := CAnsiGetAccordZenChars(p, ['@'..'Z', 'a'..'z', '0'..'9']); //ファイル名は全角が英数字に限定(数字のファイルも作れる)
  CAnsiSkipBlank(p);
  if not (p^ in ['#', #0, #13, #10]) then owner.Err('#' + lab + ' ' + fname + '??'); //コメントか改行で終わっていない
//#scol のみの場合はsysColorを読み出す
  if (c = '') and (fname = '') then begin
    s := SysColorTxt();
    owner.MsgOutLn(s);
    exit;
  end;
  if fname = '' then owner.Err('#' + lab + '?');
// #scol 1
  s := ExtractFilePath(ParamStr(0)) { +'scol\'};
//   CreateDir(s);
  fname := s + fname + '.scol.txt'; //exeと同じフォルダだけを指定する
//#scol name で name.scolでSysColorに設定する
  if (c = '') then begin
    s := readFileStr(fname);
    if s = '' then owner.Err('#' + lab + '?')
    else begin
      owner.formulaLine(s); //代入でない状態で終わってる場合は無視
      if ColBufSz > 0 then SetSysColors(ColBufsz, ColNo, ColBuf);
      ColBufSz := 0;
    end;
  end;
  //#scol +name で name.scolに現在の設定値を書き出す
  if c = '+' then writeFileStr(fname, SysColorTxt());

//#scol -name で name.scolを削除する
  if c = '-' then
    if FileExists(fname) then DeleteFile(fname);
end;


procedure TuSysColor.StartEndScript(n: Integer);
begin
  case n of
    0: ColBufSz := 0;
    1: begin
        if ColBufSz > 0 then
          SetSysColors(ColBufsz, ColNo, ColBuf);
        ColBufSz := 0;
      end;
  end;
end;
initialization
  CalcAddTCalcuAddition(TuSysColor);
end.