Wednesday, January 30, 2008

WNet Enum Class

WNetEnumClass. This class implements the discovery of connected computers, drives, and printers, using the WNet functions.

TODO: Add an array of all TNetResources, and functions to allow their access from the calling app. Or more properly, functions that will return useful info from the TNetResources, simplifying the determination of device type, and so on.

USAGE:

var
Obj :TWNetEnumClass;
begin
Obj := TWNetEnumClass.Create(Self);
try
Obj.Refresh;
Memo1.Lines := Obj.GetAllNames;
Memo2.Lines := Obj.GetCompNames;
Memo3.Lines := Obj.GetDiskNames;
Memo4.Lines := Obj.GetDomainNames;
Memo5.Lines := Obj.GetErrors;
Memo6.Lines := Obj.GetPrintNames;
finally
Obj.Free;
end;
end;



unit uWNetEnumClass;

interface

uses
Classes, Sysutils, Windows;

type
TWNetEnumClass = class(TObject)
private
FslAllNames: TStringList;
FslCompNames: TStringList;
FslDiskNames: TStringList;
FslDomainNames: TStringList;
FslErrors: TStringList;
FslPrintNames: TStringList;
procedure ErrorHandler(errorNum: Cardinal; s: string);
function EnumerateResources(startingPoint: TNetResource): Boolean;
protected
procedure EnumResources;
public
constructor Create(Owner: TComponent); virtual;
destructor Destroys; virtual;

function GetAllNames: TStringList;
function GetCompNames: TStringList;
function GetDiskNames: TStringList;
function GetDomainNames: TStringList;
function GetErrors: TStringList;
function GetPrintNames: TStringList;

procedure Refresh; // used by calling apps to populate the lists
end;

implementation

{ TWNetEnumClass }

const
BASE_RES = 128;
MAX_RES = 8192;

var
// establish a buffer to use to prime the drill-down process
base_buffer: array of TNetResource;

constructor TWNetEnumClass.Create(Owner: TComponent);
begin
inherited Create;

SetLength(base_buffer, BASE_RES); // initialize the base buffer

// now create the stringlists we will use
FslAllNames := TStringList.Create;
FslCompNames := TStringList.Create;
FslDiskNames := TStringList.Create;
FslDomainNames := TStringList.Create;
FslErrors := TStringList.Create;
FslPrintNames := TStringList.Create;
end;

destructor TWNetEnumClass.Destroys;
begin
// free the stringlists
FslPrintNames.Free;
FslErrors.Free;
FslDomainNames.Free;
FslDiskNames.Free;
FslCompNames.Free;
FslAllNames.Free;

base_buffer := nil; // free the base buffer

inherited Destroy;
end;

//

function TWNetEnumClass.EnumerateResources(startingPoint: TNetResource): Boolean;
var
res: Cardinal;
resEnum: Cardinal;
enumHandle: THandle;
buffer: array of TNetResource;
bufferSize: Cardinal;
numEntries: Cardinal;
i: Cardinal;
begin // EnumerateResources
// Open a container
res := WNetOpenEnum(
RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @startingPoint, enumHandle);
if (res <> NO_ERROR) then
ErrorHandler(res, 'WNetOpenEnum');

// loop through all the elements in the container
repeat
numEntries := Cardinal(-1);
SetLength(buffer, MAX_RES);
bufferSize := SizeOf(TNetResource) * MAX_RES;

// get resources
resEnum := WNetEnumResource(enumHandle, numEntries, buffer, bufferSize);
if (resEnum = NO_ERROR) then
begin
// loop through all entries
for i := 0 to numEntries - 1 do
begin
if (buffer[i].dwDisplayType = RESOURCEDISPLAYTYPE_SERVER) then
FslCompNames.Add(buffer[i].lpRemoteName)
else if (buffer[i].dwType = RESOURCETYPE_PRINT) then
FslPrintNames.Add(buffer[i].lpRemoteName)
else if (buffer[i].dwType = RESOURCETYPE_DISK) then
FslDiskNames.Add(buffer[i].lpRemoteName)
else if (buffer[i].dwDisplayType = RESOURCEDISPLAYTYPE_DOMAIN) then
FslDomainNames.Add(buffer[i].lpRemoteName);
// if the entry is a container, recursively open it
if (buffer[i].dwUsage and RESOURCEUSAGE_CONTAINER > 0) then
if (not EnumerateResources(buffer[i])) then
FslErrors.Add('Enumeration failed');
end;
end
else if (resEnum <> ERROR_NO_MORE_ITEMS) then
ErrorHandler(resEnum, 'WNetEnumResource');
{ added the test for ERROR_INVALID_HANDLE to deal with the case where a "remembered"
connection is no longer in existence. I need to look for a cleaner fix. }
until (resEnum = ERROR_NO_MORE_ITEMS) or (resEnum = ERROR_INVALID_HANDLE);

// clean up
buffer := nil;
res := WNetCloseEnum(enumHandle);
if (res <> NO_ERROR) then
begin
ErrorHandler(res, 'WNetCloseEnum');
result := False;
end
else
result := True;
end;

