Компоненты и примеры

[Little_Roo]

svn://svn.code.sf.net/p/lazarus-ccr/svn ... preadsheet
Может это?

[*Rik*]

svn://svn.code.sf.net/p/lazarus-ccr/svn/components/fpspreadsheet
Может это?

Не работает у меня. VarIsBool не понимает, видимо Lazarus устарел (версия 1.2.0)

[VirtUX]

Подскажите компонент наследующий TWinControl, который можно сделать прозрачным (невидимым). Задача: использовать его как контейнер (типа TPanel) для компонент (некоторые с прозрачным фоном как у TLabel), но чтоб этот контейнер не был виден (т.е. 100% прозрачен).

[mdli]

Кто то может перевести под Lazarus компонент Windows 7 Taskbar Components http://delphi.fsprolabs.com/ ? Он у меня компилируется но Лазарус при установленном пакете не запускается, знаний мне не хватает

[CynicRus]

Если вдруг кому потребуется читать из чужого процесса\писать в чужой процесс:

Код: Выделить всё


function process_vm_readv (PID: pid_t;local_iov: piovec;liovcnt: ulong;remote_iov: piovec;riovcnt: ulong; flags: ulong):ssize_t;cdecl; external clib name 'process_vm_readv';
function process_vm_writev (PID: pid_t;local_iov: piovec;liovcnt: ulong;remote_iov: piovec;riovcnt: ulong; flags: ulong):ssize_t;cdecl; external clib name 'process_vm_writev';

function TLinuxMemoryScanner.Attach: boolean;
var
  Status: longint = 0;
begin
if PTrace(PTRACE_ATTACH, pid_t(PID), nil, 0) = -1 then
    begin
      result:=false;
      raise Exception.Create(Format(ErrFailedToAttach,[PID]));
    end;
if (WaitPid(PID,@status,0) = -1) or not WIFSTOPPED(status) then
    begin
      result:=false;
      raise Exception.Create(ErrSigStopWaiting);
    end;
result:=true;
end;

function TLinuxMemoryScanner.Detach: boolean;
begin
  result:= ptrace(PTRACE_DETACH, pid, nil, nil) > -1;
end;

{$IFDEF OLDKERNEL}
function TLinuxMemoryScanner.GetValue(Address: integer; ValueSize: integer;
  Value: Pointer): boolean;
var
  i: integer;
  x:longint=0;
begin
if not Attach then
    begin
      result:=false;
      exit;
    end;
  i:=0;
  while i <= ValueSize do
    begin
      x := ptrace(PTRACE_PEEKDATA, PID, Address + i, nil);
      PByteArray(Value)^[i]:=x;
      inc(i);
    end;
detach();
result:=true;
end;

function TLinuxMemoryScanner.SetValue(Address: integer; ValueSize: integer;
  Value: Pointer): boolean;
var
  i: integer;
  x:longint=0;
begin
if not Attach then
    begin
      result:=false;
      exit;
    end;
  for i:= 0 to ValueSize - 1 do
     begin
     x := ptrace(PTRACE_POKEDATA, PID, Address + i, PByteArray(Value)^[i]);
      if errno <> 0 then
        begin
         Detach;
         result:=false;
        end;
      end;
detach();
result:=true;
end;
{$ELSE}
function TLinuxMemoryScanner.GetValue(Address: integer; ValueSize: integer;
  Value: Pointer): boolean;
var
  local,remote: array [0..0] of iovec;
  NRead: longint = 0;
begin
result:=false;
Local[0].iov_len:=ValueSize;
Local[0].iov_base:=Value;
Remote[0].iov_base:=Pointer(Address);
Remote[0].iov_len:=Valuesize;
Nread:=process_vm_readv(PID,@local[0],1,@remote[0],1,0);
if not Nread <> ValueSize then
   result:=true;
end;

function TLinuxMemoryScanner.SetValue(Address: integer; ValueSize: integer;
  Value: Pointer): boolean;
var
  local,remote: array [0..0] of iovec;
  NWritten: longint = 0;
begin
result:=false;
Local[0].iov_len:=ValueSize;
Local[0].iov_base:=Value;
Remote[0].iov_base:=Pointer(Address);
Remote[0].iov_len:=Valuesize;
NWritten:=process_vm_writev(PID,@local[0],1,@remote[0],1,0);
if not NWritten <> ValueSize then
   result:=true;
end;
{$ENDIF}


Проверено на убунте, все замечательно работает.

[CynicRus]

Перевод хидера winevt на Pascal. Для доступа к виндовому EventLog. Проверено на Win 7 и 10.

Код: Выделить всё

unit winevt_h;

{$ifdef FPC}
  {$mode objfpc}{$H+}
{$EndIF}

interface

uses
  Classes, SysUtils, Windows;
//https://msdn.microsoft.com/en-us/library/windows/desktop/aa385785%28v=vs.85%29.aspx
const
  winevt = 'wevtapi.dll';
  EVT_VARIANT_TYPE_MASK = $7f;
  EVT_VARIANT_TYPE_ARRAY = 128;
  EVT_READ_ACCESS = $1;
  EVT_WRITE_ACCESS = $2;
  EVT_CLEAR_ACCESS = $4;
  EVT_ALL_ACCESS = $7;

