jvmrulist.pas

East make Tray Icon in delphi

    Exit;
  P := nil;

  if FType = dtString then
  begin
    if not UseUnicode then
    begin
      ReAllocMem(P, 256);
      I := EnumMruList(FList, Index, P, 256);
      if I > 255 then
      begin
        ReAllocMem(P, I + 1);
        I := EnumMruList(FList, Index, P, I + 1);
      end;
      if I <> -1 then
      begin
        Result := True;
        SetItemData(P);
        FItemIndex := Index;
        if FireEvent then
          DoEnumText
      end;
    end
    else
    begin // Unicode
      ReAllocMem(P, 512);
      I := EnumMruListW(FList, Index, P, 256);
      if I > 255 then
      begin
        ReAllocMem(P, (I + 1) * 2);
        I := EnumMruListW(FList, Index, P, I + 1);
      end;
      if I <> -1 then
      begin
        Result := True;
        SetItemData(P);
        FItemIndex := Index;
        if FireEvent then
          DoUnicodeEnumText;
      end;
    end
  end
  else // FType = dtBinary
  begin
    ReAllocMem(P, 1024);

    if UnicodeAvailable then
      EnP := EnumMruListW
    else
      EnP := EnumMruList;
    //Arioch: work-around MS bug

    I := EnP(FList, Index, P, 1024);

    if I >= 1024 then
    begin
      ReAllocMem(P, 64000); // Arioch: Hmmm We'll never guess how much may there appear :)
      I := EnP(FList, 0, P, 64000);
    end;

    if I <> -1 then
    begin
      Result := True;
      ReAllocMem(P, I);
      // Arioch: should we waste more memory than we need?
      // and we can know the size of memory allocated
      // with GetMem and ReAllocMem, so we know how big Data was
      SetItemData(P);
      FItemIndex := Index;
      if FireEvent then
        DoEnumData(I);
    end;
  end;
end;

function TJvMruList.GetItemsCount: Integer;
begin
  if FList <> 0 then
    Result := EnumMruList(FList, -1, nil, 0)
  else
    Result := 0;
end;

function TJvMruList.GetMostRecentItem: Boolean;
begin
  Result := GetItem(0);
end;

function TJvMruList.GetSubKey: string;
begin
  Result := string(FSubKey);
end;

procedure TJvMruList.MoveToTop(const Index: Integer);
var
  B: Boolean;
begin
  B := False;
  if InternalGetItem(Index, False) then
  begin
    if FType = dtString then
    begin
      if UseUnicode then
        B := AddUnicodePChar(ItemDataAsPWideChar)
      else
        B := AddPChar(ItemDataAsPChar);
    end
    else
      B := AddData(ItemDataAsPointer, ItemDataSize);
  end;
  if B then
    FItemIndex := 0;
end;

procedure TJvMruList.NeedUnicode;
begin
  if not UnicodeAvailable then
    raise EMruException.CreateRes(@RsEErrorMruUnicode);
end;

procedure TJvMruList.ReCreateList;
begin
  Close;
  Open;
end;

procedure TJvMruList.SetItemData(const P: Pointer);
begin
  if P = FItemData.P then
    Exit;
  if FItemData.P <> nil then
    FreeMem(FItemData.P);
  FItemData.P := P;
end;

procedure TJvMruList.SetKey(const Value: TJvRegKey);
begin
  if Value <> FKey then
  begin
    FKey := Value;
    ReCreateList;
  end;
end;

procedure TJvMruList.SetMax(const Value: TMruCount);
begin
  if Value <> FMax then
  begin
    FMax := Value;
    ReCreateList;
  end;
end;

procedure TJvMruList.SetSubKey(const Value: string);
begin
  SetSubKeyUnicode(WideString(Value));
end;

procedure TJvMruList.SetSubKeyUnicode(const Value: WideString);
begin
  if Value <> FSubKey then
  begin
    FSubKey := Value;
    ReCreateList;
  end;
end;

procedure TJvMruList.SetType(const Value: TJvDataType);
begin
  if Value <> FType then
  begin
    FType := Value;
    ReCreateList;
  end;
end;

procedure TJvMruList.SetUseUnicode(const Value: Boolean);
begin
  if Value then
    NeedUnicode;
  if FUseUnicode = Value then
    Exit;
  FUseUnicode := Value;
end;

procedure TJvMruList.SetWantUnicode(const Value: Boolean);
begin
  if FWantUnicode = Value then
    Exit;

  FWantUnicode := Value;
  FUseUnicode := FWantUnicode and FUnicodeAvailable;
end;

procedure TJvMruList.Close;
begin
  if FList <> 0 then
  begin
    FreeMruList(FList);
    FList := 0;
  end;

  FItemIndex := -1;
  SetItemData(Pointer(nil));
end;

procedure TJvMruList.Open;
var
  FLst: TMruRec;
