Recent

Recent Posts

Pages: [1] 2 3 ... 10
1
Databases / Re: Azure sql database will not connect
« Last post by paweld on Today at 07:24:47 am »
Hi,
You need to install the previous version of msoledb: https://www.microsoft.com/en-us/download/details.aspx?id=56730
I misled a bit earlier, because the bitness of the driver is supposed to match the bitness of the operating system and not the application.
2
General / Re: Assign (textfile) not compiling - sometimes.
« Last post by bytebites on Today at 07:12:17 am »
Or use AssignFile and CloseFile procedures from the SysUtils.
3
Beginners / Re: Find child controls by name
« Last post by Handoko on Today at 04:17:05 am »
Done.

This demo below shows how to use FindChildControl as suggested by Josh and writing yourself a function for checking the existance of the control:

Code: Pascal  [Select][+][-]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, Forms, Controls, Dialogs, StdCtrls, ExtCtrls;
  9.  
  10. type
  11.  
  12.   { TForm1 }
  13.  
  14.   TForm1 = class(TForm)
  15.     btnFind: TButton;
  16.     Button1: TButton;
  17.     CheckBox1: TCheckBox;
  18.     Edit1: TEdit;
  19.     lbeName: TLabeledEdit;
  20.     Memo1: TMemo;
  21.     Panel1: TPanel;
  22.     RadioButton1: TRadioButton;
  23.     Shape1: TShape;
  24.     procedure btnFindClick(Sender: TObject);
  25.   end;
  26.  
  27. var
  28.   Form1: TForm1;
  29.  
  30. implementation
  31.  
  32. function HasControl(Container: TWinControl; const aName: string): Boolean;
  33. var
  34.   S: string;
  35.   i: Integer;
  36. begin
  37.   Result := False;
  38.   S := aName.ToUpper;
  39.   for i := 0 to Container.ControlCount-1 do
  40.   begin
  41.     if S = Container.Controls[i].Name.ToUpper then
  42.     begin
  43.       Result := True;
  44.       Exit;
  45.     end;
  46.   end;
  47. end;
  48.  
  49. {$R *.lfm}
  50.  
  51. { TForm1 }
  52.  
  53. procedure TForm1.btnFindClick(Sender: TObject);
  54. var
  55.   C: TControl;
  56.   S: string;
  57. begin
  58.   case HasControl(Panel1, lbeName.Text) of
  59.     True:
  60.       begin
  61.         C := Panel1.FindChildControl(lbeName.Text);
  62.         S := lbeName.Text + ' is found in Panel1.' + LineEnding +
  63.              'Class: ' +  C.ClassName              + LineEnding +
  64.              'Left: ' +   C.Left.ToString          + LineEnding +
  65.              'Top: ' +    C.Top.ToString           + LineEnding +
  66.              'Width: ' +  C.Width.ToString         + LineEnding +
  67.              'Height: ' + C.Height.ToString        + LineEnding;
  68.         ShowMessage(S);
  69.       end;
  70.     False:
  71.       ShowMessage(lbeName.Text + ' cannot be found in Panel1.');
  72.   end;
  73. end;
  74.  
  75. end.
4
Graphics / Demoscene The Champs Cracktro
« Last post by Gigatron on Today at 02:26:07 am »
Hi , late at night i woul like to share one of my new project;

The champs cracktro made wit LP;

In the past i made it with gdscript with Godot ;

https://www.youtube.com/watch?v=8ePm_udSYV4

Code with LP : missing font ... but i am working ;