type
  EVT_HANDLE = THandle;
  PEVT_HANDLE = ^Handle;
  EVT_OBJECT_ARRAY_PROPERTY_HANDLE = THandle;

  EVT_CHANNEL_CLOCK_TYPE = (EvtChannelClockTypeSystemTime = 0,
    EvtChannelClockTypeQPC = 1);
  EVT_CHANNEL_CONFIG_PROPERTY_ID = (EvtChannelConfigEnabled = 0,
    EvtChannelConfigIsolation = 1,
    EvtChannelConfigType = 2,
    EvtChannelConfigOwningPublisher = 3,
    EvtChannelConfigClassicEventlog = 4,
    EvtChannelConfigAccess = 5,
    EvtChannelLoggingConfigRetention = 6,
    EvtChannelLoggingConfigAutoBackup = 7,
    EvtChannelLoggingConfigMaxSize = 8,
    EvtChannelLoggingConfigLogFilePath = 9,
    EvtChannelPublishingConfigLevel = 10,
    EvtChannelPublishingConfigKeywords = 11,
    EvtChannelPublishingConfigControlGuid = 12,
    EvtChannelPublishingConfigBufferSize = 13,
    EvtChannelPublishingConfigMinBuffers = 14,
    EvtChannelPublishingConfigMaxBuffers = 15,
    EvtChannelPublishingConfigLatency = 16,
    EvtChannelPublishingConfigClockType = 17,
    EvtChannelPublishingConfigSidType = 18,
    EvtChannelPublisherList = 19,
    EvtChannelPublishingConfigFileMax = 20,
    EvtChannelConfigPropertyIdEND = 21);

  EVT_CHANNEL_ISOLATION_TYPE = (EvtChannelIsolationTypeApplication = 0,
    EvtChannelIsolationTypeSystem = 1,
    EvtChannelIsolationTypeCustom = 2);

  EVT_CHANNEL_REFERENCE_FLAGS = (EvtChannelReferenceImported = $1);
  EVT_CHANNEL_SID_TYPE = (EvtChannelSidTypeNone = 0,
    EvtChannelSidTypePublishing = 1);
  EVT_CHANNEL_TYPE = (EvtChannelTypeAdmin = 0,
    EvtChannelTypeOperational = 1,
    EvtChannelTypeAnalytic = 2,
    EvtChannelTypeDebug = 3);

  EVT_EVENT_METADATA_PROPERTY_ID = (EventMetadataEventID = 0,
    EventMetadataEventVersion = 1,
    EventMetadataEventChannel = 2,
    EventMetadataEventLevel = 3,
    EventMetadataEventOpcode = 4,
    EventMetadataEventTask = 5,
    EventMetadataEventKeyword = 6,
    EventMetadataEventMessageID = 7,
    EventMetadataEventTemplate = 8,
    EvtEventMetadataPropertyIdEND = 9);

  EVT_EVENT_PROPERTY_ID = (EvtEventQueryIDs = 0,
    EvtEventPath = 1,
    EvtEventPropertyIdEND = 2);

  EVT_EXPORTLOG_FLAGS = (EvtExportLogChannelPath = $1,
    EvtExportLogFilePath = $2,
    EvtExportLogTolerateQueryErrors = $1000);

  EVT_FORMAT_MESSAGE_FLAGS = (EvtFormatMessageEvent = 1,
    EvtFormatMessageLevel = 2,
    EvtFormatMessageTask = 3,
    EvtFormatMessageOpcode = 4,
    EvtFormatMessageKeyword = 5,
    EvtFormatMessageChannel = 6,
    EvtFormatMessageProvider = 7,
    EvtFormatMessageId = 8,
    EvtFormatMessageXml = 9);

  EVT_LOG_PROPERTY_ID = (EvtLogCreationTime = 0,
    EvtLogLastAccessTime = 1,
    EvtLogLastWriteTime = 2,
    EvtLogFileSize = 3,
    EvtLogAttributes = 4,
    EvtLogNumberOfLogRecords = 5,
    EvtLogOldestRecordNumber = 6,
    EvtLogFull = 7);

  EVT_LOGIN_CLASS = (EvtRpcLogin = 1);

  EVT_OPEN_LOG_FLAGS = (EvtOpenChannelPath = $1,
    EvtOpenFilePath = $2);

  EVT_PUBLISHER_METADATA_PROPERTY_ID =
    (EvtPublisherMetadataPublisherGuid = 0,
    EvtPublisherMetadataResourceFilePath,
    EvtPublisherMetadataParameterFilePath,
    EvtPublisherMetadataMessageFilePath,
    EvtPublisherMetadataHelpLink,
    EvtPublisherMetadataPublisherMessageID,
    EvtPublisherMetadataChannelReferences,
    EvtPublisherMetadataChannelReferencePath,
    EvtPublisherMetadataChannelReferenceIndex,
    EvtPublisherMetadataChannelReferenceID,
    EvtPublisherMetadataChannelReferenceFlags,
    EvtPublisherMetadataChannelReferenceMessageID,
    EvtPublisherMetadataLevels,
    EvtPublisherMetadataLevelName,
    EvtPublisherMetadataLevelValue,
    EvtPublisherMetadataLevelMessageID,
    EvtPublisherMetadataTasks,
    EvtPublisherMetadataTaskName,
    EvtPublisherMetadataTaskEventGuid,
    EvtPublisherMetadataTaskValue,
    EvtPublisherMetadataTaskMessageID,
    EvtPublisherMetadataOpcodes,
    EvtPublisherMetadataOpcodeName,
    EvtPublisherMetadataOpcodeValue,
    EvtPublisherMetadataOpcodeMessageID,
    EvtPublisherMetadataKeywords,
    EvtPublisherMetadataKeywordName,
    EvtPublisherMetadataKeywordValue,
    EvtPublisherMetadataKeywordMessageID,
    EvtPublisherMetadataPropertyIdEND);

  EVT_QUERY_FLAGS = (EvtQueryChannelPath = $1,
    EvtQueryFilePath = $2,
    EvtQueryForwardDirection = $100,
    EvtQueryReverseDirection = $200,
    EvtQueryTolerateQueryErrors = $1000);

  EVT_QUERY_PROPERTY_ID = (EvtQueryNames = 0,
    EvtQueryStatuses = 1,
    EvtQueryPropertyIdEND = 2);

  EVT_RENDER_CONTEXT_FLAGS = (EvtRenderContextValues = 0,
    EvtRenderContextSystem = 1,
    EvtRenderContextUser = 2);

  EVT_RENDER_FLAGS = (EvtRenderEventValues = 0,
    EvtRenderEventXml = 1,
    EvtRenderBookmark = 2);

  EVT_RPC_LOGIN_FLAGS = (EvtRpcLoginAuthDefault = 0,
    EvtRpcLoginAuthNegotiate = 1,
    EvtRpcLoginAuthKerberos = 2,
    EvtRpcLoginAuthNTLM = 3);

  EVT_SEEK_FLAGS = (EvtSeekRelativeToFirst = 1,
    EvtSeekRelativeToLast = 2,
    EvtSeekRelativeToCurrent = 3,
    EvtSeekRelativeToBookmark = 4,
    EvtSeekOriginMask = 7,
    EvtSeekStrict = $10000);

  EVT_SUBSCRIBE_FLAGS = (EvtSubscribeToFutureEvents = 1,
    EvtSubscribeStartAtOldestRecord = 2,
    EvtSubscribeStartAfterBookmark = 3,
    EvtSubscribeOriginMask = $3,
    EvtSubscribeTolerateQueryErrors = $1000,
    EvtSubscribeStrict = $10000);

  EVT_SUBSCRIBE_NOTIFY_ACTION = (EvtSubscribeActionError = 0,
    EvtSubscribeActionDeliver = 1);

  EVT_SYSTEM_PROPERTY_ID = (EvtSystemProviderName = 0,
    EvtSystemProviderGuid,
    EvtSystemEventID,
    EvtSystemQualifiers,
    EvtSystemLevel,
    EvtSystemTask,
    EvtSystemOpcode,
    EvtSystemKeywords,
    EvtSystemTimeCreated,
    EvtSystemEventRecordId,
    EvtSystemActivityID,
    EvtSystemRelatedActivityID,
    EvtSystemProcessID,
    EvtSystemThreadID,
    EvtSystemChannel,
    EvtSystemComputer,
    EvtSystemUserID,
    EvtSystemVersion,
    EvtSystemPropertyIdEND);

  EVT_VARIANT_TYPE = (EvtVarTypeNull = 0,
    EvtVarTypeString = 1,
    EvtVarTypeAnsiString = 2,
    EvtVarTypeSByte = 3,
    EvtVarTypeByte = 4,
    EvtVarTypeInt16 = 5,
    EvtVarTypeUInt16 = 6,
    EvtVarTypeInt32 = 7,
    EvtVarTypeUInt32 = 8,
    EvtVarTypeInt64 = 9,
    EvtVarTypeUInt64 = 10,
    EvtVarTypeSingle = 11,
    EvtVarTypeDouble = 12,
    EvtVarTypeBoolean = 13,
    EvtVarTypeBinary = 14,
    EvtVarTypeGuid = 15,
    EvtVarTypeSizeT = 16,
    EvtVarTypeFileTime = 17,
    EvtVarTypeSysTime = 18,
    EvtVarTypeSid = 19,
    EvtVarTypeHexInt32 = 20,
    EvtVarTypeHexInt64 = 21,
    EvtVarTypeEvtHandle = 32,
    EvtVarTypeEvtXml = 35);

  TEvtRPCLogin = record
    Server: PWideChar;
    User: PWideChar;
    Domain: PWideChar;
    Password: PWideChar;
    Flags: PWideChar;
  end;
{$packrecords C}
  type TEvtVariant =  record
   Union:  record
    case dword of
      0: (BooleanVal: boolean);
      1: (SByteVal: Int8);
      2: (Int16Val: int16);
      3: (Int32Val: int32);
      4: (Int64Val: int64);
      5: (ByteVal: UInt8);
      6: (UInt16Val: UInt16);
      7: (UInt32Val: UInt32);
      8: (UInt64Val: UInt64);
      9: (SingleVal: single);
      10: (DoubleVal: double);
      11: (FileTimeVal: ULONGLONG);
      12: (SysTimeVal: ^SYSTEMTIME);
      13: (GuidVal: ^GUID);
      14: (StringVal: PWideChar);
      15: (AnsiStringVal: PChar);
      16: (BinaryVal: PByte);
      17: (SidVal: PSid);
      18: (SizeTVal: size_t);
      19: (EvtHandleVal: EVT_HANDLE);
      20: (BooleanArr: PBoolean);
      21: (SByteArr: PByte);
      22: (Int16Arr: ^int16);
      23: (Int32Arr: ^int32);
      24: (Int64Arr: ^int64);
      25: (ByteArr: PByte);
      26: (UInt16Arr: ^UInt16);
      27: (UInt32Arr: ^Uint32);
      28: (UInt64Arr: ^Uint64);
      29: (SingleArr: ^single);
      30: (DoubleArr: ^double);
      31: (FileTimeArr: ^FileTime);
      32: (SysTimeArr: ^SystemTime);
      33: (GuidArr: ^GUID);
      34: (StringArr: ^PWideChar);
      35: (AnsiStringArr: ^PChar);
      36: (SidArr: ^PSid);
      37: (SizeTArr: ^Size_T);
      38: (XmlVal: PwideChar);
      39: (XmlValArr: ^PWideChar);
      end;
    Count: Dword;
    vType: EVT_VARIANT_TYPE;
  end;
  PEVT_VARIANT = ^TEvtVariant;

  EVT_SUBSCRIBE_CALLBACK = function(Action: EVT_SUBSCRIBE_NOTIFY_ACTION;
    UserContext: Pointer; Event: EVT_HANDLE): dword; stdcall;

