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;