Archive
Ye old network snippets revisited
Lately I have been looking at some code for ordinary, average networking tasks. Simple stuff like “how do you get the workgroup name” or “how do you get the computer name”. Functions that should be fairly commonplace in our day and age. But there is a world of pain on the internet when it comes to snippets like this. Everyone makes mistakes so I’m not pointing any fingers, but a quick visit to MSDN unveils a horror of memory leaks, incompatible datatypes and code that will make your citrix administrator permanently ban you.
Here are some routines I updated (most of them collected here and there). Tested on Windows 8 and Windows 7 under Citrix.
class function TNetUtils.getUserName:String; var BufferSize: DWORD; pUser: PChar; begin // Extract default system-buffer size BufferSize := 0; winapi.Windows.GetUserName(nil, BufferSize); // Allocate string to match system buffer pUser := StrAlloc(BufferSize); try if winapi.Windows.GetUserName(pUser, BufferSize) then result := pUser; finally StrDispose(pUser); end; end; class function TNetUtils.getDomainController:String; var BufPtr: PChar; begin BufPtr:=NIL; (* API reference material: msdn.microsoft.com/en-us/library/windows/desktop/aa370420(v=vs.85).aspx *) if netGetDCName(nil,nil,BufPtr)=NERR_SUCCESS then Begin try Result := BufPtr; finally NetApiBufferFree(BufPtr); end; end; end; class function TNetUtils.getDomainController(Const aDomain:String):String; var BufPtr: PChar; begin if length(aDomain)>0 then Begin (* API reference material: msdn.microsoft.com/en-us/library/windows/desktop/aa370420(v=vs.85).aspx *) if NetGetDCName(nil,PChar(aDomain),BufPtr)=NERR_SUCCESS then Begin try Result := BufPtr; finally NetApiBufferFree(BufPtr); end; end; end else result:=getDomainController; end; class function TNetUtils.getComputerName:String; var mSize: DWord; mBuffer: PChar; begin (* API reference material: msdn.microsoft.com/en-us/library/windows/desktop/ms724295(v=vs.85).aspx *) mSize:=(MAX_COMPUTERNAME_LENGTH + 1) * SizeOf(WideChar); (* Allocate buffer *) mBuffer:=allocmem(mSize); try (* Get the computer name *) if winapi.Windows.GetComputerName(mBuffer, mSize) then result:=mBuffer; finally freeMem(mBuffer); end; end; class function TNetUtils.getWorkGroupName:String; var Info: P_WKSTA_INFO_100; begin setLength(result,0); (* API reference material: msdn.microsoft.com/en-us/library/windows/desktop/aa370663(v=vs.85).aspx *) if NetWkstaGetInfo(NIL,100,info)=NERR_SUCCESS then Begin try result:=info.wki100_langroup; finally NetApiBufferFree(info); end; end; end; class function TNetUtils.getUserDomain:string; begin result:=getUserDomain(getUserName); end; class function TNetUtils.getUserDomain(aUserName:String):String; const DNLEN = 255; var sid : PSID; sidSize : DWORD; sidNameUse : DWORD; domainNameSize : DWORD; domainName : array[0..DNLEN] of char; vlSize : ^DWORD; begin aUsername:=Trim(aUserName); if length(aUserName)<1 then raise Exception.Create ('Unable to extract domain, username was empty'); domainNameSize := DNLEN + 1; sidNameUse := SidTypeUser; (* try the "proper" way *) sidSize := 65536; sid:=AllocMem(sidSize); try if LookupAccountName(nil, PChar(aUserName), sid, sidSize, domainName, domainNameSize, sidNameUse) then Result:=StrPas(domainName); finally FreeMem(sid); end; (* Fallback mechanism, check environment variables *) if length(result)<1 then Begin New(vlSize); try vlSize^ := 1024; ExpandEnvironmentStrings(PChar('%USERDOMAIN%'), domainName, vlSize^); Result := domainName; finally Dispose(vlSize); end; end; end;
And some updated declarations which doesnt mix ansi and widestring into a nest of pigs:
type P_WKSTA_INFO_100 = ^T_WKSTA_INFO_100; _WKSTA_INFO_100 = record wki100_platform_id: DWORD; wki100_computername: PChar; wki100_langroup: PChar; wki100_ver_major: DWORD; wki100_ver_minor: DWORD; end; T_WKSTA_INFO_100 = _WKSTA_INFO_100; function NetApiBufferAllocate (ByteCount: DWORD; var Buffer:Pointer):DWORD; stdcall; external 'netapi32.dll'; function NetApiBufferFree (Buffer: Pointer): DWORD; stdcall;external 'netapi32.dll'; function NetGetDCName (servername:PChar; domainname:PChar; var bufptr):DWORD; stdcall; external 'netapi32.dll'; Function NetWkstaGetInfo (ServerName : PChar; Level : DWORD; var BufPtr) : DWord; Stdcall; external 'netapi32.dll';
Virtual canvas
Ever wanted to simplify polygon creation? Perhaps add functions like line, circle and rectangle?
Well I decided to slap together a simple bare-bones virtual canvas that basically draws into an array of TPoints.
Just for fun i also included functions to rotate the resulting point buffer (which is cool but not that useful).
Also, I added two modes of drawing: the first plots everything, the second stores each drawing operation as a list of instructions.
The plan is that if you want to draw the result to a TCanvas, then we can use the native TCanvas methods to render it more correctly.
Have fun!
unit vcanvas; interface uses System.SysUtils, System.Classes, Vcl.Graphics, System.Math, System.Types,System.Generics.Collections; const CNT_VCAN_PLOT = 1; CNT_VCAN_LINE = 2; CNT_VCAN_POLY = 3; CNT_VCAN_RECT = 4; type TVirtualCanvasOpCode = Record coCode: Integer; coV1: Real; coV2: Real; coData: Array of TPoint; Constructor Create(const aInstr:Integer; const aValues:Array of TPoint);overload; constructor Create(const aInstr:Integer; const v1:real; const aValues:Array of TPoint);overload; Constructor Create(const aInstr:Integer; const V1,V2:Real; const aValues:Array of TPoint);overload; End; TVirtualCanvas = Class(TObject) private FStack: TList<TPoint>; FInstr: TList<TVirtualCanvasOpCode>; FOverlap: Boolean; FOps: Boolean; protected procedure AddItem(const aLeft,aTop:Integer);overload; procedure AddItem(const aItem:TPoint);overload; public Property UseOps:Boolean read FOps write FOps default false; Property Overlapping:boolean read FOverlap write FOverlap default true; Property Items:TList<TPoint> read FStack; Procedure Plot(const aLeft,aTop:Integer);overload; Procedure Plot(const aPoint:TPoint);overload; Procedure Line(const x1,y1,x2,y2:Integer);overload; procedure Line(const aStart,aStop:TPoint);overload; Procedure Rectangle(const cx,cy,wd,hd:Integer;const aAngle:Integer=0); Procedure DrawTo(Const aCanvas:TCanvas); Procedure Polygon(const aPoints:Array of TPoint); Procedure Circle(cx,cy,radius:Integer); function Bounds:TRect; function FindCenter:TPoint; Procedure Rotate(angle:integer); Procedure Scale(factor:Real); Constructor Create;virtual; Destructor Destroy;Override; End; implementation //########################################################################## // TVirtualCanvasOpCode //########################################################################## Constructor TVirtualCanvasOpCode.Create(const aInstr:Integer; const aValues:Array of TPoint); var x: Integer; mLen: Integer; Begin coCode:=aInstr; coV1:=0.0; coV2:=0.0; mLen:=length(aValues); setLength(coData,mLen); for x:=0 to mLen-1 do coData[x]:=aValues[x]; end; constructor TVirtualCanvasOpCode.Create(const aInstr:Integer; const v1:real; const aValues:Array of TPoint); var x: Integer; mLen: Integer; Begin coCode:=aInstr; coV1:=v1; coV2:=0.0; mLen:=length(aValues); setLength(coData,mLen); for x:=0 to mLen-1 do coData[x]:=aValues[x]; end; Constructor TVirtualCanvasOpCode.Create(const aInstr:Integer; const V1,V2:Real; const aValues:Array of TPoint); var x: Integer; mLen: Integer; Begin coCode:=aInstr; coV1:=V1; coV2:=V2; mLen:=length(aValues); setLength(coData,mLen); for x:=0 to mLen-1 do coData[x]:=aValues[x]; end; //########################################################################## // TVirtualCanvas //########################################################################## Constructor TVirtualCanvas.Create; Begin inherited; FStack:=TList<TPoint>.Create; FInstr:=TList<TVirtualCanvasOpCode>.Create; end; Destructor TVirtualCanvas.Destroy; Begin FStack.free; FInstr.Free; inherited; end; function TVirtualCanvas.Bounds:TRect; var pt : TPoint; begin if FStack.Count>0 then Begin pt:=FStack[0]; Result.Left := pt.X; Result.Top := pt.Y; Result.Right := pt.X; Result.Bottom := pt.Y; for pt in FStack do Begin if pt.X<Result.Left then Result.Left := pt.X else if pt.X>Result.Right then Result.Right := pt.X; if pt.Y<Result.Top then Result.Top := pt.Y else if pt.Y>Result.Bottom then Result.Bottom := pt.Y; end; end; end; function TVirtualCanvas.FindCenter:TPoint; var mBounds: TRect; Begin if FStack.Count>0 then result:=Bounds.CenterPoint else result:=TPoint.Create(-1,-1); end; procedure TVirtualCanvas.Scale(factor:Real); var i : Integer; dx, dy : Real; mItem: TPoint; mCenter: TPoint; begin mCenter:=FindCenter; dx := mCenter.X * (1.0-factor); dy := mCenter.Y * (1.0-factor); for i := 0to FStack.Count-1 do begin FStack.Items[i]:=TPoint.Create(Round( FStack[i].X * factor + dx ), Round( FStack[i].Y * factor + dy )); end; end; Procedure TVirtualCanvas.Rotate(angle: integer); var i : Integer; c, s, dx, dy : Real; mCenter: TPoint; begin if FStack.Count>0 then Begin angle:=EnsureRange(angle,0,360); mCenter:=FindCenter; c := cos(angle * PI / 180); s := sin(angle * PI / 180); for i := 0 to FStack.Count-1 do begin dx := FStack[i].X - mCenter.X; dy := FStack[i].Y - mCenter.Y; FStack.Items[i]:=TPoint.Create(Round(mCenter.X + dx*c - dy*s), Round(mCenter.Y + dx*s + dy*c)); end; end; end; Procedure TVirtualCanvas.DrawTo(Const aCanvas:TCanvas); var x: Integer; mInstr: TVirtualCanvasOpCode; Begin if assigned(aCanvas) then Begin if not FOps then Begin for x:=0 to FStack.Count-1 do aCanvas.Pixels[FStack[x].X,FStack[x].Y]:=aCanvas.Pen.Color; end else Begin for x:=0 to FInstr.Count-1 do Begin mInstr:=FInstr[x]; case mInstr.coCode of CNT_VCAN_PLOT: Begin aCanvas.Pixels[mInstr.coData[0].X,mInstr.coData[0].Y]:=aCanvas.Pen.Color; end; CNT_VCAN_LINE: Begin aCanvas.MoveTo(mInstr.coData[0].X,mInstr.coData[0].Y); aCanvas.LineTo(mInstr.coData[1].X,mInstr.coData[1].Y); end; CNT_VCAN_POLY: Begin aCanvas.Polygon(mInstr.coData); end; CNT_VCAN_RECT: Begin //VCL has no rotated rectangle aCanvas.Polygon(mInstr.coData); end; end; end; end; end; end; procedure TVirtualCanvas.AddItem(const aLeft,aTop:Integer); var mPoint: TPoint; mIndex: Integer; Begin if not FOverlap then Begin (* Only add point if not already in stack *) mPoint:=TPoint.Create(aLeft,aTop); mIndex:=FStack.IndexOf(mPoint); if mIndex<0 then FStack.Add(TPoint.Create(aleft,atop)); end else FStack.Add(TPoint.Create(aleft,atop)); end; procedure TVirtualCanvas.AddItem(const aItem:TPoint); var mIndex: Integer; Begin if not FOverlap then Begin (* Only add point if not already in stack *) mIndex:=FStack.IndexOf(aItem); if mIndex<0 then FStack.Add(aItem); end else FStack.Add(aItem); end; Procedure TVirtualCanvas.Plot(const aLeft,aTop:Integer); Begin if not FOps then AddItem(aLeft,aTop) else FInstr.Add(TVirtualCanvasOPCode.Create(CNT_VCAN_PLOT, [TPoint.Create(aLeft,aTop)])); end; Procedure TVirtualCanvas.Plot(const aPoint:TPoint); Begin if not FOps then AddItem(aPoint) else FInstr.Add(TVirtualCanvasOPCode.Create(CNT_VCAN_PLOT,[aPoint])); end; Procedure TVirtualCanvas.Line(const x1,y1,x2,y2:Integer); var Lpixel, LMaxAxisLength: integer; LRatio: Real; dx,dy:Integer; begin if not FOps then Begin LMaxAxisLength := Max(abs(x1 - x2), abs(y1 - y2)); for Lpixel := 0 to LMaxAxisLength do begin LRatio := Lpixel / LMaxAxisLength; dx:=x1 + Round((x2 - x1) * LRatio); dy:=y1 + Round((y2 - y1) * LRatio); AddItem(dx,dy); end; end else FInstr.Add(TVirtualCanvasOPCode.Create(CNT_VCAN_LINE, [TPoint.Create(x1,y1),TPoint.Create(x2,y2)])); end; procedure TVirtualCanvas.Line(const aStart,aStop:TPoint); Begin if not FOps then Line(aStart.X,aStart.Y,aStop.X,aStop.Y) else FInstr.Add(TVirtualCanvasOPCode.Create(CNT_VCAN_LINE, [aStart,aStop])); end; Procedure TVirtualCanvas.Circle(cx: Integer; cy: Integer; radius: Integer); var xpos,ypos: Integer; Pix, Pixels: Integer; x: Real; begin if radius>0 then Begin Pixels := Round( 2 * Radius * PI); for pix := 0 to Pixels-1 do begin x := 360 * pix / Pixels; xpos:=(round(cx + sin(x*pi/180)*radius)); ypos:=(round(cy + cos(x*pi/180)*radius)); self.AddItem(xpos,ypos); end; end; end; Procedure TVirtualCanvas.Polygon(const aPoints:Array of TPoint); var mLen: Integer; mIndex: Integer; Begin mLen:=length(aPoints); if mLen>0 then Begin if not FOps then Begin case mLen of 1: AddItem(aPoints[0]); 2: Line(aPoints[0],aPoints[1]); else begin for mIndex:=1 to mLen-1 do Line(aPoints[mIndex-1],aPoints[mIndex]); Line(aPoints[mLen-1],aPoints[0]); end; end; end else FInstr.Add(TVirtualCanvasOPCode.Create(CNT_VCAN_POLY,aPoints)); end; end; Procedure TVirtualCanvas.Rectangle(const cx,cy,wd,hd:Integer; const aAngle:Integer=0); var x1,y1,x2,y2,x3,y3,x4,y4:integer; radius,theta2:real; mAngle: Real; begin if (wd>0) and(hd>0) then Begin mAngle:=EnsureRange(aAngle,0,360) * PI / 180; radius:=sqrt(sqr(wd/2)+sqr(hd/2)); theta2:=arctan(hd/wd); x1:=round(cx-radius*cos(theta2+mAngle)); y1:=round(cy-radius*sin(theta2+mAngle)); x2:=round(cx+radius*cos(theta2-mAngle)); y2:=round(cy-radius*sin(theta2-mAngle)); x3:=round(cx+radius*cos(theta2+mAngle)); y3:=round(cy+radius*sin(theta2+mAngle)); x4:=round(cx-radius*cos(theta2-mAngle)); y4:=round(cy+radius*sin(theta2-mAngle)); if not FOps then polygon([TPoint.Create(x1,y1), TPoint.Create(x2,y2), TPoint.Create(x3,y3), TPoint.Create(x4,y4)]) else Begin FInstr.Add(TVirtualCanvasOpCode.Create(CNT_VCAN_RECT,aAngle, [TPoint.Create(x1,y1), TPoint.Create(x2,y2), TPoint.Create(x3,y3), TPoint.Create(x4,y4)])); end; end; end; end.
Handle messages without forms?
Want to handle messages without creating an actual form? Send messages between a thread and your main app? Or just impress your friends by using messages to communicate between forms? This is a very handy class that i’ve used over the years. Just override “HandleMessage” to intercept and process your own messages (ps: dispatch is your friend).
TMessageHandler = Class(TObject) private FHandle: HWND; protected Property Handle:HWND read FHandle; Procedure HandleMessage(var message:TMessage);virtual; public Constructor Create;virtual; Destructor Destroy;Override; End; constructor TMessageHandler.Create; begin inherited Create; FHandle:=AllocateHWnd(HandleMessage); end; destructor TMessageHandler.Destroy; begin DeallocateHWnd(FHandle); inherited; end; procedure TMessageHandler.HandleMessage(var Message:TMessage); begin Message.Result := DefWindowProc(FHandle, Message.Msg, Message.wParam, Message.lParam); end;
Delayed non-blocking callback function
In my previous post regarding a delayed callback function under Delphi I should have pointed out that it was coded for a form-based environment. Meaning that it allows the GUI to remain responsive and other events to fire by calling application.processmessages at a regular intervals. It was indeed “blocking” in the sense that it also functions as a friendly alternative to the sleep API function.
For a complete non-blocking solution, one that truly “calls back later”, more or less a replica of the Smart Pascal callback (which essentially is the JavaScript callback), we have to add a bit more. Here is a minimalistic version of a OS friendly callback function:
unit w3callback; interface uses System.SysUtils, Winapi.Windows, System.Generics.Collections; procedure w3_callback(const aCallback:TProc;ms:Integer); implementation var _LUT: TDictionary<UINT,TProc>; procedure w3_callback(const aCallback:TProc;ms:Integer); procedure w3_invoke(hwnd: HWND; uMsg: UINT; idEvent: UINT_PTR;dwTime: DWORD);stdcall; var mProc: TProc; begin KillTimer(0,idEvent); if assigned(_LUT) then begin mproc:=_lut.Items[idEvent]; _lut.Remove(idEvent); if assigned(mProc) then mproc; end; end; begin if Assigned(_LUT) then _LUT.add(SetTimer(0,0,ms,@w3_invoke),aCallback); end; initialization _LUT:=TDictionary<UINT,TProc>.Create; finalization if Assigned(_LUT) then FreeAndNil(_LUT); end.
Delphi delayed callback function
When I wrote the Smart Mobile Studio RTL I added a handy function for delayed callback. Under JavaScript this is very easy to achieve and it’s also an important part of an environment that is based on events. In JavaScript everything is about events and all data is received in a non-blocking manner.
But the function is equally handy under Delphi, especially if you want something to execute “after im done with this”. It can be anything from displaying a hint on a form, to start loading data just a few seconds later. Or if you just want to add a form-friendly delay.
NOTE: This code has been replaced by a “non blocking” callback method, click here to view the latest post!
Here is the Delphi implementation of Smart Pascal’s w3_callback function (with a twist).
Note: This function is semi-blocking in the sense that it will halt execution inside the running procedure – but still allow the GUI to be responsive and events to fire. The alternative would be to spawn a thread with a synchronized re-entry.
Procedure w3_Callback(const aCallback:TProc; const ms:Integer); var mCount: Integer; mThen: TDateTime; begin if assigned(application) and not application.Terminated then Begin try mCount:=0; mThen:=dateutils.IncMilliSecond(now,ms); repeat Sleep(0); Inc(mCount); if (mCount mod 600)=599 then begin if Assigned(Application) and not (application.Terminated) then application.ProcessMessages else break; end; until CompareDateTime(Now,mThen)>=0; if Assigned(Application) and not (application.Terminated) and Assigned(aCallback) then aCallback; except on exception do; end; end; end;
How do you use it? With anonymous procedures ofcourse, like this:
w3_Callback( procedure () begin showmessage('Your helmet is ready lord vader'); end, 1000);
Recent
The vatican vault
- January 2022
- October 2021
- March 2021
- November 2020
- September 2020
- July 2020
- June 2020
- April 2020
- March 2020
- February 2020
- January 2020
- November 2019
- October 2019
- September 2019
- August 2019
- July 2019
- June 2019
- May 2019
- April 2019
- March 2019
- February 2019
- January 2019
- December 2018
- November 2018
- October 2018
- September 2018
- August 2018
- July 2018
- June 2018
- May 2018
- April 2018
- March 2018
- February 2018
- January 2018
- December 2017
- November 2017
- October 2017
- August 2017
- July 2017
- June 2017
- May 2017
- April 2017
- March 2017
- February 2017
- January 2017
- December 2016
- November 2016
- October 2016
- September 2016
- August 2016
- July 2016
- June 2016
- May 2016
- April 2016
- March 2016
- January 2016
- December 2015
- November 2015
- October 2015
- September 2015
- August 2015
- June 2015
- May 2015
- April 2015
- March 2015
- February 2015
- January 2015
- December 2014
- November 2014
- October 2014
- September 2014
- August 2014
- July 2014
- June 2014
- May 2014
- April 2014
- March 2014
- February 2014
- January 2014
- December 2013
- November 2013
- October 2013
- September 2013
- August 2013
- July 2013
- June 2013
- May 2013
- February 2013
- August 2012
- June 2012
- May 2012
- April 2012
You must be logged in to post a comment.