function EvtArchiveExportedLog(Session: EVT_HANDLE; LogFilePath: PWideChar;
  Locale: LCID; Flags: DWORD): boolean; stdcall; external winevt;
function EvtCancel(Obj: EVT_HANDLE): boolean; stdcall; external winevt;
function EvtClearLog(Session: EVT_HANDLE; ChannelPath: PwideChar;
  TargetFilePath: PWideChar; Flags: DWORD): boolean; stdcall; external winevt;
function EvtClose(Obj: EVT_HANDLE): boolean; stdcall; external winevt;
function EvtCreateBookmark(BookmarkXML: PWideChar): boolean; stdcall; external winevt;
function EvtCreateRenderContext(ValuePathsCount: dword; ValuePaths: PPWideChar;
  Flags: EVT_RENDER_CONTEXT_FLAGS): EVT_HANDLE; stdcall; external winevt;
function EvtExportLog(Session: EVT_HANDLE; Path, Query, TargetFilePath: PWideChar;
  Flags: EVT_EXPORTLOG_FLAGS): boolean; stdcall; external winevt;
function EvtFormatMessage(PublisherMetadata, Event: EVT_HANDLE;
  MessageID, ValueCount: dword; Values: PEVT_Variant; Flags, BufferSize: dword;
  Buffer: PWideChar; BufferUsed: dword): boolean; stdcall; external winevt;