begin
  if csDesigning in ComponentState then
    Exit;

  if FSubKey <> '' then
  begin
    FLst.cbSize := SizeOf(FList);
    FLst.nMaxItems := FMax;
    case FType of
      dtString:
        begin
          FLst.dwFlags := MRUF_STRING_LIST;
          FLst.lpfnCompareString := nil;
        end;
      dtBinary:
        begin
          FLst.dwFlags := MRUF_BINARY_LIST;
          FLst.lpfnCompareData := nil;
        end;
    end;
    if FDelayedWrite then
      with FLst do
        dwFlags := MRUF_DELAYED_SAVE or dwFlags;
    case FKey of
      hkClassesRoot:
        FLst.hKey := HKEY_CLASSES_ROOT;
      hkCurrentUser:
        FLst.hKey := HKEY_CURRENT_USER;
      hkLocalMachine:
        FLst.hKey := HKEY_LOCAL_MACHINE;
      hkUsers:
        FLst.hKey := HKEY_USERS;
      hkCurrentConfig:
        FLst.hKey := HKEY_CURRENT_CONFIG;
    end;
    if UseUnicode then
    // Arioch changed this
      FLst.lpszSubKeyW := PWideChar(FSubKey)
    else
      FLst.lpszSubKey := PChar(GetSubKey);

    if UseUnicode then
    // Arioch changed this
      FList := CreateMruListW(@FLst)
    else
      FList := CreateMruList(@FLst);

    if FList = 0 then
      raise EMruException.CreateRes(@RsEErrorMruCreating);
  end;
end;

function TJvMruList.ItemDataSize: Integer;
// Arioch: Here we rely on undocumented internal structure
// that has been used by GetMem/FreeMem for ages!
// for example see sources for GetMem.Inc in VCL sources
//
// JVCL should have a list were it relies upon undocumented parts of Delphi,
//  Windows, etc..., so when new version of D,Win,... is released we could
//  check the list instead of hunting for misty bug;
begin
  if ItemDataAsPointer <> nil then
    Result := Integer(Pointer(Integer(ItemDataAsPointer) - SizeOf(Integer))^)
  else
    Result := 0;
end;

procedure TJvMruList.DoEnumText;
begin
  if Assigned(FOnEnumText) then
    FOnEnumText(Self, string(FItemData.S), ItemIndex);
//    FOnEnumText(Self, S, Index);
end;

procedure TJvMruList.DoUnicodeEnumText;
begin
  if Assigned(FOnEnumUnicodeText) then
    FOnEnumUnicodeText(Self, WideString(FItemData.Ws), FItemIndex);
//    FOnEnumUnicodeText(Self, S, Index);
end;

procedure TJvMruList.DoEnumData(DataSize: Integer);
begin
  if Assigned(FOnEnumData) then
    FOnEnumData(Self, FItemData.P, DataSize, FItemIndex);
end;

function TJvMruList.DeleteKey: Boolean;
begin
  Result := False;
  with TRegistry.Create do
  try
    if (FList = 0) and (SubKey <> '') and KeyExists(SubKey) then
      Result := DeleteKey(SubKey);
  finally
    Free;
  end;
end;

function TJvMruList.GetActive: Boolean;
begin
  Result := FList <> 0;
end;

procedure TJvMruList.SetActive(const Value: Boolean);
begin
  if GetActive <> Value then
  begin
    if Value then
      Open
    else
      Close;
  end;
end;

function TJvMruList.GetItemDataAsPChar: PChar;
begin
  Result := FItemData.S;
end;

function TJvMruList.GetItemDataAsPWideChar: PWideChar;
begin
  Result := FItemData.Ws;
end;

procedure FinalizeDLL;
begin
  if hComCtlDll > 0 then
  begin
    FreeLibrary(hComCtlDll);
    hComCtlDll := 0;
  end;
end;

procedure InitializeDLL;
begin
  if hComCtlDll = 0 then
  begin
    hComCtlDll := LoadLibrary(DllComCtlName);
    if hComCtlDll > 0 then
    begin
      // (rom) can we get them by name?
      CreateMruList := GetProcAddress(hComCtlDll, PChar(151));
      FreeMruList := GetProcAddress(hComCtlDll, PChar(152));
      AddMruString := GetProcAddress(hComCtlDll, PChar(153));
      AddMruData := GetProcAddress(hComCtlDll, PChar(167));
      DelMruString := GetProcAddress(hComCtlDll, PChar(156));
      EnumMruList := GetProcAddress(hComCtlDll, PChar(154));
      FindMruString := GetProcAddress(hComCtlDll, PChar(155));
      FindMruData := GetProcAddress(hComCtlDll, PChar(169));

      if Win32Platform = VER_PLATFORM_WIN32_NT then
      begin
        CreateMruListW := GetProcAddress(hComCtlDll, PChar(400));
        AddMruStringW := GetProcAddress(hComCtlDll, PChar(401));
        FindMruStringW := GetProcAddress(hComCtlDll, PChar(402));
        EnumMruListW := GetProcAddress(hComCtlDll, PChar(403));
      end;
    end
    else
      RaiseLastOSError;
  end;
end;

initialization
  {$IFDEF UNITVERSIONING}
  RegisterUnitVersion(HInstance, UnitVersioning);
  {$ENDIF UNITVERSIONING}

finalization
  FinalizeDLL;
  {$IFDEF UNITVERSIONING}
  UnregisterUnitVersion(HInstance);
  {$ENDIF UNITVERSIONING}

end.