procedure TWNetEnumClass.EnumResources;
begin
EnumerateResources(base_buffer[0]);
end;

procedure TWNetEnumClass.ErrorHandler(errorNum: Cardinal; s: string);
var
res: Cardinal;
error: Cardinal;
errorStr: string;
nameStr: string;
begin
if (errorNum <> ERROR_EXTENDED_ERROR) then
begin
FslErrors.Add('Error number ' + IntToStr(errorNum) + ' returned by ' + s);
end
else
begin
res := WNetGetLastError(
error, PChar(errorStr), 1000, PChar(nameStr), 1000);
if (res <> NO_ERROR) then
FslErrors.Add('Failure in WNetGetLastError: ' + IntToStr(error))
else
begin
FslErrors.Add('Extended Error: ' + errorStr + '. Provider: ' + nameStr);
end;
end;
end;

function TWNetEnumClass.GetAllNames: TStringList;
begin
FslAllNames.Sort;
Result := FslAllNames;
end;

function TWNetEnumClass.GetCompNames: TStringList;
begin
FslCompNames.Sort;
Result := FslCompNames;
end;

function TWNetEnumClass.GetDiskNames: TStringList;
begin
FslDiskNames.Sort;
Result := FslDiskNames;
end;

function TWNetEnumClass.GetDomainNames: TStringList;
begin
FslDomainNames.Sort;
Result := FslDomainNames;
end;

function TWNetEnumClass.GetErrors: TStringList;
begin
Result := FslErrors;
end;

function TWNetEnumClass.GetPrintNames: TStringList;
begin
FslPrintNames.Sort;
Result := FslPrintNames;
end;

procedure TWNetEnumClass.Refresh;
begin
FslAllNames.Clear;
FslCompNames.Clear;
FslDiskNames.Clear;
FslDomainNames.Clear;
FslErrors.Clear;
FslPrintNames.Clear;
EnumResources;
end;

end.

Creating Excel (XLS) from Delphi


const
CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0);
CXlsEof: array[0..1] of Word = ($0A, 00);
CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);

procedure XlsBeginStream(XlsStream: TStream; const BuildNumber: Word);
begin
CXlsBof[4] := BuildNumber;
XlsStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;

procedure XlsEndStream(XlsStream: TStream);
begin
XlsStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;

procedure XlsWriteCellRk(XlsStream: TStream; const ACol, ARow: Word; const AValue: Integer);
var
V: Integer;
begin
CXlsRk[2] := ARow;
CXlsRk[3] := ACol;
XlsStream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
V := (AValue shl 2) or 2;
XlsStream.WriteBuffer(V, 4);
end;

procedure XlsWriteCellNumber(XlsStream: TStream; const ACol, ARow: Word; const AValue: Double);
begin
CXlsNumber[2] := ARow;
CXlsNumber[3] := ACol;
XlsStream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
XlsStream.WriteBuffer(AValue, 8);
end;

procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word; const AValue: string);
var
L: Word;
begin
L := Length(AValue);
CXlsLabel[1] := 8 + L;
CXlsLabel[2] := ARow;
CXlsLabel[3] := ACol;
CXlsLabel[5] := L;
XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
XlsStream.WriteBuffer(Pointer(AValue)^, L);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
FStream: TFileStream;
I, J: Integer;
begin
FStream := TFileStream.Create('J:\e.xls', fmCreate);
try
XlsBeginStream(FStream, 0);
for I := 0 to 99 do
for J := 0 to 99 do
begin
XlsWriteCellNumber(FStream, I, J, 34.34);
// XlsWriteCellRk(FStream, I, J, 3434);
// XlsWriteCellLabel(FStream, I, J, Format('Cell: %d,%d', [I, J]));
end;
XlsEndStream(FStream);
finally
FStream.Free;
end;
end;

Paint Dock Frame


procedure TDockTree.PaintDockFrame(Canvas: TCanvas; Control: TControl; const ARect: TRect);

procedure DrawCloseButton(Left, Top: Integer);
begin
DrawFrameControl(Canvas.Handle, Rect(Left, Top, Left+FGrabberSize-2,
Top+FGrabberSize-2), DFC_CAPTION, DFCS_CAPTIONCLOSE);
end;

procedure DrawGrabberLine(Left, Top, Right, Bottom: Integer);
begin
with Canvas do
begin
Pen.Color := clBtnHighlight;
MoveTo(Right, Top);
LineTo(Left, Top);
LineTo(Left, Bottom);
Pen.Color := clBtnShadow;
LineTo(Right, Bottom);
LineTo(Right, Top-1);
end;
end;

begin
with ARect do
if FDockSite.Align in [alTop, alBottom] then
begin
DrawCloseButton(Left+1, Top+1);
DrawGrabberLine(Left+3, Top+FGrabberSize+1, Left+5, Bottom-2);
DrawGrabberLine(Left+6, Top+FGrabberSize+1, Left+8, Bottom-2);
end
else
begin
DrawCloseButton(Right-FGrabberSize+1, Top+1);
DrawGrabberLine(Left+2, Top+3, Right-FGrabberSize-2, Top+5);
DrawGrabberLine(Left+2, Top+6, Right-FGrabberSize-2, Top+8);
end;
end;