Code: Pascal  [Select][+][-]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
  9.   BGLVirtualScreen, BGRAOpenGL, BGRABitmap,
  10.   BGRABitmapTypes;
  11.  
  12. const
  13.   StarCount = 400;
  14.   MaxSpeed  = 3;
  15.  
  16. type
  17.   TStar = record        //  Stars
  18.     X, Y, Z: Double;
  19.     Speed:   Double;
  20.   end;
  21.  
  22.   { TForm1 }
  23.  
  24.   TForm1 = class(TForm)
  25.     BGLVirtualScr: TBGLVirtualScreen;
  26.     Timer1: TTimer;
  27.     procedure BGLVirtualScrRedraw(Sender: TObject; BGLContext: TBGLContext);
  28.     procedure BGLVirtualScrUnloadTextures(Sender: TObject; BGLContext: TBGLContext);
  29.     procedure FormCreate(Sender: TObject);
  30.     procedure FormShow(Sender: TObject);
  31.     procedure Timer1Timer(Sender: TObject);
  32.  
  33.     private
  34.  
  35.     Stars  : array of TStar;
  36.     a_logo, bg_copper      : IBGLTexture;
  37.     one,nine,eight,eight_2 : IBGLTexture;
  38.  
  39.     private
  40.  
  41.     const cop_col:Array[0..245] of String =('#000066','#000055','#000044','#000033','#000022','#000011','#000011','#000022','#000033',
  42.                                             '#000044','#000055','#000066','#000077','#000088','#000099','#0000aa','#0000bb','#0000cc',
  43.                                             '#0000dd','#0000ee','#0000ff','#1111ff','#2222ff','#3333ff','#4444ff','#5555ff','#6666ff',
  44.                                             '#7777ff','#8888ff','#9999ff','#aaaaff','#bbbbff','#ccccff','#ddddff','#eeeeff','#eeffff',
  45.                                             '#ffffff','#ffffff','#eeffff','#eeeeff','#ddddff','#ccccff','#bbbbff','#aaaaff','#9999ff',
  46.                                             '#8888ff','#7777ff','#6666ff','#5555ff','#4444ff','#3333ff','#2222ff','#1111ff','#0000ff',
  47.                                             '#0000ee','#0000dd','#0000cc','#0000bb','#0000aa','#000099','#000088','#000077','#000066',
  48.                                             '#000055','#000044','#000033','#000022','#000011','#000022','#000033','#000044','#000055',
  49.                                             '#000066','#000077','#000088','#000099','#0000aa','#0000bb','#0000cc','#0000dd','#0000ee',
  50.                                             '#0000ff','#1111ff','#2222ff','#3333ff','#4444ff','#5555ff','#6666ff','#7777ff','#8888ff',
  51.                                             '#9999ff','#aaaaff','#bbbbff','#ccccff','#ddddff','#eeeeff','#eeffff','#ffffff','#ffffff',
  52.                                             '#eeffff','#eeeeff','#ddddff','#ccccff','#bbbbff','#aaaaff','#9999ff','#8888ff','#7777ff',
  53.                                             '#6666ff','#5555ff','#4444ff','#3333ff','#2222ff','#1111ff','#0000ff','#0000ee','#0000dd',
  54.                                             '#0000cc','#0000bb','#0000aa','#000099','#000088','#000077','#000066','#000055','#000044',
  55.                                             '#000033','#000022','#000011','#000011','#000022','#000033','#000044','#000055','#000066',
  56.                                             '#000077','#000088','#000099','#0000aa','#0000bb','#0000cc','#0000dd','#0000ee','#0000ff',
  57.                                             '#1111ff','#2222ff','#3333ff','#4444ff','#5555ff','#6666ff','#7777ff','#8888ff','#9999ff',
  58.                                             '#aaaaff','#bbbbff','#ccccff','#ddddff','#eeeeff','#eeffff','#ffffff','#ffffff','#eeffff',
  59.                                             '#eeeeff','#ddddff','#ccccff','#bbbbff','#aaaaff','#9999ff','#8888ff','#7777ff','#6666ff',
  60.                                             '#5555ff','#4444ff','#3333ff','#2222ff','#1111ff','#0000ff','#0000ee','#0000dd','#0000cc',
  61.                                             '#0000bb','#0000aa','#000099','#000088','#000077','#000066','#000055','#000044','#000033',
  62.                                             '#000022','#000011','#000022','#000033','#000044','#000055','#000066','#000077','#000088',
  63.                                             '#000099','#0000aa','#0000bb','#0000cc','#0000dd','#0000ee','#0000ff','#1111ff','#2222ff',
  64.                                             '#3333ff','#4444ff','#5555ff','#6666ff','#7777ff','#8888ff','#9999ff','#aaaaff','#bbbbff',
  65.                                             '#ccccff','#ddddff','#eeeeff','#eeffff','#ffffff','#ffffff','#eeffff','#eeeeff','#ddddff',
  66.                                             '#ccccff','#bbbbff','#aaaaff','#9999ff','#8888ff','#7777ff','#6666ff','#5555ff','#4444ff',
  67.                                             '#3333ff','#2222ff','#1111ff','#0000ff','#0000ee','#0000dd','#0000cc','#0000bb','#0000aa',
  68.                                             '#000099','#000088','#000077');
  69.  
  70.   // Sin table Ripped by Gigatron Winuae Debugger; x first 255 , y after 256 to 512 !!
  71.   const sprite_dat : Array[0..511] of integer = (80,80,81,83,86,90,94,99,104,110,116,123,130,137,145,152,159,167,173,180,186,192,197,
  72.                                                  202,206,209,212,214,215,216,216,216,214,213,210,208,205,201,197,193,189,185,181,177,
  73.                                                  173,169,166,162,160,157,155,153,152,151,151,151,151,152,153,155,156,158,160,162,164,
  74.                                                  166,168,170,171,172,173,174,174,174,173,172,170,168,166,163,160,156,152,148,143,139,
  75.                                                  134,129,125,120,116,112,108,105,102,100,98,97,97,97,98,100,102,106,109,114,119,125,131,
  76.                                                  137,144,151,159,166,174,182,189,196,203,209,215,221,226,230,233,236,238,239,239,238,237,
  77.                                                  235,232,228,224,219,214,208,202,195,188,181,174,167,160,154,147,141,135,130,125,121,118,
  78.                                                  115,112,111,110,109,109,110,112,113,116,118,121,124,128,131,135,139,142,146,149,152,155,
  79.                                                  157,159,161,162,163,163,163,163,162,161,160,158,156,154,152,150,148,146,144,142,141,139,
  80.                                                  139,138,138,139,139,141,143,145,148,151,155,159,163,168,173,178,183,188,194,199,204,208,
  81.                                                  212,216,220,222,225,226,227,227,227,225,223,221,217,213,208,203,197,190,183,176,169,161,
  82.                                                  153,145,138,130,123,116,110,104,99,94,90,87,84,83,82,86,82,79,75,72,68,65,62,60,57,55,54,
  83.                                                  53,52,51,51,51,52,53,54,55,57,59,62,64,67,69,72,75,78,81,83,86,89,91,93,95,97,98,99,100,
  84.                                                  101,101,102,101,101,101,100,99,98,97,96,95,94,92,91,90,89,88,87,87,86,86,86,86,86,87,88,
  85.                                                  88,89,90,92,93,94,96,97,99,100,101,102,103,104,105,105,105,105,105,104,103,102,100,98,96,
  86.                                                  94,92,89,86,83,80,77,74,71,68,65,63,60,58,56,54,52,51,50,50,50,50,50,51,53,55,57,59,62,65,
  87.                                                  68,71,75,78,82,86,89,93,97,100,103,106,109,111,114,115,117,118,119,119,119,119,119,118,116,
  88.                                                  115,113,111,109,107,104,102,99,96,94,91,89,86,84,82,80,79,77,76,75,75,74,74,74,75,75,76,76,
  89.                                                  77,78,79,80,81,82,83,84,85,86,87,87,87,87,87,87,86,86,85,84,82,81,80,78,76,75,73,72,70,69,67,
  90.                                                  66,65,65,64,64,64,64,65,66,67,68,70,72,74,77,80,83,86,89,92,95,98,102,105,108,111,113,116,118,
  91.                                                  120,121,122,123,124,124,123,123,121,120,118,116,114,111,108,105,101,98,94,91);
  92.  
  93.     procedure InitializeStarfield;
  94.     procedure UpdateStarfield;
  95.  
  96.   public
  97.  
  98.   end;
  99.  
  100. var
  101.   Form1: TForm1;
  102.  
  103.   hexColor: string;
  104.   red, green, blue: Byte;
  105.   pause : integer;
  106.   j: integer;
  107.  
  108.   // sprite  vars
  109.  
  110.   xx,yy,nx,ny,ex,ey,exx,eyy : integer;
  111.  
  112. implementation
  113.  
  114. {$R *.lfm}
  115.  
  116. { TForm1 }
  117.  
  118. procedure TForm1.FormCreate(Sender: TObject);
  119. begin
  120.   Randomize;
  121.   InitializeStarfield;
  122.   j:=0;
  123.   pause := 0;
  124.  // sprite var initialisation one,nine,eight * 2
  125.   xx :=0;
  126.   yy := 256;
  127.   nx := 6;
  128.   ny := 256+6;
  129.   ex := 12;
  130.   ey := 256+12;
  131.   exx:= 18;
  132.   eyy:= 256+18;
  133.  
  134.  
  135. end;
  136.  
  137. procedure TForm1.FormShow(Sender: TObject);
  138. begin
  139.         bg_copper := BGLTexture('bg_copper.png');
  140.         a_logo := BGLTexture('champs_logo.png');
  141.  
  142.         one     := BGLTexture('one.png');
  143.         nine    := BGLTexture('nine.png');
  144.         eight   := BGLTexture('eight.png');
  145.         eight_2 := BGLTexture('eight_2.png');
  146.  
  147.  
  148. end;
  149.  
  150. procedure TForm1.InitializeStarfield;
  151. var
  152.   i: Integer;
  153. begin
  154.   SetLength(Stars, StarCount); // Nombre d'étoiles
  155.   for i := 0 to High(Stars) do
  156.   begin
  157.     Stars[i].X := Random(ClientWidth);
  158.     Stars[i].Y := (60+Random(ClientHeight-140));
  159.     Stars[i].Speed := Random * 2 + 1; // Vitesse aléatoire
  160.   end;
  161. end;
  162.  
  163. procedure TForm1.UpdateStarfield;
  164. var
  165.   i : integer;
  166. begin
  167.   for i := 0 to High(Stars) do
  168.   begin
  169.      Stars[i].X := Stars[i].X + Stars[i].Speed*3 ;
  170.  
  171.     if Stars[i].X > ClientWidth then // Réinitialiser la position si l'étoile sort de l'écran
  172.     begin
  173.       Stars[i].X := 0;
  174.       Stars[i].Y := (60+Random(ClientHeight-140));
  175.       Stars[i].Speed := Random * 2 + 1;
  176.  
  177.     end;
  178.   end;
  179. end;
  180.  
  181. procedure HexToRGB(hex: string; var r, g, b: Byte);
  182. begin
  183.   r := StrToInt('$' + Copy(hex, 2, 2));
  184.   g := StrToInt('$' + Copy(hex, 4, 2));
  185.   b := StrToInt('$' + Copy(hex, 6, 2));
  186. end;
  187.  
  188.  
  189. procedure TForm1.BGLVirtualScrRedraw(Sender: TObject; BGLContext: TBGLContext);
  190. var
  191.   i : integer;
  192.   StarPosition: TPoint;
  193.   sttype : Int16 ;
  194.   col: TColor;
  195.  
  196. begin
  197.  
  198.  
  199.  
  200.     // draw logo and update Sf + 2 vertical raster bars
  201.   BGLCanvas.StretchPutImage(0,0,640,480, bg_copper);
  202.   // stars
  203.   for i := 0 to High(Stars) do
  204.   begin
  205.  
  206.     StarPosition.X := Round(Stars[i].X );
  207.     StarPosition.Y := Round(Stars[i].Y);
  208.     sttype := Round(Stars[i].Speed);
  209.  
  210.     col := RGBToColor(50,50,50);
  211.     // stars bitplanes colors
  212.     case  (sttype)  of
  213.       1: col := RGBToColor(50,50,50);
  214.       2: col := RGBToColor(238,238,238);
  215.       3: col := RGBToColor(100,136,255);
  216.       4: col := RGBToColor(125,125,125);
  217.       5: col := RGBToColor(150,150,150);
  218.       6: col := RGBToColor(175,175,175);
  219.       7: col := RGBToColor(200,200,200);
  220.       8: col := RGBToColor(254,254,254);
  221.  
  222.     end;
  223.       BGLContext.Canvas.Rectangle(StarPosition.X, StarPosition.Y,StarPosition.X+1,StarPosition.Y+1,col);
  224.   end;
  225.  
  226.   // raster bars cycle colors with pause like A-Team intro
  227.   for i := 0 to 31 do
  228.   begin
  229.        hexColor := cop_col[i+j];
  230.        HexToRGB(hexColor, red, green, blue);
  231.        BGLContext.Canvas.FillRect(0,370+i*2,640,370+i*2-4,RGBToColor(red,green,blue));
  232.  
  233.   end;
  234.  
  235.   inc(pause);
  236.    if (pause>=3) then
  237.    begin
  238.        inc(j);
  239.        pause := 0;
  240.        if(j>=184) then j:=0;
  241.  
  242.     end;
  243.  
  244.   BGLCanvas.PutImage(0,50,a_logo,255);    // champs 1988
  245.  
  246.   // sprites
  247.  
  248.   // sin table ...
  249.  
  250.    BGLCanvas.StretchPutImage(-30+sprite_dat[xx]*2 ,-20+sprite_dat[yy]*2,32,32,eight);
  251.    BGLCanvas.StretchPutImage(-30+sprite_dat[nx]*2 ,-20+sprite_dat[ny]*2,32,32,eight);
  252.    BGLCanvas.StretchPutImage(-30+sprite_dat[ex]*2 ,-20+sprite_dat[ey]*2,32,32,nine);
  253.    BGLCanvas.StretchPutImage(-30+sprite_dat[exx]*2 ,-20+sprite_dat[eyy]*2,32,32,one);
  254.  
  255.  
  256.    BGLCanvas.StretchPutImage(-10+sprite_dat[xx]*2 ,322,32,32,eight);
  257.    BGLCanvas.StretchPutImage(-10+sprite_dat[nx]*2 ,322,32,32,eight);
  258.    BGLCanvas.StretchPutImage(-10+sprite_dat[ex]*2 ,322,32,32,nine);
  259.    BGLCanvas.StretchPutImage(-10+sprite_dat[exx]*2 ,322,32,32,one);
  260.  
  261.    // limites les boucles
  262.  
  263.  
  264.     inc(exx);
  265.     inc(eyy);
  266.     if(exx>=255) then exx :=0;
  267.     if(eyy>=511) then eyy :=256;
  268.  
  269.     inc(ex);
  270.     inc(ey);
  271.     if(ex>=255) then ex :=0;
  272.     if(ey>=511) then ey :=256;
  273.  
  274.     inc(nx);
  275.     inc(ny);
  276.     if(nx>=255) then nx :=0;
  277.     if(ny>=511) then ny :=256;
  278.  
  279.     inc(xx);
  280.     inc(yy);
  281.     if(xx>=255) then xx :=0;
  282.     if(yy>=511) then yy :=256;
  283.  
  284.  
  285.   UpdateStarfield;
  286.  
  287.  
  288.  
  289. end;
  290.  
  291. procedure TForm1.BGLVirtualScrUnloadTextures(Sender: TObject; BGLContext: TBGLContext);
  292. begin
  293.  
  294.   bg_copper := nil;
  295.   a_logo    := nil;
  296.  
  297.   one       := nil;
  298.   nine      := nil;
  299.   eight     := nil;
  300.   eight_2   := nil;
  301.  
  302. end;
  303.  
  304.  
  305.  
  306. procedure TForm1.Timer1Timer(Sender: TObject);
  307. begin
  308.  
  309.   BGLVirtualScr.Repaint;
  310. end;
  311.  
  312. end.