function EvtGetChannelConfigProperty(ChannelConfig: EVT_HANDLE;
  PropertyID: EVT_CHANNEL_CONFIG_PROPERTY_ID; Flags, PropertyValueBufferSize: dword;
  PropertyValueBuffer: PEVT_Variant; PropertyValueBufferUsed: Dword): boolean;
  stdcall; external winevt;
function EvtGetEventInfo(Event: EVT_HANDLE; PropertyId: EVT_EVENT_PROPERTY_ID;
  PropertyValueBufferSize: dword; PropertyValueBuffer: PEVT_Variant;
  PropertyValueBufferUsed: Dword): boolean; stdcall; external winevt;
function EvtGetEventMetadataProperty(EventMetadata: EVT_HANDLE;
  PropertyId: EVT_EVENT_METADATA_PROPERTY_ID; EventMetadataPropertyValueBufferSize: dword;
  EventMetadataPropertyValueBuffer: PEVT_Variant;
  EventMetadataPropertyValueBufferUsed: Dword): boolean; stdcall; external winevt;
function EvtGetExtendedStatus(BufferSize: Dword; Buffer: PWideChar;
  BufferUsed: dword): dword; stdcall; external winevt;
function EvtGetLogInfo(Log: EVT_HANDLE; PropertyID: EVT_LOG_PROPERTY_ID;
  PropertyValueBufferSize: dword; PropertyValueBuffer: PEVT_Variant;
  PropertyValueBufferUsed: dword): boolean; stdcall; external winevt;
function EvtGetObjectArrayProperty(ObjArray: EVT_OBJECT_ARRAY_PROPERTY_HANDLE;
  PropertyID, ArrayIndex, Flags: dword; PropertyValueBufferSize: dword;
  PropertyValueBuffer: PEVT_Variant; PropertyValueBufferUsed: dword): boolean;
  stdcall; external winevt;
function EvtGetObjectArraySize(ObjArray: EVT_OBJECT_ARRAY_PROPERTY_HANDLE;
  ObjArraySize: Dword): boolean; stdcall; external winevt;
function EvtGetPublisherMetadataProperty(PublisherMetadata: EVT_HANDLE;
  PropertyId: EVT_PUBLISHER_METADATA_PROPERTY_ID;
  Flags, PublisherEventMetadataPropertyValueBufferSize: dword;
  PublisherEventMetadataPropertyValueBuffer: PEVT_Variant;
  PublisherEventMetadataPropertyValueBufferUsed: Dword): boolean; stdcall; external winevt;
function EvtGetQueryInfo(QueryOrSubscription: EVT_HANDLE;
  PropertyID: EVT_QUERY_PROPERTY_ID; PropertyValueBufferSize: dword;
  PropertyValueBuffer: PEVT_Variant; PropertyValueBufferUsed: dword): boolean;
  stdcall; external winevt;
function EvtNext(ResultSet: EVT_HANDLE; EventArraySize: dword;
  EventArray: PEVT_Handle; Timeout, Flags: dword; Returned: PDword): boolean;
  stdcall; external winevt;
function EvtNextChannelPath(ChannelEnum: EVT_HANDLE;
  ChannelPathValueBufferSize: dword; ChannelPathValueBuffer: PEVT_Variant;
  ChannelPathBufferUsed: dword): boolean; stdcall; external winevt;
function EvtNextEventMetadata(EventMetadataEnum: EVT_HANDLE; Flags: dword): boolean;
  stdcall; external winevt;
function EvtNextPublisherId(PublisherId: EVT_HANDLE; PublisherIdBufferSize: dword;
  PublisherIdBuffer: PEVT_Variant; PublisherIdBufferUsed: dword): boolean;
  stdcall; external winevt;
function EvtOpenChannelConfig(Session: EVT_HANDLE; ChannelPath: PwideChar;
  Flags: dword): EVT_HANDLE; stdcall; external winevt;
function EvtOpenChannelEnum(Session: EVT_HANDLE; Flags: dword): EVT_HANDLE;
  stdcall; external winevt;
function EvtOpenEventMetadataEnum(PublisherMetadata: EVT_HANDLE;
  Flags: dword): EVT_HANDLE; stdcall; external winevt;
function EvtOpenLog(Session: EVT_HANDLE; Path: PwideChar;
  Flags: EVT_OPEN_LOG_FLAGS): EVT_HANDLE; stdcall; external winevt;
function EvtOpenPublisherEnum(Session: EVT_HANDLE; Flags: dword): EVT_HANDLE;
  stdcall; external winevt;
function EvtOpenPublisherMetadata(Session: EVT_HANDLE;
  PublisherIdentity: PWideChar; LogFilePath: PwideChar; Locale: LCID;
  Flags: dword): EVT_HANDLE;
  stdcall; external winevt;
function EvtOpenSession(LoginClass: EVT_LOGIN_CLASS; Login: Pointer;
  Timeout, Flags: dword): EVT_HANDLE; stdcall; external winevt;