Convert Shockwave SWF to EXE

Example:
 
Swf2Exe('C:\somefile.swf', 'C:\somefile.exe', 'C:\Program Files\MacromediaFlash MX\Players\SAFlashPlayer.exe');



function Swf2Exe(SourceSWF, exeFile, FlashPlayer : string): string;
var
SourceStream, DestinyStream, LinkStream : TFileStream;
flag : Cardinal;
SwfFileSize : integer;
begin
result := 'Error';
DestinyStream := TFileStream.Create(exeFile, fmCreate);
try
LinkStream := TFileStream.Create(FlashPlayer, fmOpenRead or fmShareExclusive);
try
DestinyStream.CopyFrom(LinkStream, 0);
finally
LinkStream.Free;
end;

SourceStream := TFileStream.Create(SourceSWF, fmOpenRead or fmShareExclusive);
try
DestinyStream.CopyFrom(SourceStream, 0);
flag := $FA123456;
DestinyStream.WriteBuffer(flag, sizeof(integer));
SwfFileSize := SourceStream.Size;
DestinyStream.WriteBuffer(SwfFileSize, sizeof(integer));
result := '';
finally
SourceStream.Free;
end;
finally
DestinyStream.Free;
end;
end;

Customise your Message Dialog


procedure TForm1.Button2Click(Sender: TObject);
var
Dlg: TForm;
Rslt: Integer;
begin
Dlg := CreateMessageDialog('Customised MessageBox, hope this is helpful', mtConfirmation, [mbYes, mbNo, mbNoToAll]);

{ change the messagedlg caption }
Dlg.Caption := 'Please Confirm';

{change the button texts }
TButton(Dlg.FindComponent('Yes')).Caption := 'Indeed!';
TButton(Dlg.FindComponent('No')).Caption := 'Surely Not!';
TButton(Dlg.FindComponent('NoToAll')).Caption := 'None please!';

{ change the button fonts }
TButton(Dlg.FindComponent('Yes')).Font.Name := 'C4 Text';
TButton(Dlg.FindComponent('No')).Font.Name := 'C4 TextMedium' ;
TButton(Dlg.FindComponent('NoToAll')).Font.Name := 'Tahoma';
//this sets the buttons font to Bold & Underlined
TButton(Dlg.FindComponent('NoToAll')).Font.Style:=[fsBold];

{ change the Message's appearance }
TLabel(Dlg.FindComponent('Message')).Font.Name := 'Courier New';
TLabel(Dlg.FindComponent('Message')).Font.Size := 12;
TLabel(Dlg.FindComponent('Message')).Font.Color := clRed;

Rslt := Dlg.ShowModal;

case Rslt of
mrYes: { do "Yes" stuff };
mrNo: { do "No" stuff };
mrNoToAll: { do "No to All" stuff };
end;
end;

Calculate estimated Download time of a File


{ Add this under your type declaration }

type
TDRec = record
H, M, S: Integer;
end;

const
Count = 6;
BpsArray: array [0..Count] of Integer = (14400, 28800, 33600, 56000, 64000, 128000, 512000);

function CalculateDLTime(const Value, Units, Connection: Integer): TDRec;
var
i, size_bits, filedltimesec, hourmod, HH, MM, SS: Integer;
Rec: TDRec;

function pow(a, b: Integer): Integer;
function sl(nr, times: Integer): Integer;
var
i: Integer;
begin
Result := nr * nr;
for i := 0 to times do Result := Result + nr * nr;
end;
begin
if a > b then
Result := sl(a, b)
else
Result := sl(b, a);
end;
begin
case Units of
1: size_bits := (8 div 1) * Value; // bytes
2: size_bits := (8 div 1) * ((pow(2,10)) div 1) * Value; // kilobytes
3: size_bits := (8 div 1) * ((pow(2,20)) div 1) * Value; // Megabytes
end;

// Calculate
filedltimesec := Round(size_bits) div BpsArray[Connection];

hourmod := filedltimesec mod (60 * 60); // Modulus.
HH := Floor(filedltimesec / (60 * 60));
MM := Floor(hourmod / 60);
SS := Floor(filedltimesec mod 60); // Modulus.

if SS > 0 then Inc(SS);

with Rec do
begin
H := HH;
M := MM;
S := SS;
end;

Result := Rec;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
Rec: TDRec;
begin
ListView1.Items.Clear;

for i := 0 to Count do
begin
Rec := CalculateDLTime(StrToInt(Edit1.Text), ComboBox1.ItemIndex + 1,i);

with ListView1.Items.Add do
begin
Caption := NameArray[i];
SubItems.Add(IntToStr(Rec.H));
SubItems.Add(IntToStr(Rec.M));
SubItems.Add(IntToStr(Rec.S));
end;
end;
end;