5
General / Re: Linux Workspaces -- StayOnTop?
« Last post by dbannon on Today at 02:13:13 am »
In my App, I use a system tray icon that the user can use to "call" any open windows to what ever workspace is currently open.

I mention this because with the recent adoption of Wayland many of the X11 things we take fro granted are disappearing so, if you do find a solution that does what you want, make sure it works under wayland before you build it into your app.

Davo
6
Beginners / Re: Find child controls by name
« Last post by Joanna on Today at 02:03:50 am »
Quote
function FindControl(Handle: HWND): TWinControl;
C:\lazarus\lcl\controls.pp(2705,10)
Description
Return the TWinControl of the given Handle.
The result is very interface specific. Use FindOwnerControl when Handle may be a non-TWinControl handle.
im not sure how to use handle for a name
7
General / Re: Assign (textfile) not compiling - sometimes.
« Last post by teresa on Today at 01:56:13 am »
Thanks TRon - the code is  indeed in a button click event.

Good to be reminded!
8
General / Re: Assign (textfile) not compiling - sometimes.
« Last post by TRon on Today at 01:48:13 am »
replace
Quote from: teresa on Today at 01:44:26 am
Code: Pascal  [Select][+][-]
  1.    {$IFDEF debug}
  2.    assign(debugfile, 'overfs.debug'); // problem here
  3.    rewrite(debugfile);
  4.    {$ENDIF}