function EvtQuery(Session: EVT_HANDLE; Path, Query: PWideChar; Flags: EVT_QUERY_FLAGS): EVT_HANDLE;
  stdcall; external winevt;
function EvtRender(Context, Fragment: EVT_HANDLE; Flags:EVT_RENDER_FLAGS; BufferSize: dword;
  Buffer: pointer; BufferUsed, PropertyCount: PDword): boolean; stdcall; external winevt;
function EvtSaveChannelConfig(ChannelConfig: EVT_HANDLE; Flags: dword): boolean;
  stdcall; external winevt;
function EvtSeek(ResultSet: EVT_HANDLE; Position: LONGLONG;
  Bookmark: EVT_HANDLE; Timeout, Flags: dword): boolean; stdcall; external winevt;
function EvtSetChannelConfigProperty(ChannelConfig: EVT_HANDLE;
  PropertyID: EVT_CHANNEL_CONFIG_PROPERTY_ID; Flags: dword;
  PropertyValue: PEVT_VARIANT): boolean; stdcall; external winevt;
function EvtSubscribe(Session: EVT_HANDLE; SignalEvent: EVT_HANDLE;
  ChannelPath, Query: PWideChar; Bookmark: EVT_HANDLE; Context: pointer;
  Callback: EVT_SUBSCRIBE_CALLBACK; Flags: dword): EVT_HANDLE; stdcall; external winevt;
function EvtUpdateBookmark(Bookmark, Event: EVT_HANDLE): boolean;
  stdcall; external winevt;

implementation

end.

Правда не все функции, но большая часть, которая мне была необходима-)

[CynicRus]

Пример распечатывания StringGrid'a, на принтер по дефолту. Если данных больше, чем на одну страницу, то распечатается на нескольких. Сам долго искал, как это разбить по человечески. Нашёл, напильником немного обработал - делюсь с остальными

Код: Выделить всё

procedure PrintGrid(Grid: TStringGrid; Title: string; Orientation: TPrinterOrientation);
var
  P, I, J, YPos, XPos, HorzSize, VertSize: integer;
  PagesCount, Page, Line, HeaderSize, FooterSize, LineSize, FontHeight: integer;
  mmx, mmy: extended;
  Footer: string;
begin
  HeaderSize := 100;
  FooterSize := 200;
  LineSize := 36;
  FontHeight := 36;
  //Инициализация принтера
  Printer.Orientation := Orientation;
  Printer.Title := Title;
  Printer.BeginDoc;

  mmx := Printer.PaperSize.PaperRect.PhysicalRect.Right /
    GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSX) * 25.4;
  mmy := Printer.PaperSize.PaperRect.PhysicalRect.Bottom /
    GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY) * 25.4;

  VertSize := Trunc(mmy) * 10;
  HorzSize := Trunc(mmx) * 10;
  SetMapMode(Printer.Canvas.Handle, MM_LOMETRIC);

  // Установить количество строк  на страницу
  Line := (VertSize - HeaderSize - FooterSize) div LineSize;
  // Определение количества страниц
  if Grid.RowCount mod Line <> 0 then
    PagesCount := Grid.RowCount div Line + 1
  else
    PagesCount := Grid.RowCount div Line;

  Page := 1;
  //Печатаем таблицу
  for P := 1 to PagesCount do
  begin
    //заголовок и верхний клонтитул
    Printer.Canvas.Font.Height := 48;
    if Page = 1 then
      Printer.Canvas.TextOut((HorzSize div 2 - (Printer.Canvas.TextWidth(Title) div 2)),
        -20, Title);
    Printer.Canvas.Pen.Width := 5;
    Printer.Canvas.MoveTo(0, -HeaderSize);
    Printer.Canvas.LineTo(HorzSize, -HeaderSize);
    //нижний колонтитул
    Printer.Canvas.MoveTo(0, -VertSize + FooterSize);
    Printer.Canvas.LineTo(HorzSize, -VertSize + FooterSize);
    Printer.Canvas.Font.Height := 36;
    Footer := 'Страница: ' + IntToStr(Page) + ' из ' + IntToStr(PagesCount);
    Printer.Canvas.TextOut((HorzSize div 2 - (Printer.Canvas.TextWidth(Footer) div 2)),
      -VertSize + 150, Footer);
    //Печатаем сами данные
    Printer.Canvas.Font.Height := FontHeight;
    YPos := HeaderSize + 10;
    for I := 1 to Line do
    begin
      if Grid.RowCount >= I + (Page - 1) * Line then
      begin
        XPos := 0;
        for J := 0 to Grid.ColCount - 1 do
        begin
          Printer.Canvas.TextOut(XPos, -YPos,
            Grid.Cells[J, I + (Page - 1) * Line - 1]);
          XPos := XPos + Grid.ColWidths[J] * 3;
        end;
        YPos := YPos + LineSize;
      end;
    end;
    //переходим на следующую страницу.
    Inc(Page);
    if Page <= PagesCount then
      Printer.NewPage;
  end;
  Printer.EndDoc;
end;


[Sharfik]

Под lazarus есть компоненты просмотра и по возможности сравнения pdf файлов?

[v-t-l]

единственное, что нашлось из открытого:
https://github.com/ahausladen/PdfiumLib

[Vlad04]

Подскажите? есть ли готовый компонент? для выбора диапазона значений, наподобие этого

Selector.png

[olegy123]

https://www.tmssoftware.com/site/advtrackbar.asp

Добавлено спустя 5 минут 49 секунд:
DevExpress есть slider

[Vlad04]

Вот, нашёл в сети такой модуль, вроде работает. Может, кому пригодится

Код: Выделить всё

unit RangeSelector;

{$mode objfpc}{$H+}

interface

uses
//  LCLIntf,
  SysUtils,
  Windows,
