mwhighlighter.pas

来自「本人买的<<VC++项目开发实例>>源代码配套光盘.」· PAS 代码 · 共 643 行 · 第 1/2 页

                if bgDefault = '1'
                  then Background := clWindow
                  else Background := Pal16[StrToInt(bgIndex16)];
                if fgDefault = '1'
                  then Foreground := clWindowText
                  else Foreground := Pal16[StrToInt(fgIndex16)];
                Style := [];
                if Pos('B',fontStyle) > 0 then Style := Style + [fsBold];
                if Pos('I',fontStyle) > 0 then Style := Style + [fsItalic];
                if Pos('U',fontStyle) > 0 then Style := Style + [fsUnderline];
                Result := true;
              end;
            finally CloseKey; end;
          end; // if
        end; // with
      finally reg.Free; end;
    except end;
  end; { LoadOldStyle }

  function LoadNewStyle(rootKey: HKEY; attrKey, attrName: string): boolean;
  var
    fgIndex16    : DWORD;
    bgIndex16    : DWORD;
    fontBold     : string;
    fontItalic   : string;
    fontUnderline: string;
    fgDefault    : string;
    bgDefault    : string;
    reg          : TBetterRegistry;

    function IsTrue(value: string): boolean;
    begin
      Result := not ((UpperCase(value) = 'FALSE') or (value = '0')); 
    end; { IsTrue }

  begin
    Result := false;
    try
      reg := TBetterRegistry.Create;
      reg.RootKey := rootKey;
      try
        with reg do begin
          if OpenKeyReadOnly(attrKey+'\'+attrName) then begin
            try
              if ValueExists('Foreground Color')
                then fgIndex16 := ReadInteger('Foreground Color')
                else Exit;
              if ValueExists('Background Color')
                then bgIndex16 := ReadInteger('Background Color')
                else Exit;
              if ValueExists('Bold')
                then fontBold := ReadString('Bold')
                else Exit;
              if ValueExists('Italic')
                then fontItalic := ReadString('Italic')
                else Exit;
              if ValueExists('Underline')
                then fontUnderline := ReadString('Underline')
                else Exit;
              if ValueExists('Default Foreground')
                then fgDefault := ReadString('Default Foreground')
                else Exit;
              if ValueExists('Default Background')
                then bgDefault := ReadString('Default Background')
                else Exit;
              if IsTrue(bgDefault)
                then Background := clWindow
                else Background := Pal16[bgIndex16];
              if IsTrue(fgDefault)
                then Foreground := clWindowText
                else Foreground := Pal16[fgIndex16];
              Style := [];
              if IsTrue(fontBold) then Style := Style + [fsBold];
              if IsTrue(fontItalic) then Style := Style + [fsItalic];
              if IsTrue(fontUnderline) then Style := Style + [fsUnderline];
              Result := true;
            finally CloseKey; end;
          end; // if
        end; // with
      finally reg.Free; end;
    except end;
  end; { LoadNewStyle }

begin
  if oldStyle then Result := LoadOldStyle(rootKey, attrKey, attrName)
              else Result := LoadNewStyle(rootKey, attrKey, attrName);
end; { TmwHighLightAttributes.LoadFromBorlandRegistry }

procedure TmwHighLightAttributes.SetBackground(Value: TColor);
begin
  if fBackGround <> Value then
    begin
      fBackGround := Value;
      if Assigned(fOnChange) then
        fOnChange(Self);
    end;
end;

procedure TmwHighLightAttributes.SetForeground(Value: TColor);
begin 
  if fForeGround <> Value then
    begin
      fForeGround := Value;
      if Assigned(fOnChange) then
        fOnChange(Self);
    end;
end;

procedure TmwHighLightAttributes.SetStyle(Value: TFontStyles);
begin 
  if fStyle <> Value then
    begin
      fStyle := Value;
      if Assigned(fOnChange) then
        fOnChange(Self);
    end;
end;

function TmwHighLightAttributes.LoadFromRegistry(Reg: TBetterRegistry): boolean;
var
  key: string;
begin
  key := Reg.CurrentPath;
  if Reg.OpenKeyReadOnly(Name) then begin
    if Reg.ValueExists('Background') then Background := Reg.ReadInteger('Background');
    if Reg.ValueExists('Foreground') then Foreground := Reg.ReadInteger('Foreground');
    if Reg.ValueExists('Style') then IntegerStyle := Reg.ReadInteger('Style');
    reg.OpenKeyReadOnly('\'+key);
    Result := true;
  end
  else Result := false;
end;

function TmwHighLightAttributes.SaveToRegistry(Reg: TBetterRegistry): boolean;
var
  key: string;
begin
  key := Reg.CurrentPath;
  if Reg.OpenKey(Name,true) then begin
    Reg.WriteInteger('Background', Background);
    Reg.WriteInteger('Foreground', Foreground);
    Reg.WriteInteger('Style', IntegerStyle);
    reg.OpenKey('\'+key,false);
    Result := true;
  end
  else Result := false;
end;

function TmwHighLightAttributes.GetStyleFromInt: integer;
begin
  if fsBold in Style then Result:= 1 else Result:= 0;
  if fsItalic in Style then Result:= Result+2;
  if fsUnderline in Style then Result:= Result+4;
  if fsStrikeout in Style then Result:= Result+8;
end;

procedure TmwHighLightAttributes.SetStyleFromInt(const Value: integer);
begin
  if Value and $1 = 0 then  Style:= [] else Style:= [fsBold];
  if Value and $2 <> 0 then Style:= Style+[fsItalic];
  if Value and $4 <> 0 then Style:= Style+[fsUnderline];
  if Value and $8 <> 0 then Style:= Style+[fsStrikeout];
end;

{ TmwCustomHighLighter }

constructor TmwCustomHighLighter.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  fAttributes := TStringList.Create;
  fAttributes.Duplicates := dupIgnore;
  fAttributes.Sorted := TRUE;

  fAttrChangeHooks := TmwNotifyEventChain.CreateEx(Self);
  fDefaultFilter := '';
end;

destructor TmwCustomHighLighter.Destroy;
var i: integer;
begin

  for i := fAttributes.Count - 1 downto 0 do begin
    if (fAttributes.Objects[i] = nil) then continue;
    TmwHighLightAttributes(fAttributes.Objects[i]).Free;
  end;
  fAttributes.Free;

  fAttrChangeHooks.Free;
  inherited Destroy;
end;

procedure TmwCustomHighLighter.EnumUserSettings(settings: TStrings);
begin
  settings.Clear;
end;

function TmwCustomHighLighter.UseUserSettings(
  settingIndex: integer): boolean;
begin
  Result := false;
end;

function TmwCustomHighLighter.GetIdentChars: TIdentChars;
begin
  Result := [#33..#255];
end;

procedure TmwCustomHighLighter.NextToEol;
begin
  while not GetEol do Next;
end;

procedure TmwCustomHighLighter.ScanAllLineTokens(const Value: string;
                                                 LineNumber: integer);
var sToken: string;
begin
  SetLine(Value, LineNumber);
  while not GetEOL do begin
    if Assigned(fOnToken) then begin
      sToken := GetToken;
      if (Length(sToken) > 0) then
        OnToken(Self, GetTokenKind, sToken, LineNumber);
    end;
    Next;
  end;
end;

function TmwCustomHighLighter.LoadFromRegistry(RootKey: HKEY; Key: string): boolean;
var
  r: TBetterRegistry;
  i: integer;
begin
  r := TBetterRegistry.Create;
  try
    r.RootKey := RootKey;
    if r.OpenKeyReadOnly(Key) then begin
      Result := true;
      for i := 0 to AttrCount-1 do
        Result := Result and Attribute[i].LoadFromRegistry(r);
    end
    else Result := false;
  finally r.Free; end;
end;

function TmwCustomHighLighter.SaveToRegistry(RootKey: HKEY; Key: string): boolean;
var
  r: TBetterRegistry;
  i: integer;
begin
  r := TBetterRegistry.Create;
  try
    r.RootKey := RootKey;
    if r.OpenKey(Key,true) then begin
      Result := true;
      for i := 0 to AttrCount-1 do
        Result := Result and Attribute[i].SaveToRegistry(r);
    end
    else Result := false;
  finally r.Free; end;
end;

procedure TmwCustomHighLighter.AddAttribute(AAttrib: TmwHighLightAttributes);
begin
  fAttributes.AddObject(AAttrib.Name, AAttrib);
end;

procedure TmwCustomHighLighter.DefHighlightChange(Sender: TObject);
begin
  fAttrChangeHooks.Fire;
end;

function TmwCustomHighLighter.GetAttribCount: integer;
begin
  Result := fAttributes.Count;
end;

function TmwCustomHighLighter.GetAttribute(idx: integer): TmwHighLightAttributes;
begin
  Result := nil;
  if (idx >= 0) and (idx < fAttributes.Count) then
    Result := TmwHighLightAttributes(fAttributes.Objects[idx]);
end;

procedure TmwCustomHighLighter.SetAttributesOnChange(AEvent: TNotifyEvent);
var i: integer;
    attri: TmwHighLightAttributes;
begin
  for i := fAttributes.Count - 1 downto 0 do begin
    attri := TmwHighLightAttributes(fAttributes.Objects[i]);
    if Assigned(attri) then attri.OnChange := AEvent;
  end;
end;

function TmwCustomHighLighter.GetCapability: THighlighterCapability;
begin
  Result := [hcRegistry]; //registry save/load supported by default
end;

function TmwCustomHighLighter.GetDefaultFilter: string;
begin
  Result := fDefaultFilter;
end;

procedure TmwCustomHighLighter.SetDefaultFilter(Value: string);
begin
  if fDefaultFilter <> Value then fDefaultFilter := Value;
end;

procedure TmwCustomHighLighter.HookAttrChangeEvent(ANotifyEvent: TNotifyEvent);
begin
  fAttrChangeHooks.Add(ANotifyEvent);
end;

procedure TmwCustomHighLighter.UnhookAttrChangeEvent(ANotifyEvent: TNotifyEvent);
begin
  fAttrChangeHooks.Remove(ANotifyEvent);
end;

end.