with
Code: Pascal  [Select][+][-]
  1.    {$IFDEF debug}
  2.    system.assign(debugfile, 'overfs.debug'); // problem here
  3.    rewrite(debugfile);
  4.    {$ENDIF}
Probably better to prefix all system related routines, just in case.

The issue is that the code is probably situated somewhere in a control/component/form and there (in that scope) assign means something else.
9
General / Assign (textfile) not compiling - sometimes.
« Last post by teresa on Today at 01:44:26 am »
Is there a bug in text file handling?  FPC 3.2.2, Lazarus 3.2 - recently updated.

I have a few hundred lines of code. In the global variables there is
Code: Pascal  [Select][+][-]
  1.    {$DEFINE debug}
  2.  
  3.    {$IFDEF debug}
  4.    debugfile: Text;
  5.    {$ENDIF}
and later:
Code: Pascal  [Select][+][-]
  1.    {$IFDEF debug}
  2.    assign(debugfile, 'overfs.debug'); // problem here
  3.    rewrite(debugfile);
  4.    {$ENDIF}
(I'm doing it this way because I need to collect a whole lot of data - more than I want to see in the debugger.)
   
The editor is perfectly happy to suggest completions for the assign - for example suggesting Assign(out t: text; const c: shortstring);

But the compiler has other ideas:
   
Code: Pascal  [Select][+][-]
  1. unit1.pp(343,36) Error: (3026) Wrong number of parameters specified for call to "Assign"
  2. /usr/local/lib/fpc/3.2.2/units/x86_64-linux/rtl/classes.ppu:persist.inc(104,23) Error: (5088) Found declaration: Assign(TPersistent);

(That declaration is the first in the list offered by the code editor. but not the one for today.)

I have worked around this issue with a stringlist, but what is happening? Enquiring minds etc.
10
General / Re: How to: create DLL file for Windows 10 64-Bit Pro
« Last post by KodeZwerg on Today at 12:57:56 am »
Here is my working testcode, no units included.
Code: Pascal  [Select][+][-]
  1. program project1;
  2.  
  3. {$APPTYPE CONSOLE}
  4.  
  5. type
  6.   LPCSTR = PAnsiChar;
  7.   DWORD = Cardinal;
  8.   ULONG_PTR = UInt64;
  9.   LongBool = False..Boolean(4294967295);
  10.   BOOL = LongBool;
  11.   THandle = {$IFDEF WIN32} Cardinal {$ENDIF} {$IFDEF WIN64} UInt64 {$ENDIF};
  12.   POverlapped = ^TOverlapped;
  13.   _OVERLAPPED = record
  14.     Internal: ULONG_PTR;
  15.     InternalHigh: ULONG_PTR;
  16.     Offset: DWORD;
  17.     OffsetHigh: DWORD;
  18.     hEvent: THandle;
  19.   end;
  20.   TOverlapped = _OVERLAPPED;
  21.   PSecurityAttributes = ^TSecurityAttributes;
  22.   _SECURITY_ATTRIBUTES = record
  23.     nLength: DWORD;
  24.     lpSecurityDescriptor: Pointer;
  25.     bInheritHandle: BOOL;
  26.   end;
  27.   TSecurityAttributes = _SECURITY_ATTRIBUTES;
  28.  
  29. const
  30.   GENERIC_WRITE = $40000000;
  31.   FILE_SHARE_READ = $00000001;
  32.   FILE_SHARE_WRITE = $00000002;
  33.   CREATE_NEW = 1;
  34.   OPEN_EXISTING = 3;
  35.   FILE_END = 2;
  36.   FILE_ATTRIBUTE_NORMAL = $00000080;
  37.   INVALID_HANDLE_VALUE = THandle(-1);
  38.  
  39. function WriteFile(hFile: THandle; const Buffer; nNumberOfBytesToWrite: DWORD; var lpNumberOfBytesWritten: DWORD; lpOverlapped: POverlapped): BOOL; stdcall; external 'kernel32.dll' name 'WriteFile';
  40. function CreateFileA(lpFileName: LPCSTR; dwDesiredAccess, dwShareMode: DWORD; lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; hTemplateFile: THandle): THandle; stdcall; external 'kernel32.dll' name 'CreateFileA';
  41. function SetFilePointer(hFile: THandle; lDistanceToMove: Longint; lpDistanceToMoveHigh: Pointer; dwMoveMethod: DWORD): DWORD; stdcall; external 'kernel32.dll' name 'SetFilePointer';
  42. function CloseHandle(hObject: THandle): BOOL; stdcall; external 'kernel32.dll' name 'CloseHandle';
  43.  
  44. procedure AppendToFile(const AFileName: string; AData: PAnsiChar);
  45. var
  46.   hFile: THandle;
  47.   cnt: Cardinal;
  48.   DataSize: Integer;
  49. begin
  50.   DataSize := StrLen(AData);
  51.   hFile := CreateFileA(PAnsiChar(AFileName), GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil,
  52.              OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  53.   if (hFile = INVALID_HANDLE_VALUE) then
  54.       hFile := CreateFileA(PAnsiChar(AFileName), GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil,
  55.                  CREATE_NEW, FILE_ATTRIBUTE_NORMAL, 0);
  56.   if (hFile <> INVALID_HANDLE_VALUE) then
  57.     begin
  58.       SetFilePointer(hFile, 0, nil, FILE_END);
  59.       WriteFile(hFile, AData^, DataSize, cnt, nil);
  60.       CloseHandle(hFile);
  61.     end;
  62. end;
  63.  
  64. begin
  65.   AppendToFile('test.txt', 'Hello World.');
  66.   ReadLn;
  67. end.
Pages: [1] 2 3 ... 10

TinyPortal © 2005-2018