//  LMessages,
  Graphics,
  Classes,
  Controls,
  UxTheme,
  Dialogs;

type
  TRangeSelectorState = (rssNormal, rssDisabled, rssThumb1Hover, rssThumb1Down, rssThumb2Hover, rssThumb2Down, rssBlockHover, rssBlockDown);

  TRangeSelector = class(TCustomControl)
  private
    { Private declarations }
    FMin,
    FMax,
    FSelStart,
    FSelEnd: double;
    FTrackPos,
    FSelPos,
    FThumbPos1,
    FThumbPos2: TRect;
    FState: TRangeSelectorState;
    FDown: boolean;
    FPrevX,
    FPrevY: integer;
    FOnChange: TNotifyEvent;
    FDblClicked: Boolean;
    FThumbSize: TSize;
    procedure SetMin(Min: double);
    procedure SetMax(Max: double);
    procedure SetSelStart(SelStart: double);
    procedure SetSelEnd(SelEnd: double);
    function GetSelLength: double;
    procedure UpdateMetrics;
    procedure SetState(State: TRangeSelectorState);
    function DeduceState(const X, Y: integer; const Down: boolean): TRangeSelectorState;
    function BarWidth: integer; inline;
    function LogicalToScreen(const LogicalPos: double): double;
    procedure UpdateThumbMetrics;
  protected
    { Protected declarations }
    procedure Paint; override;
    procedure WndProc(var Message: TMessage); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseLeave; override ;
    procedure DblClick; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Anchors;
    property Min: double read FMin write SetMin;
    property Max: double read FMax write SetMax;
    property SelStart: double read FSelStart write SetSelStart;
    property SelEnd: double read FSelEnd write SetSelEnd;
    property SelLength: double read GetSelLength;
    property Enabled;
    property Visible;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Color ;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('RangeSelector', [TRangeSelector]);
end;

function IsIntInInterval(x, xmin, xmax: integer): boolean; inline;
begin
  IsIntInInterval := (xmin <= x) and (x <= xmax);
end;

function PointInRect(const X, Y: integer; const Rect: TRect): boolean; inline;
begin
  PointInRect := IsIntInInterval(X, Rect.Left, Rect.Right) and
                 IsIntInInterval(Y, Rect.Top, Rect.Bottom);
end;

function IsRealInInterval(x, xmin, xmax: extended): boolean; inline;
begin
  IsRealInInterval := (xmin <= x) and (x <= xmax);
end;

{ TRangeSelector }

function TRangeSelector.BarWidth: integer;
begin
  result := Width - 2*FThumbSize.cx;
end;

constructor TRangeSelector.Create(AOwner: TComponent);
begin
  inherited;
  FMin := 0;
  FMax := 100;
  FSelStart := 20;
  FSelEnd := 80;
  FDown := false;
  FPrevX := -1;
  FPrevY := -1;
  FDblClicked := false;
end;

procedure TRangeSelector.UpdateThumbMetrics;
var
  theme: HTHEME;
const
  DEFAULT_THUMB_SIZE: TSize = (cx: 12; cy: 20);
begin
  FThumbSize := DEFAULT_THUMB_SIZE;
  if UxTheme.UseThemes then
  begin
    theme := OpenThemeData(Handle, 'TRACKBAR');
    if theme <> 0 then
      try
        GetThemePartSize(theme, Handle, TKP_THUMBTOP, TUTS_NORMAL, nil, TS_DRAW, FThumbSize)
      finally
        CloseThemeData(theme);
      end;
  end;
end;

destructor TRangeSelector.Destroy;
begin
  inherited;
end;

function TRangeSelector.GetSelLength: double;
begin
  result := FSelEnd - FSelStart;
end;

function TRangeSelector.LogicalToScreen(const LogicalPos: double): double;
begin
  result := FThumbSize.cx + BarWidth * (LogicalPos - FMin) / (FMax - FMin)
end;

procedure TRangeSelector.DblClick;
var
  str: string;
begin
  FDblClicked := true;
  case FState of
    rssThumb1Hover, rssThumb1Down:
      begin
        str := FloatToStr(FSelStart);
        if InputQuery('Initial value', 'Enter new initial value:', str) then
          SetSelStart(StrToFloat(str));
      end;
    rssThumb2Hover, rssThumb2Down:
      begin
        str := FloatToStr(FSelEnd);
        if InputQuery('Final value', 'Enter new final value:', str) then
          SetSelEnd(StrToFloat(str));
      end;
  end;
end;

function TRangeSelector.DeduceState(const X, Y: integer; const Down: boolean): TRangeSelectorState;
begin
  result := rssNormal;

  if not Enabled then
    Exit(rssDisabled);

  if PointInRect(X, Y, FThumbPos1) then
    if Down then
      result := rssThumb1Down
    else
      result := rssThumb1Hover

  else if PointInRect(X, Y, FThumbPos2) then
    if Down then
      result := rssThumb2Down
    else
      result := rssThumb2Hover

  else if PointInRect(X, Y, FSelPos) then
    if Down then
      result := rssBlockDown
    else
      result := rssBlockHover;


end;

procedure TRangeSelector.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if FDblClicked then
  begin
    FDblClicked := false;
    Exit;
  end;
  FDown := Button = mbLeft;
  SetState(DeduceState(X, Y, FDown));
end;

procedure TRangeSelector.MouseLeave;
begin
  if Enabled then
    SetState(rssNormal)
  else
    SetState(rssDisabled);
end;

procedure TRangeSelector.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if FState = rssThumb1Down then
    SetSelStart(FSelStart + (X - FPrevX) * (FMax - FMin) / BarWidth)
  else if FState = rssThumb2Down then
    SetSelEnd(FSelEnd + (X - FPrevX) * (FMax - FMin) / BarWidth)
  else if FState = rssBlockDown then
  begin
    if IsRealInInterval(FSelStart + (X - FPrevX) * (FMax - FMin) / BarWidth, FMin, FMax) and
       IsRealInInterval(FSelEnd + (X - FPrevX) * (FMax - FMin) / BarWidth, FMin, FMax) then
    begin
      SetSelStart(FSelStart + (X - FPrevX) * (FMax - FMin) / BarWidth);
      SetSelEnd(FSelEnd + (X - FPrevX) * (FMax - FMin) / BarWidth);
    end;
  end
  else
    SetState(DeduceState(X, Y, FDown));

  FPrevX := X;
  FPrevY := Y;
end;

procedure TRangeSelector.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  FDown := false;
  SetState(DeduceState(X, Y, FDown));
end;

procedure TRangeSelector.Paint;
var
  theme: HTHEME;
begin
  inherited;

  theme := 0 ;

  if UxTheme.UseThemes then
    theme := OpenThemeData(Handle, 'TRACKBAR');

  Canvas.Brush.Color := Color;
  Canvas.FillRect(ClientRect);
  if theme <> 0 then
  begin
    try
      DrawThemeBackground(theme, Canvas.Handle, TKP_TRACK, TRS_NORMAL, FTrackPos, nil);

      case FState of
        rssDisabled:
          DrawThemeBackground(theme, Canvas.Handle, TKP_THUMB, TUS_DISABLED, FSelPos, nil);
        rssBlockHover:
          DrawThemeBackground(theme, Canvas.Handle, TKP_THUMB, TUS_HOT, FSelPos, nil);
        rssBlockDown:
          DrawThemeBackground(theme, Canvas.Handle, TKP_THUMB, TUS_PRESSED, FSelPos, nil);
      else
        DrawThemeBackground(theme, Canvas.Handle, TKP_THUMB, TUS_NORMAL, FSelPos, nil);
      end;


      case FState of
        rssDisabled:
          DrawThemeBackground(theme, Canvas.Handle, TKP_THUMBBOTTOM, TUBS_DISABLED, FThumbPos1, nil);
        rssThumb1Hover:
          DrawThemeBackground(theme, Canvas.Handle, TKP_THUMBBOTTOM, TUBS_HOT, FThumbPos1, nil);
        rssThumb1Down:
          DrawThemeBackground(theme, Canvas.Handle, TKP_THUMBBOTTOM, TUBS_PRESSED, FThumbPos1, nil);
      else
        DrawThemeBackground(theme, Canvas.Handle, TKP_THUMBBOTTOM, TUBS_NORMAL, FThumbPos1, nil);
      end;

      case FState of
        rssDisabled:
          DrawThemeBackground(theme, Canvas.Handle, TKP_THUMBTOP, TUTS_DISABLED, FThumbPos2, nil);
        rssThumb2Hover:
          DrawThemeBackground(theme, Canvas.Handle, TKP_THUMBTOP, TUTS_HOT, FThumbPos2, nil);
        rssThumb2Down:
          DrawThemeBackground(theme, Canvas.Handle, TKP_THUMBTOP, TUTS_PRESSED, FThumbPos2, nil);
      else
        DrawThemeBackground(theme, Canvas.Handle, TKP_THUMBTOP, TUTS_NORMAL, FThumbPos2, nil);
      end;

    finally
      CloseThemeData(theme);
    end;
  end


  else

  begin

    DrawEdge(Canvas.Handle, FTrackPos, EDGE_SUNKEN, BF_RECT);

    Canvas.Brush.Color := clHighlight;
    Canvas.FillRect(FSelPos);

    case FState of
      rssDisabled:
        DrawEdge(Canvas.Handle, FSelPos, EDGE_BUMP, BF_RECT or BF_MONO);
      rssBlockHover:
        DrawEdge(Canvas.Handle, FSelPos, EDGE_RAISED, BF_RECT);
      rssBlockDown:
        DrawEdge(Canvas.Handle, FSelPos, EDGE_SUNKEN, BF_RECT);
    else
      DrawEdge(Canvas.Handle, FSelPos, EDGE_ETCHED, BF_RECT);
    end;

    case FState of
      rssDisabled:
        DrawEdge(Canvas.Handle, FThumbPos1, EDGE_BUMP, BF_RECT or BF_MONO);
      rssThumb1Hover:
        DrawEdge(Canvas.Handle, FThumbPos1, EDGE_RAISED, BF_RECT);
      rssThumb1Down:
        DrawEdge(Canvas.Handle, FThumbPos1, EDGE_SUNKEN, BF_RECT);
    else
      DrawEdge(Canvas.Handle, FThumbPos1, EDGE_ETCHED, BF_RECT);
    end;

    case FState of
      rssDisabled:
        DrawEdge(Canvas.Handle, FThumbPos2, EDGE_BUMP, BF_RECT or BF_MONO);
      rssThumb2Hover:
        DrawEdge(Canvas.Handle, FThumbPos2, EDGE_RAISED, BF_RECT);
      rssThumb2Down:
        DrawEdge(Canvas.Handle, FThumbPos2, EDGE_SUNKEN, BF_RECT);
    else
      DrawEdge(Canvas.Handle, FThumbPos2, EDGE_ETCHED, BF_RECT);
    end;

  end;

end;

procedure TRangeSelector.UpdateMetrics;
begin
  UpdateThumbMetrics;
  FTrackPos := Rect(FThumbSize.cx, FThumbSize.cy + 2, Width - FThumbSize.cx, Height - FThumbSize.cy - 2);
  FSelPos := Rect(round(LogicalToScreen(FSelStart)),
                  FTrackPos.Top,
                  round(LogicalToScreen(FSelEnd)),
                  FTrackPos.Bottom);
  with FThumbPos1 do
  begin
    Top := 0;
    Left := round(LogicalToScreen(FSelStart) - FThumbSize.cx / 2);
    Right := Left + FThumbSize.cx;
    Bottom := Top + FThumbSize.cy;
  end;
  with FThumbPos2 do
  begin
    Top := Self.Height - FThumbSize.cy;
    Left := round(LogicalToScreen(FSelEnd) - FThumbSize.cx / 2);
    Right := Left + FThumbSize.cx;
    Bottom := Top + FThumbSize.cy;
  end;
end;

procedure TRangeSelector.WndProc(var Message: TMessage);
begin
  inherited;
  case Message.Msg of
    WM_SIZE:
      UpdateMetrics;
  end;
end;

procedure TRangeSelector.SetMax(Max: double);
begin
  if FMax <> Max then
  begin
    FMax := Max;
    UpdateMetrics;
    Paint;
  end;
end;

procedure TRangeSelector.SetMin(Min: double);
begin
  if FMin <> Min then
  begin
    FMin := Min;
    UpdateMetrics;
    Paint;
  end;
end;

procedure TRangeSelector.SetSelEnd(SelEnd: double);
begin
  if (FSelEnd <> SelEnd) and IsRealInInterval(SelEnd, FMin, FMax) then
  begin
    FSelEnd := SelEnd;
    if FSelStart > FSelEnd then
      FSelStart := FSelEnd;
    UpdateMetrics;
    Paint;
    if Assigned(FOnChange) then
      FOnChange(Self);
  end;
end;

procedure TRangeSelector.SetSelStart(SelStart: double);
begin
  if (FSelStart <> SelStart) and IsRealInInterval(SelStart, FMin, FMax) then
  begin
    FSelStart := SelStart;
    if FSelStart > FSelEnd then
      FSelEnd := FSelStart;
    UpdateMetrics;
    Paint;
    if Assigned(FOnChange) then
      FOnChange(Self);
  end;
end;

procedure TRangeSelector.SetState(State: TRangeSelectorState);
begin
  if State <> FState then
  begin
    FState := State;
    Paint;
  end;
end;

end.

[RusMikle]

ViruZ
Доброе время суток,

пользую ZColorStringGrid на дельфях, сейчас есть проект на Лазаре где хотелось бы его использовать. Может адаптируете? Желательно чтоб и под линукс с маком можно было скомпилить.

Спасибо

[jsa]

Вот, нашёл в сети такой модуль, вроде работает. Может, кому пригодится

Огромное спасибо.
Пользовался RangeSelector на Delphi7 , но не смог задействовать тот компонент, и бросил это занятие. Искал аналог не нашел. А этот модуль получилось подключить.

[CynicRus]

Пример добавления картинок в ms word. Точно работает с 2007, но по идее должен работать и с остальными постарше. Берёт кучу картинок из каталога с картинками, добавляет в документ и сохраняет в этот же каталог с именем каталога. Lazarus 2.0 + FPC 3.0.4

Код: Выделить всё

unit main;

{$Mode objfpc}{$h+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ComObj, Variants,LazUTF8;

type

  { TMainForm }

  TMainForm = class(TForm)
    makeBtn: TButton;
    chBtn: TButton;
    DirDialog: TSelectDirectoryDialog;
    infoMemo: TMemo;
    PathEdit: TEdit;
    GroupBox1: TGroupBox;
    procedure chBtnClick(Sender: TObject);
    procedure makeBtnClick(Sender: TObject);
  private

  public
    procedure MakeReportFile(FileName: string);

  end;

var
  MainForm: TMainForm;
  repName: string;
  dirPath: string;

implementation

{$R *.lfm}

{ TMainForm }

function ExtractFilePathLast(aPath: string): string;
begin
  Result := Copy(aPath, aPath.LastIndexOf(DirectorySeparator) + 2);
end;

procedure TMainForm.chBtnClick(Sender: TObject);
begin
  if DirDialog.Execute then
  begin
    //infoMemo.Lines.Add(ExtractFilePathLast(DirDialog.FileName));
    dirPath := DirDialog.FileName;
    repName := ExtractFilePathLast(DirDialog.FileName) + '.docx';
    pathEdit.Text:=dirPath;
    //infoMemo.Lines.Add(repName);
  end;
end;

procedure TMainForm.makeBtnClick(Sender: TObject);
begin
  MakeReportFile(dirPath + '\' + repName);
end;

procedure TMainForm.MakeReportFile(FileName: string);
var
  MSWord,Doc :variant;
  FPath, SavePath: variant;
  SR: TSearchRec;
  DirList: TStrings;
  i: integer;
begin
  FPath := '';
  DirList := TStringList.Create;
  try
    try
      MsWord := CreateOleObject('Word.Application');
      MsWord.Visible := false;
    except
      Exception.Create('Error');
    end;
    MSWord.Documents.Add(EmptyParam, EmptyParam, EmptyParam, EmptyParam);
    infomemo.Lines.Add('Word запущен!');
    if FindFirst(dirPath+'/' + '*.*', faArchive, SR) = 0 then
    begin
      repeat
        DirList.Add(StringReplace(dirPath+'\'+ SR.Name, '/', '\',[rfReplaceAll, rfIgnoreCase])); //Fill the list
      until FindNext(SR) <> 0;
      FindClose(SR);
    end;
    infomemo.Lines.Add('Поиск файлов завершён!');
    for i := 0 to DirList.Count - 1 do
    begin
      infomemo.Lines.Add('Добавляю: ' + StringReplace(dirlist[i], '/', '\',[rfReplaceAll, rfIgnoreCase]));
      FPath := dirlist[i];
      MSWord.ActiveDocument.InlineShapes.AddPicture((FPath), false, true,EmptyParam);
    end;
    infomemo.Lines.Add('Файлы успешно добавлены!');
  finally
    SavePath := filename;
    //doc.SaveAs(Variant(filename));
    MSWord.ActiveDocument.SaveAs(SavePath);
    MSWord.Quit;
    DirList.Free;
    infomemo.Lines.Add('Отчёт успешно сохранен в: ' + filename);
  end;
end;