DELPHI SOURCE CODE

Download Gammu smsm gateway installer

2011-11-16T06:25:00.000-08:00

Download Gammu smsm gateway installer here

How to show printing a Rich Edit control onto a bitmap for preview

2011-11-16T05:59:00.000-08:00

How to show printing a Rich Edit control onto a bitmap for preview

The Rich Edit control (we a talking about standard Windows control, not a Delphi component) contains built-in printing features that can be used to send formatted text to the printer or to paint it's content onto any canvas with minimal effort from the programmer.
Of course, the standard Delphi TRichEdit component incapsulates this feature.
We can use this posibility to make a fast print preview with a scaling or drawing Rich Text on any Delphi control.
Drawing from a Rich Edit control to any canvas involves the use of the standard Rich Edit control message EM_FORMATRANGE.
The lParam parameter for this message is a pointer to the TFormatRange record.
This record have to be filled before sending the message to the RichEdit.
The TFORMATRANGE record contains information that a rich edit control uses to format its output for a particular device, where
hdc Device to render to.
hdcTarget Target device to format for.
rc Area to render to. Units are measured in twips. Twips are screen-independent units to ensure that the proportion of screen elements are the same on all display systems. A twip is defined as being 1/1440 of an inch.
rcPage Entire area of rendering device. Units are measured in twips.
chrg TCHARRANGE record that specifies the range of text to format.
This record usually is used with the EM_EXGETSEL and EM_EXSETSEL messages and includes two fields: cpMin and cpMax.

cpMin is a character position index immediately preceding the first character in the range.
cpMax is a character position immediately following the last character in the range.

function PrintRTFToBitmap(ARichEdit : TRichEdit; ABitmap : TBitmap) : Longint;
var
range   : TFormatRange;
begin
   FillChar(Range, SizeOf(TFormatRange), 0);
// Rendering to the same DC we are measuring.
Range.hdc       := ABitmap.Canvas.handle;
Range.hdcTarget := ABitmap.Canvas.Handle;

// Set up the page.
Range.rc.left   := 0;
Range.rc.top     := 0;
Range.rc.right   := ABitmap.Width * 1440 div Screen.PixelsPerInch;
Range.rc.Bottom := ABitmap.Height * 1440 div Screen.PixelsPerInch;

// Default the range of text to print as the entire document.
Range.chrg.cpMax := -1;
Range.chrg.cpMin := 0;

// format the text
Result := SendMessage(ARichedit.Handle, EM_FORMATRANGE, 1, Longint(@Range));

// Free cached information
SendMessage(ARichEdit.handle, EM_FORMATRANGE, 0,0);
end;
The next example shows how to draw the Rich Edit not only to any canvas, but also how to draw only selected text range.

function PrintToCanvas(ACanvas : TCanvas; FromChar, ToChar : integer;
                      ARichEdit : TRichEdit; AWidth, AHeight : integer) : Longint;
var
  Range   : TFormatRange;
begin
   FillChar(Range, SizeOf(TFormatRange), 0);
   Range.hdc       := ACanvas.handle;
   Range.hdcTarget := ACanvas.Handle;
   Range.rc.left   := 0;
   Range.rc.top     := 0;
   Range.rc.right   := AWidth * 1440 div Screen.PixelsPerInch;
   Range.rc.Bottom := AHeight * 1440 div Screen.PixelsPerInch;
   Range.chrg.cpMax := ToChar;
   Range.chrg.cpMin := FromChar;
   Result := SendMessage(ARichedit.Handle, EM_FORMATRANGE, 1, Longint(@Range));
SendMessage(ARichEdit.handle, EM_FORMATRANGE, 0,0);
end;
But how to draw a Rich Text with the background image?
That is hopeless with the standard TRichedit control, because it based on the Windows control and have no provision to handle background bitmaps or transparency.
In this case we can use two different bitmaps for background and drawing the Rich Text and after combine them togehter.
procedure TForm1.Button2Click(Sender: TObject);
var Bmp : TBitmap;
begin
   Bmp := TBitmap.Create;
   bmp.Width := 300;
   bmp.Height := 300;
   PrintToCanvas(bmp.Canvas,2,5,RichEdit1,300,300);
   BitBlt(Image1.Picture.Bitmap.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height,
        bmp.Canvas.Handle, 0, 0, srcAND);
Image1.Repaint;
bmp.Free;
end;
This tutorial was kindly provided by serge perevoznyk, thank you Serge

Mengubah Background Toolbar Windows Explorer dgn Gambar Bitmap

2011-11-16T05:47:00.001-08:00

Mengubah Background Toolbar Windows Explorer dgn Gambar Bitmap

Program ini menjelaskan tentang mengubah background toolbar windos Explorer dengan gambar bitmap. Yang dilakukan program ini sangat sederhana, yakni memberikan data value BackBitmapShell pada key HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Toolbat dan nilainya merupakan path file bitmap yang digunakan.
Pada Fom rancang 2 Button dan poperty Dialog dengan mengambil OpenPictureDialog, dan juga EditText

Ini Listing program selengkapnya
Procedure Tform1.Button1Click(Sender:TObject);
begin
if OpenPictureDialog1.Execute then
Edit1.Text:=OpenPicutreDialog1.FileName;
end;

Procedure Tfrom1.Button2Click(Sender:TObject);
var Register:Tregister;
begin
Register:=Tregister.create;
Register.RootKey:=HKEY_CURRENT_USER;
try
try
Register.OpenKey('\Software\Microsoft\Internet Explorer\'+ 'Toolbar',True);
Register.WriteString('BackBitmapShell',Edit1.Text);
ShowMessage('Berhasil mengubah background toolbar'+#13+'Untuk melihat hasilnya,buka'+
' "Windows Explorer" baru.');
Except on ERegistryException do
ShowMessage('Gagal mengubah background toolbar explorer');
end;
Finally
Register.CloseKey;
Register.Free;
end;

Selamat mencoba>>>

Run your Delphi application fullscreen

2010-12-14T20:25:00.001-08:00

Here's a nice trick to run your application fullscreen.

A "normal" form doesn't cover the entire screen, but only a part of it. Of course you could maximize your form, but then it still wouldn't cover the entire screensize, because of the title bar of the window and because of Windows' taskbar.

In order to hide both the title bar and the task bar, so to make your form have the same dimensions as the screen dimensions, turn off the borderof the form and then maximize it. You can do this in the form's OnCreate event. The OnCreate event-handler should look like this:

procedure TForm1.FormCreate(Sender: TObject);
begin
  BorderStyle := bsNone;
  WindowState := wsMaximized;
end;

Now run your application: it covers the entire screen!

But... how do you stop the program? Simply press Alt-F4. Because that's not very friendly towards the user, you'd better add a button with a caption (title) Close, that closes the form; if this is the main form (or only form), you also automatically end the program. Here's the button's OnClick event handler:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Close;
end;

Delphi Basics hints and tips

2010-11-01T22:48:00.000-07:00

Delphi Basics hints and tips

The idea of this page is to collect together in one place small, but eminently useful aids to efficient and productive programming in Delphi.

This list will start small, and grow with just the best hints and tips. Alternatively, you can look in Delphi help - for example, type in Shortcuts in the Find tab.

Feel free to contact the author to add to the list here - your suggestions are more than welcome.

Editor shortcuts

Shortcut Keys Resulting actions

Alt + BlockSelect Allows column constrained selection of a text block.

Normally, when you select more than one line using the mouse (by dragging with the left mouse button down) or the arrow keys (with shift held down), the text on the middle lines is always the whole line.

By holding down the Alt key before doing starting the selection, you mark just a vertical block of text. (You can release the Alt key as soon as you have started marking).

When you insert the copied block, it will insert the text where the cursor is positioned, but will not create new lines. It effectively inserts horizontally, but not vertically. The best way to see the effect is to try it!

Ctrl + Shift + i Block Indent. Indents a block of text (lines or Alt-selection) by the tab amount.

Ctrl + Shit + u Block UnIndent. UnIndents a block of text (lines or Alt-selection) by the tab amount.

Ctrl + Shift

+ UpArrow Switch between routine definition and implementation.

Position the cursor on the line of a function or procedure in the interface part of your unit, and this key combination will move to the implementation. And vice versa.

Ctrl + Shift + c Code completion

Position the cursor at a new function or procedure definition, and this key combination will create the code skeleton, and move the cursor into the begin block ready for typing.

Ctrl + Shift + r Macro record

Records the subsequent mouse and key actions as a macro. Finish with the same key combination.

Ctrl + Shift + p Macro play

Plays the last recorded macro.

Ctrl + e Incremental search. The letters you subsequently type form a search string. As you type, it moves to the first part of the current file that matches the string.

It is not case sensitive. Press Escape to stop searching.

Google Map API on Delphi

2010-07-28T20:07:00.000-07:00

I've wrapped the Google Maps API some time ago. It's a component that contains a TWebBrowser that loads a local html file that contains some javascript helper functions and sets up a basic Google maps page. The HTML file is embedded into the exe as a resource for easy deployment.
It can use some work, but it has done some nice jobs for me already. It expands on the idea that was posed here: http://www.stevetrefethen.com/blog/UsingGoogleMapsFromVCLSampleApplication.aspx
I've put a demo executable and sourcecode online here: http://www.xs4all.nl/~niff/GoogleMaps.zip
On this screenshot I've switched to the Google Earth view:

Here are a few examples of how you can use it:

Center the map to some shithole in the Netherlands, with nicely rounded coordinates:
```
GoogleMaps1.SetCenter(52,5,True);
```

Load a KML or KMZ file:

GeoXML := TGGeoXML.Create('http://mywebsite.com/mykml.kmz');
GeoXML.GoogleMaps := GoogleMaps1;
GoogleMaps1.AddOverlay( GeoXML );

Switch to the embedded version of Google Earth, for fast and smooth 3d action:
```
GoogleMaps1.MapType := MT_SATELLITE_3D;
```

Keep a list of overlays, and manage it via Delphi structures:

GoogleMaps1.Overlays[2].hide; // hide overlay 2
GoogleMaps1.RemoveOverlayByIndex(3); // delete overlay 3

It lets you create polygons using fast Delphi arrays and then plot that in GMaps;

MyPolygon := TGPolygon.Create(MyPointArray);
MyPolygon.Color := clBlue; MyPolygon.Name := 'Awesome Polygon 1';
GoogleMaps1.AddPolygon( MyPolygon );

It doesn't intend to wrap the full API; it's just to make life easier when dealing with Google maps. The unit DouglasPeuckers is not really needed. It's used to simplify a polygon when you run out of resources.
Good luck, and let me know if you've created something useful with it.

{—————————————————————————————————————————————————————————————————————————}
{ Project : uGoogleMaps.pas                                               }
{ Comment : Google Maps API wrapper                                       }
{                                                                         }
{    Date : 14 mrt 2008                                                   }
{  Author : Wouter van Nifterick                                          }
{—————————————————————————————————————————————————————————————————————————}
{ The aim of this unit is to wrap the Google Maps API in such a way that  }
{ users don't need to know that map operations end up being rendered by   }
{ a browser component and JavaScript.                                     }
{                                                                         }
{ JavaScript classes have a Delphi counterpart, and each Delphi class     }
{ takes care of proper JavaScript rendering and execution.                }
{                                                                         }
{ For many things, like constructing detailed polygons, this provides a   }
{ major performance boost and adds compile-time type checking.            }
{                                                                         }
{ A big limitation so far is that I didn't find a way to directly pass    }
{ complex types from and to the JavaScript engine in IE via COM, so for   }
{ now, everything needs to be (de)serialized to and from strings. :(      }
{—————————————————————————————————————————————————————————————————————————}
{ Last modified                                                           }
{    Date :                                                               }
{  Author :                                                               }
{—————————————————————————————————————————————————————————————————————————}
{$M+}

unit uGoogleMaps;
interface

uses
  Controls,
  Dialogs,
  ActiveX,
  StdCtrls,
  ExtCtrls,
  SysUtils,
  Classes,
  Contnrs,
  Forms,
  SHDocVw,
  MSHTML,
  StrUtils,
  DouglasPeuckers
//  ,  uGoogleEarth_intf
  ;
const
  GoogleMapsFileName = 'GoogleMaps.html';
  WGS84_MULT_FACT    = 100000; // multiply lat/lon values by this value in order to fit them into integers
  DEFAULT_SIMPLIFY_TOLERANCE = 0.5;
{$R GoogleMaps_html.res}


type


  TGoogleMapControl = (MC_NONE=1,MC_SMALL,MC_LARGE);
  TGoogleMapType    = (MT_NORMAL=1,MT_SATELLITE,MT_HYBRID,MT_PHYSICAL,MT_SATELLITE_3D);

  TGoogleMaps       = class; // forward declaration

  GIcon             = class end; // to be implemented

  IJsClassWrapper=interface(IInterface)
    function JsClassName:String;

    function GetJsVarName:String;
    procedure SetJsVarName(const aVarName:String);
    property JsVarName:String read GetJsVarName write SetJsVarName;

    function ToJavaScript:String;
  end;

  IHidable=interface(IInterface)
    procedure hide;                         // Hides the object if the overlay is both currently visible and the overlay's supportsHide() method returns true. Note that this method will trigger the respective visibilitychanged event for each child overlay that fires that event (e.g. GMarker.visibilitychanged, GGroundOverlay.visibilitychanged, etc.). If no overlays are currently visible that return supportsHide() as true, this method has no effect. (Since 2.87)
    function  isHidden           : Boolean; // Returns true if the GGeoXml object is currently hidden, as changed by the GGeoXml.hide() method. Otherwise returns false. (Since 2.87)
    procedure show;                         // Shows the child overlays created by the GGeoXml object, if they are currently hidden. Note that this method will trigger the respective visibilitychanged event for each child overlay that fires that event (e.g. GMarker.visibilitychanged, GGroundOverlay.visibilitychanged). (Since 2.87)
    function  supportsHide       : Boolean; // 
  end;


  // marker class
  GMarkerOptions=record
    icon          : GIcon;    // Chooses the Icon for this class. If not specified, G_DEFAULT_ICON is used. (Since 2.50)
    dragCrossMove : Boolean;  // When dragging markers normally, the marker floats up and away from the cursor. Setting this value to true keeps the marker underneath the cursor, and moves the cross downwards instead. The default value for this option is false. (Since 2.63)
    title         : String;   // This string will appear as tooltip on the marker, i.e. it will work just as the title attribute on HTML elements. (Since 2.50)
    clickable     : Boolean;  // Toggles whether or not the marker is clickable. Markers that are not clickable or draggable are inert, consume less resources and do not respond to any events. The default value for this option is true, i.e. if the option is not specified, the marker will be clickable. (Since 2.50)
    draggable     : Boolean;  // Toggles whether or not the marker will be draggable by users. Markers set up to be dragged require more resources to set up than markers that are clickable. Any marker that is draggable is also clickable, bouncy and auto-pan enabled by default. The default value for this option is false. (Since 2.61)
    bouncy        : Boolean;  // Toggles whether or not the marker should bounce up and down after it finishes dragging. The default value for this option is false. (Since 2.61)
    bounceGravity : Integer;   // When finishing dragging, this number is used to define the acceleration rate of the marker during the bounce down to earth. The default value for this option is 1. (Since 2.61)
    autoPan       : Boolean;  // Auto-pan the map as you drag the marker near the edge. If the marker is draggable the default value for this option is true. (Since 2.87)

    // to implement:
    //    zIndexProcess : Function; // This function is used for changing the z-Index order of the markers when they are overlaid on the map and is also called when their infowindow is opened. The default order is that the more southerly markers are placed higher than more northerly markers. This function is passed in the GMarker object and returns a number indicating the new z-index. (Since 2.98)
  end;

  TGPoint=class

  end;

  TGLatLng=class(TInterfacedObject,IJsClassWrapper)
  private
    FLat,
    FLng:Double;
    FJsVarName: String;
    function GetJsVarName: String;
    procedure SetJsVarName(const Value: String);
  published
    constructor Create(aLat,aLng:Double);
    property Lat:Double read FLat write FLat;
    property Lng:Double read FLng write FLng;
    function ToJavaScript:String;
    function Equals(const AGLatLng:TGLatLng):Boolean;
    function ToString:String;
    function JsClassName:String;virtual;
    property JsVarName:String read GetJsVarName write SetJsVarName;
  end;


  TGBounds=class(TInterfacedObject,IJsClassWrapper)
  private
    FJsVarName: String;
    FMinX, FMinY, FMaxX, FMaxY:Double;
    FMin,FMax,FMid:TGLatLng;
    function GetMax: TGLatLng;
    function GetMid: TGLatLng;
    function GetMin: TGLatLng;
    procedure SetJsVarName(const Value: String);
    function GetJsVarName: String;
  published
    destructor Destroy;override;
    property minX : Double read FMinX write FMinX;
    property minY : Double read FMinY write FMinY;
    property maxX : Double read FMaxX write FMaxX;
    property maxY : Double read FMaxY write FMaxY;
    function ToString:String;
    function Equals(aGBounds:TGBounds):Boolean;
    property Min:TGLatLng read GetMin;
    property Mid:TGLatLng read GetMid;
    property Max:TGLatLng read GetMax;
    function JsClassName:String;virtual;
    property JsVarName:String read GetJsVarName write SetJsVarName;
    function ToJavaScript:String;
  end;

  TGLatLngBounds=class
  private
    procedure setNorthEast(const Value: TGLatLng);
    procedure setSouthWest(const Value: TGLatLng);
  published
    constructor Create(sw,ne:TGLatLng);
    destructor Destroy;override;
    function contains(aLatLng:TGLatLng):Boolean; deprecated; // Returns true iff the geographical coordinates of the point lie within this rectangle. (Deprecated since 2.88)
    function containsLatLng(aLatLng:TGLatLng):Boolean; // Returns true iff the geographical coordinates of the point lie within this rectangle. (Since 2.88)
    function intersects(aGLatLngBounds:TGLatLngBounds):Boolean;
    function containsBounds(aGLatLngBounds:TGLatLngBounds):Boolean;
    procedure extend(aLatLng:TGLatLng); // Enlarges this rectangle such that it contains the given point. In longitude direction, it is enlarged in the smaller of the two possible ways. If both are equal, it is enlarged at the eastern boundary.

    function toSpan()       :   TGLatLng; //    Returns a GLatLng whose coordinates represent the size of this rectangle.
    function isFullLat()    :   Boolean ; //    Returns true if this rectangle extends from the south pole to the north pole.
    function isFullLng()    :   Boolean ; //    Returns true if this rectangle extends fully around the earth in the longitude direction.
    function isEmpty()      :   Boolean ; //    Returns true if this rectangle is empty.
    function getCenter()    :   TGLatLng; //    Returns the point at the center of the rectangle. (Since 2.52)

    function getSouthWest() :   TGLatLng; //    Returns the point at the south-west corner of the rectangle.
    function getNorthEast() :   TGLatLng; //    Returns the point at the north-east corner of the rectangle.
    property SouthWest : TGLatLng read getSouthWest write setSouthWest;
    property NorthEast : TGLatLng read getNorthEast write setNorthEast;

    function ToString:String;
    function Equals(aGLatLngBounds:TGLatLngBounds):Boolean;
  end;

  TColor = integer;

  // abstract class.. subclassed by TGMarker and TGPolygon and TGPolyLine..

  TGOverlay=class(TInterfacedObject,IJsClassWrapper,IHidable)
  private
    FID: Integer;
    FGoogleMaps: TGoogleMaps;
    FName: String;
    FJsVarName:String;
    procedure SetID(const Value: Integer);
    procedure SetGoogleMaps(const Value: TGoogleMaps);
    procedure SetName(const Value: String);
    function GetJsVarName: String;
    procedure SetJsVarName(const Value: String);
  public
    procedure hide;virtual;
    function isHidden: Boolean;virtual;
    procedure show;virtual;
    function supportsHide: Boolean;virtual;
  published
    property ID:Integer read FID write SetID;
    function ToJavaScript:String;virtual;abstract;
    property JsVarName:String read GetJsVarName write SetJsVarName;
    property GoogleMaps:TGoogleMaps read FGoogleMaps write SetGoogleMaps;
    property Name:String read FName write SetName;
    function JsClassName:string;virtual;
  end;

  TOverlayList=class(TObjectList)
  private
    AutoIncrementID:Integer;
    function GetItems(Index: Integer): TGOverlay;
    procedure SetItems(Index: Integer; const Value: TGOverlay);
  public
    property Items[Index:Integer]:TGOverlay read GetItems write SetItems; default;
  published
    constructor Create;
    destructor Destroy;override;
    function Add(aGOverlay:TGOverlay):Integer;
    procedure Clear;override;
    function ToString:String;
  end;



  TGInfoWindow=class(TGOverlay,IJsClassWrapper,IHidable)
    procedure Maximize;
    procedure Restore;
  private
    FHTML: String;
    procedure SetHTML(const Value: String);
  public
    property HTML:String read FHTML write SetHTML;
    function JsClassName:String;override;
    constructor Create(const aCenter:TGLatLng);
    destructor Destroy;override;
    function ToJavaScript:String;override;
    function supportsHide: Boolean;override;
  end;


  // used to show a location on a map
  // can be dragged, can show a popup, can have custom colors and icon
  TGMarker=class(TGOverlay,IJsClassWrapper,IHidable)
  private
    FCenter: TGLatLng;
    FDraggingEnabled: Boolean;
    procedure setLatLng(const Value: TGLatLng);
    procedure SetDraggingEnabled(const Value: Boolean);
  public
    function supportsHide: Boolean;override;
  published
    function JsClassName:String;override;
    constructor Create(const aCenter:TGLatLng);
    destructor Destroy;override;
    property Center:TGLatLng read FCenter write setLatLng;
    property DraggingEnabled:Boolean read FDraggingEnabled write SetDraggingEnabled;
    function ToJavaScript:String;override;
   { TODO 3 -oWouter : implement all marker methods and events }

    procedure openInfoWindow(aContent:String); // Opens the map info window over the icon of the marker. The content of the info window is given as a DOM node. Only option GInfoWindowOptions.maxWidth is applicable.
    procedure openInfoWindowHtml(aContent:String); // Opens the map info window over the icon of the marker. The content of the info window is given as a string that contains HTML text. Only option GInfoWindowOptions.maxWidth is applicable.
{    procedure openInfoWindowTabs(tabs, opts?) : none; // Opens the tabbed map info window over the icon of the marker. The content of the info window is given as an array of tabs that contain the tab content as DOM nodes. Only options GInfoWindowOptions.maxWidth and InfoWindowOptions.selectedTab are applicable.
    procedure openInfoWindowTabsHtml(tabs, opts?) : none; // Opens the tabbed map info window over the icon of the marker. The content of the info window is given as an array of tabs that contain the tab content as Strings that contain HTML text. Only options InfoWindowOptions.maxWidth and InfoWindowOptions.selectedTab are applicable.
    procedure bindInfoWindow(content, opts?) : none; // Binds the given DOM node to this marker. The content within this node will be automatically displayed in the info window when the marker is clicked. Pass content as null to unbind. (Since 2.85)
    procedure bindInfoWindowHtml(content, opts?) : none; // Binds the given HTML to this marker. The HTML content will be automatically displayed in the info window when the marker is clicked. Pass content as null to unbind. (Since 2.85)
    procedure bindInfoWindowTabs(tabs, opts?) : none; // Binds the given GInfoWindowTabs (provided as DOM nodes) to this marker. The content within these tabs' nodes will be automatically displayed in the info window when the marker is clicked. Pass tabs as null to unbind. (Since 2.85)
    procedure bindInfoWindowTabsHtml(tabs, opts?) : none; // Binds the given GInfoWindowTabs (provided as strings of HTML) to this marker. The HTML content within these tabs will be automatically displayed in the info window when the marker is clicked. Pass tabs as null to unbind. (Since 2.85)
    procedure closeInfoWindow() : none; // Closes the info window only if it belongs to this marker. (Since 2.85)
    procedure showMapBlowup(opts?) : none; // Opens the map info window over the icon of the marker. The content of the info window is a closeup map around the marker position. Only options InfoWindowOptions.zoomLevel and InfoWindowOptions.mapType are applicable.
    procedure getIcon() : GIcon; // Returns the icon of this marker, as set by the constructor.
    procedure getTitle() : String; // Returns the title of this marker, as set by the constructor via the GMarkerOptions.title property. Returns undefined if no title is passed in. (Since 2.85)
    procedure getPoint() : GLatLng; // Returns the geographical coordinates at which this marker is anchored, as set by the constructor or by setPoint(). (Deprecated since 2.88)
    procedure getLatLng() : GLatLng; // Returns the geographical coordinates at which this marker is anchored, as set by the constructor or by setLatLng(). (Since 2.88)
    procedure setPoint(latlng) : none; // Sets the geographical coordinates of the point at which this marker is anchored. (Deprecated since 2.88)
    procedure setLatLng(latlng) : none; // Sets the geographical coordinates of the point at which this marker is anchored. (Since 2.88)
    procedure enableDragging() : none; // Enables the marker to be dragged and dropped around the map. To function, the marker must have been initialized with GMarkerOptions.draggable = true.
    procedure disableDragging() : none; // Disables the marker from being dragged and dropped around the map.
    procedure draggable() : Boolean; // Returns true if the marker has been initialized via the constructor using GMarkerOptions.draggable = true. Otherwise, returns false.
    procedure draggingEnabled() : Boolean; // Returns true if the marker is currently enabled for the user to drag on the map.
    procedure setImage(url) : none; // Requests the image specified by the url to be set as the foreground image for this marker. Note that neither the print image nor the shadow image are adjusted. Therefore this method is primarily intended to implement highlighting or dimming effects, rather than drastic changes in marker's appearances. (Since 2.75)
}

  end;


  TGGeoXml=class(TGOverlay,IJsClassWrapper,IHidable)
  private
    FUrlOfXml: String;
    procedure SetUrlOfXml(const Value: String);
  published
//    function  getTileLayerOverlay: GTileLayerOverlay; // GGeoXml objects may create a tile overlay for optimization purposes in certain cases. This method returns this tile layer overlay (if available). Note that the tile overlay may be null if not needed, or if the GGeoXml file has not yet finished loading. (Since 2.84)
//    function  getDefaultCenter   : GLatLng;           // Returns the center of the default viewport as a lat/lng. This function should only be called after the file has been loaded. (Since 2.84)
//    function  getDefaultSpan     : GLatLng;           // Returns the span of the default viewport as a lat/lng. This function should only be called after the file has been loaded. (Since 2.84)
//    function  getDefaultBounds   : GLatLngBounds;     // Returns the bounding box of the default viewport. This function should only be called after the file has been loaded. (Since 2.84)
    procedure gotoDefaultViewport(Map:TGoogleMaps);     // Sets the map's viewport to the default viewport of the XML file. (Since 2.84)
//    function  hasLoaded          : Boolean; // Checks to see if the XML file has finished loading, in which case it returns true. If the XML file has not finished loading, this method returns false. (Since 2.84)
//    function  loadedCorrectly    : Boolean; // Checks to see if the XML file has loaded correctly, in which case it returns true. If the XML file has not loaded correctly, this method returns false. If the XML file has not finished loading, this method's return value is undefined. (Since 2.84)
    function  supportsHide       : Boolean; override; // Always returns true. (Since 2.87)

    function JsClassName:String;override;
    constructor Create(const aUrlOfXml:String);
    destructor Destroy;override;
    property UrlOfXml:String read FUrlOfXml write SetUrlOfXml;
    function ToJavaScript:String;override;
  end;


  // polygon class
  TGPolygon=class(TGOverlay,IJsClassWrapper,IHidable)
  private
    FCoordinates:Array of TGLatLng;
    FOpacity: double;
    FWeightPx: integer;
    FColor: TColor;
    FSimplified: TGPolygon;
    FIsDirty: Boolean;
    procedure SetColor(const Value: TColor);
    procedure SetOpacity(const Value: double);
    procedure SetWeightPx(const Value: integer);
    function GetCount: Integer;
    procedure SetSimplified(const Value: TGPolygon);
    function GetSimplified: TGPolygon;
  public
    constructor Create(const aCoordinates: array of TGLatLng);overload;
    constructor Create(const aPoints:Array of TPointFloat2D);overload;
    function supportsHide: Boolean;override;
  published
    function JsClassName:String;override;
    procedure Clear;
    function ToJavaScript:String;override;
    function AddPoint(const aGLatLng:TGLatLng):integer;
    property Color:TColor read FColor write SetColor;
    property WeightPx:integer read FWeightPx write SetWeightPx;
    property Opacity:double read FOpacity write SetOpacity;// number between 0 and 1
    property Count:Integer read GetCount;
    destructor Destroy;override;
    property IsDirty:Boolean read FIsDirty write FIsDirty;
    property Simplified:TGPolygon read GetSimplified write SetSimplified;
    function getSimplifiedVersion(Tolerance:Double=DEFAULT_SIMPLIFY_TOLERANCE):TGPolygon;
    class function PolyTypeStr: String;virtual;
  end;

  TGPolyLine=class(TGPolygon,IJsClassWrapper,IHidable)
  published
    class function PolyTypeStr:String;override;
    function JsClassName:String;override;
  end;

  TGCopyright=class(TGOverlay,IJsClassWrapper,IHidable)
  private
    FminZoom: Integer;
    Fid: Integer;
    Fbounds: TGLatLngBounds;
    Ftext: String;
    procedure Setbounds(const Value: TGLatLngBounds);
    procedure Setid(const Value: Integer);
    procedure SetminZoom(const Value: Integer);
    procedure Settext(const Value: String);
  published
    property id         : Integer        read Fid write Setid; // A unique identifier for this copyright information.
    property minZoom    : Integer        read FminZoom write SetminZoom; // The lowest zoom level at which this information applies.
    property bounds     : TGLatLngBounds read Fbounds write Setbounds; // The region to which this information applies.
    property text     : String         read Ftext write Settext; // The text of the copyright message.
    constructor Create (aId : Integer; aBounds:TGLatLngBounds;aMinZoom:Integer;aText:String);
  end;

  TGoogleMaps=class(TPanel)
  private
    FWebBrowser:TWebBrowser;
    FhasEnd: Boolean;
    FhasStart: Boolean;
    FLogLines: TStrings;
    FOverlays: TOverlayList;
    FMapType: TGoogleMapType;
    FLatLngCenter: TGLatLng;
    FEnableDoubleClickZoom: Boolean;
    FEnableContinuousZoom: Boolean;
    FStatusPanel: TPanel;
    FJsVarName: String;
    procedure LoadHTML(URL:String);
    procedure SetLogLines(const Value: TStrings);
    procedure SetOverlays(const Value: TOverlayList);
    procedure Init;
    procedure SaveGoogleMapsHtml(const aFileName:String);
    procedure SetLatLngCenter(const Value: TGLatLng);
    procedure SetEnableContinuousZoom(const Value: Boolean);
    procedure SetEnableDoubleClickZoom(const Value: Boolean);
    function GetLatLngCenter: TGLatLng;
    property WebBrowser : TWebBrowser read FWebBrowser write FWebBrowser;
    procedure SetMapType(AMapType:TGoogleMapType);
    procedure SaveHTML(const FileName:String);
    function GetHTML: String;
    property hasStart     : Boolean read FhasStart write FhasStart;
    property hasEnd       : Boolean read FhasEnd write FhasEnd;
    procedure SetStatusPanel(const Value: TPanel);
    procedure SetJsVarName(const Value: String);
    property DragKind;
    property DragMode;
    property DockSite;
    property Ctl3D;
    property BiDiMode;
    property AutoSize;
    property HelpContext;
    property HelpKeyword;
    property HelpType;
    property Owner;
    property ParentBackground;
    property ParentBiDiMode;
    property ParentCtl3D;
    property Showing;
    property UseDockManager;
    property VerticalAlignment;
    property WheelAccumulator;



  public
    constructor Create(AOwner: TComponent);override;
    destructor Destroy;override;
    procedure SetCenter(Lat,Lng,Alt:Double;doPan:Boolean=false);overload;
    procedure SetCenter(Lat,Lng:Double;doPan:Boolean=false);overload;
    procedure SetCenter(LatLng:TGLatLng;doPan:Boolean=false);overload;
    procedure HandleOnResize(Sender:TObject);
    function GetJsValue(aJavaScript:String):OleVariant;
    property HTML: String read GetHTML;
    procedure CheckResize;
  published
    property StatusPanel  : TPanel read FStatusPanel write SetStatusPanel;
    property LogLines     : TStrings read FLogLines write SetLogLines;
    property Overlays     : TOverlayList read FOverlays write SetOverlays;
    property LatLngCenter : TGLatLng read GetLatLngCenter write SetLatLngCenter;
    property EnableContinuousZoom:Boolean read FEnableContinuousZoom write SetEnableContinuousZoom default true;
    property EnableDoubleClickZoom:Boolean read FEnableDoubleClickZoom write SetEnableDoubleClickZoom default true;
    property MapType:TGoogleMapType read FMapType write SetMapType;
    property JsVarName:String read FJsVarName write SetJsVarName;
    procedure AddControl(ControlType:TGoogleMapControl);
    procedure AddStartMarker;
    procedure AddEndMarker;
    procedure AddMarker(Lat,Lon:Double);
    procedure AddPolygon(GPolygon:TGPolygon);
    procedure AddOverlay(aOverlay:TGOverlay);
    procedure RemoveOverlay(aOverlay:TGOverlay);
    procedure RemoveOverlayByIndex(Index:Integer);
    procedure ClearOverlays;
    procedure SwapBeginEndMarkers;
    procedure GetDirections;
    procedure ShowAddress(const Street,City,State,Country:String);
    procedure openInfoWindow(aLatlng : TGLatLng; aHTML:String);
    procedure closeInfoWindow;
    procedure ExecJavaScript(const aScript:String);
    procedure WebBrowserDocumentComplete(ASender: TObject; const pDisp: IDispatch; var URL: OleVariant);
    procedure OnMouseOver;

    property Align;
    property OnClick;
    property OnCanResize;
    property OnResize;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnDblClick;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnConstrainedResize;

A quick Google search on "Google maps delphi" turned up 10+ pages of hits. Among the top 3 was Using Google Maps from a VCL Sample Application

Knowing the URL of the Browser with Delphi

2010-07-11T19:44:00.000-07:00

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

uses ddeman;

procedure TForm1.Button1Click(Sender: TObject);
const
sName = 'Name';
sURL = 'URL';
var
DDEClient : TDDEClientConv;
s : string;
begin
s := '';
try
DDEClient := TDDEClientConv.Create(self);
try
with DDEClient do
begin
if SetLink('IExplore','WWW_GetWindowInfo') then
s := RequestData('0xFFFFFFFF,sURL,sTitle')
else
if SetLink('Netscape','WWW_GetWindowInfo') then
s := RequestData('0xFFFFFFFF,sURL,sTitle')
else
if SetLink('Mosaic','WWW_GetWindowInfo') then
s := RequestData('0xFFFFFFFF,sURL,sTitle')
else
if SetLink('Netscp6','WWW_GetWindowInfo') then
s := RequestData('0xFFFFFFFF,sURL,sTitle')
else
if SetLink('Mozilla','WWW_GetWindowInfo') then
s := RequestData('0xFFFFFFFF,sURL,sTitle');
end;
finally
Edit1.Text := s;
DDEClient.Free;
end;
except
end;
end;

end.

Software Pengirim Iklan

2010-03-07T18:21:00.000-08:00

Inginkah Anda memiliki satu software khusus, yang mampu mengirimkan iklan Anda ke ratusan bahkan ribuan situs iklan baris SEKALIGUS hanya dalam waktu 1 klik ??? Anda hanya perlu mengetikkan isi iklan Anda 1 x saja, lalu pilih iklan baris mana yang ingin Anda kirimkan, dan... satu klik terakhir akan langsung mengirimkan iklan Anda ke semua iklan baris yang Anda pilih! WOW!!!

Anda Bisa Download disini Gratis!!!. http://www.ziddu.com/download/8836211/pasangiklan.zip.html

Write Excel sheet with Delphi

2010-01-24T02:08:00.000-08:00

Anyway, I had concealed this topic somehow for several years after finalized my last project contains an Excel spreadsheet module exported from database. I knew that what I show you below is a kind of old-fashioned and everyone will know how to did it, but I wrote it just for me. Nothing more except for remind my self that I used to have a project which deal with database and Excel.

The subject is Delphi, records in a database and Microsoft Excel application. It have really quite process: retrieve the data into a component and move the records to Excel sheet grid by grid. You may said that this one is a stupid way, but believe me… this stupid way will work great.

Let’s assumed that you have the way how to retrieve data sources, since I’ll not about how to do that. What I tried to explain is a method how to transfer it to Excel. Strike to the point, simply add the blank form with TDBGrid, TButton and few components got from Servers tab such as TExcelApplication, TExcelWorkBook, TExcelWorkSheet and optionally TExcelQueryTable if you plan to do more action.

Whatever the event is, just a connection to database and display the records into TDBGrid component. Once you do that, I’ll show you the rest of the step.

TButton component to trigger the opening of Microsoft Excel and transfer one by one records into it. But first, you have to catch the total number of the records and fields then use it as the looping procedure, the grid by grid data mover horizontally and vertically from header until end of records. See below example code:

baris:=q1.RecordCount; // number of rows
kolom:=DBGrid1.FieldCount; // number of columns

objExcel := TExcelApplication.Create(nil);
objExcel.Visible[0] := TRUE;
objWB := objExcel.Workbooks.Add(null,1);
for j:=1 to kolom do
objWB.Worksheets.Application.Cells.Item[1,j]:=DBGrid1.Fields[j-1].DisplayName;

q1.First; // TQuery component
for i:=1 to baris do
begin
for j:=1 to kolom do
objWB.Worksheets.Application.Cells.Item[i+1,j]:=DBGrid1.Fields[j-1].AsString;
q1.Next;
end;

objExcel.Free;

Okay, let’s execute the application, press the button and see the result. Voila! Now you have an Excel with records from database directly.

ComboBox with icons

2009-12-19T00:34:00.000-08:00

Each ComboBox item with own icon? No problem. Using OwnerDraw style, we can do almost anything.
Place ComboBox and ImageList on form. Fill ImageList with icons for ComboBox items and set Style of ComboBox to csOwnerDrawFixed or csOwnerDrawVariable. And last thing is the OnDrawItem event of ComboBox:

unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, ImgList, StdCtrls;

type
 TForm1 = class(TForm)
   ComboBox1: TComboBox;
   ImageList1: TImageList;
   procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer;
     Rect: TRect; State: TOwnerDrawState);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;  Rect: TRect; State: TOwnerDrawState);
var
 ComboBox: TComboBox;
 bitmap: TBitmap;
begin
 ComboBox := (Control as TComboBox);
 Bitmap := TBitmap.Create;
 try
   ImageList1.GetBitmap(Index, Bitmap);
   with ComboBox.Canvas do
   begin
     FillRect(Rect);
     if Bitmap.Handle <> 0 then Draw(Rect.Left + 2, Rect.Top, Bitmap);
     Rect := Bounds(Rect.Left + ComboBox.ItemHeight + 2, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
     DrawText(handle, PChar(ComboBox.Items[Index]), length(ComboBox.Items[index]), Rect, DT_VCENTER+DT_SINGLELINE);
   end;
 finally
   Bitmap.Free;
 end;
end;

end.

Are we connected to the Internet?

2009-11-22T00:11:00.000-08:00

Here's how to check whether you are connected to the Internet:

~~~~~~~~~~~~~~~~~~~~~~~~~procedure TForm1.Button1Click(Sender: TObject) ; function FuncAvail(_dllname, _funcname: string; var _p: pointer): boolean; {return True if _funcname exists in _dllname}
var _lib: tHandle;
begin
Result := false;
if LoadLibrary(PChar(_dllname)) = 0 then exit;
_lib := GetModuleHandle(PChar(_dllname)) ;
if _lib <> 0 then begin
_p := GetProcAddress(_lib, PChar(_funcname)) ;
if _p <> NIL then Result := true;
end;
end; { Call SHELL32.DLL for Win < Win98 otherwise call URL.dll }
{button code:}
var InetIsOffline : function(dwFlags: DWORD): BOOL;
stdcall;
begin
if FuncAvail('URL.DLL', 'InetIsOffline', @InetIsOffline) then
if InetIsOffLine(0) = true then
ShowMessage('Not connected')
else
ShowMessage('Connected!') ;
end;
~~~~~~~~~~~~~~~~~~~~~~~~~

Numerical Entry Only On TEdit

2009-11-18T19:23:00.000-08:00

If you want to limit the input of a TEdit to numerical strings only, you can discard the "invalid" characters in its OnKeyPress event handler.

Let's assume that you only want to allow positive integer numbers. The code for the OnKeyPress event handler is as follows:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
 // #8 is Backspace
 if not (Key in [#8, '0'..'9']) then begin
   ShowMessage('Invalid key');
   // Discard the key
   Key := #0;
 end;
end;

If you also want numbers with a decimal fraction, you must allow a POINT or a COMMA, but only once. For an international version that looks at the correct decimal separator, the code could be as follows:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
 if not (Key in [#8, '0'..'9', DecimalSeparator]) then begin
   ShowMessage('Invalid key: ' + Key);
   Key := #0;
 end
 else if (Key = DecimalSeparator) and
         (Pos(Key, Edit1.Text) > 0) then begin
   ShowMessage('Invalid Key: twice ' + Key);
   Key := #0;
 end;
end;

And here's a full blown version of the event handler, accepting a decimal separator and negative numbers (minus sign: only accepted once, has to be the first character):

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
 if not (Key in [#8, '0'..'9', '-', DecimalSeparator]) then
   ShowMessage('Invalid key: ' + Key);
   Key := #0;
 end
 else if ((Key = DecimalSeparator) or (Key = '-')) and
         (Pos(Key, Edit1.Text) > 0) then begin
   ShowMessage('Invalid Key: twice ' + Key);
   Key := #0;
 end
 else if (Key = '-') and
         (Edit1.SelStart <> 0) then begin
   ShowMessage('Only allowed at beginning of number: ' + Key);
   Key := #0;
 end;
end;

How about giving that same behaviour to several TEdits on the same form, say 10 of them? In the Object Inspector, you change the name of the event handler of Edit1 from Edit1KeyPress to Edit1_10KeyPress or something similar. Delphi automatically changes the name in the code editor, don't worry.

Then, for each next TEdit, you select its OnKeyPress event and you select Edit1_10KeyPress from the listbox next to the event.

Finally, we have to slightly adapt the code. Intead of pointing to Edit1, we must point to "the TEdit that generated the event", in other words: the edit-box where the cursor was when a key was depressed. When you look at the template for the event handler that Delphi made, you see the parameter Sender: that's a pointer to the component that generated the event. But we are not allowed to use it straight away in our code, we must specify that we're dealing with a component of the type TEdit. That's done with the code Sender as TEdit:

procedure TForm1.Edit1_10KeyPress(Sender: TObject; var Key: Char);
begin
 if not (Key in [#8, '0'..'9', '-', DecimalSeparator]) then
   ShowMessage('Invalid key: ' + Key);
   Key := #0;
 end
 else if ((Key = DecimalSeparator) or (Key = '-')) and
         (Pos(Key, (Sender as TEdit).Text) > 0) then begin
   ShowMessage('Invalid Key: twice ' + Key);
   Key := #0;
 end
 else if (Key = '-') and
         ((Sender as TEdit).SelStart <> 0) then begin
   ShowMessage('Only allowed at beginning of number: ' + Key);
   Key := #0;
 end;
end;

Get a list of computers in a network

2009-11-15T01:42:00.001-08:00

type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..100] of TNetResource;

function CreateNetResourceList(ResourceType: DWord;
NetResource: PNetResource;
out Entries: DWord;
out List: PNetResourceArray): Boolean;
var
EnumHandle: THandle;
BufSize: DWord;
Res: DWord;
begin
Result := False;
List := Nil;
Entries := 0;
if WNetOpenEnum(RESOURCE_GLOBALNET,
ResourceType,
0,
NetResource,
EnumHandle) = NO_ERROR then begin
try
BufSize := $4000; // 16 kByte
GetMem(List, BufSize);
try
repeat
Entries := DWord(-1);
FillChar(List^, BufSize, 0);
Res := WNetEnumResource(EnumHandle, Entries, List, BufSize);
if Res = ERROR_MORE_DATA then
begin
ReAllocMem(List, BufSize);
end;
until Res <> ERROR_MORE_DATA;
Result := Res = NO_ERROR;
if not Result then
begin
FreeMem(List);
List := Nil;
Entries := 0;
end;
except
FreeMem(List);
raise;
end;
finally
WNetCloseEnum(EnumHandle);
end;
end;
end;

procedure ScanNetworkResources(ResourceType, DisplayType: DWord; List: TStrings);

procedure ScanLevel(NetResource: PNetResource);
var
Entries: DWord;
NetResourceList: PNetResourceArray;
i: Integer;
begin
if CreateNetResourceList(ResourceType, NetResource, Entries, NetResourceList) then try
for i := 0 to Integer(Entries) - 1 do
begin
if (DisplayType = RESOURCEDISPLAYTYPE_GENERIC) or
(NetResourceList[i].dwDisplayType = DisplayType) then begin
List.AddObject(NetResourceList[i].lpRemoteName,
Pointer(NetResourceList[i].dwDisplayType));
end;
if (NetResourceList[i].dwUsage and RESOURCEUSAGE_CONTAINER) <> 0 then
ScanLevel(@NetResourceList[i]);
end;
finally
FreeMem(NetResourceList);
end;
end;
begin
ScanLevel(Nil);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ScanNetworkResources(RESOURCETYPE_DISK, RESOURCEDISPLAYTYPE_SERVER, ListBox1.Items);
end;

Langkah mudah untuk membuat Delphi chart

2009-11-13T00:10:00.000-08:00

Gunakan langkahmudah berikut ini untuk memulai menggunakan Delphi TChart component:

Masukkan Komponen TChart kedalam form
Double Click pada chart lalu anda akan melihat dialog box.
Click tombol add idi series tab sheet.
Pilih Chart style pada daftar

Put following code to add data into the chart

procedure TForm1.Button1Click(Sender: TObject);
begin
   { function AddXY(Const AXValue, AYValue: Double;
   Const AXLabel: String; AColor: TColor) : Longint;
    
   This function inserts a new point in the Series.
   The new point has X and Y values. The AXLabel
   parameter is optional (can be empty ''). The AColor
   parameter is optional (can be clTeeColor).
   The function returns the new point position in the
   Values list. }
   Chart1.Series[0].AddXY(10, 20, '', clTeeColor);
   Chart1.Series[0].AddXY(15, 50, '', clTeeColor);
   Chart1.Series[0].AddXY(20, 30, '', clTeeColor);
   Chart1.Series[0].AddXY(25, 70, '', clTeeColor);
   Chart1.Series[0].AddXY(30, 10, '', clTeeColor);
   Chart1.Series[0].AddXY(35, 50, '', clTeeColor);
   Chart1.Series[0].AddXY(40, 45, '', clTeeColor);
   Chart1.Series[0].AddXY(45, 10, '', clTeeColor);
    
   { Or you can write following code using "With" statement.
   Its much easier than repeating everything again and again.
    
       With Chart1.Series[0] Do
       Begin
           AddXY(10, 20, '', clTeeColor);
           AddXY(15, 50, '', clTeeColor);
           AddXY(20, 30, '', clTeeColor);
           AddXY(25, 70, '', clTeeColor);
           AddXY(30, 10, '', clTeeColor);
           AddXY(35, 50, '', clTeeColor);
           AddXY(40, 45, '', clTeeColor);
           AddXY(45, 10, '', clTeeColor);
       End;
   }
end;

Mengirim Email dengan Delphi

2009-11-11T01:57:00.000-08:00

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
edtSubject: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
edtNamaPengirim: TEdit;
edtEmailPengirim: TEdit;
Label4: TLabel;
edtNamaPenerima: TEdit;
edtEmailPenerima: TEdit;
Label5: TLabel;
MemoMessage: TMemo;
Label6: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

uses MAPI;

{$R *.dfm}

function SendMail(const Subject, Body, FileName,
SenderName, SenderEMail,
RecipientName, RecipientEMail: string): Integer;
var
Message: TMapiMessage;
lpSender, lpRecipient: TMapiRecipDesc;
FileAttach: TMapiFileDesc;
SM: TFNMapiSendMail;
MAPIModule: HModule;
begin
FillChar(Message, SizeOf(Message), 0);
with Message do
begin
if (Subject <> '') then
lpszSubject := PChar(Subject);
if (Body <> '') then
lpszNoteText := PChar(Body);
if (SenderEmail <> '') then
begin
lpSender.ulRecipClass := MAPI_ORIG;
if (SenderName = '') then
lpSender.lpszName := PChar(SenderEMail)
else
lpSender.lpszName := PChar(SenderName);
lpSender.lpszAddress := PChar(SenderEmail);
lpSender.ulReserved := 0;
lpSender.ulEIDSize := 0;
lpSender.lpEntryID := nil;
lpOriginator := @lpSender;
end;
if (RecipientEmail <> '') then
begin
lpRecipient.ulRecipClass := MAPI_TO;
if (RecipientName = '') then
lpRecipient.lpszName := PChar(RecipientEMail)
else
lpRecipient.lpszName := PChar(RecipientName);
lpRecipient.lpszAddress := PChar(RecipientEmail);
lpRecipient.ulReserved := 0;
lpRecipient.ulEIDSize := 0;
lpRecipient.lpEntryID := nil;
nRecipCount := 1;
lpRecips := @lpRecipient;
end
else lpRecips := nil;
if (FileName = '') then
begin
nFileCount := 0;
lpFiles := nil;
end
else
begin
FillChar(FileAttach, SizeOf(FileAttach), 0);
FileAttach.nPosition := Cardinal($FFFFFFFF);
FileAttach.lpszPathName := PChar(FileName);
nFileCount := 1;
lpFiles := @FileAttach;
end;
end;
MAPIModule := LoadLibrary(PChar(MAPIDLL));
if MAPIModule = 0 then
Result := -1
else
try
@SM := GetProcAddress(MAPIModule, 'MAPISendMail');
if @SM <> nil then
begin
Result := SM(0, Application.Handle, Message, MAPI_DIALOG or MAPI_LOGON_UI, 0);
end
else
Result := 1;
finally
FreeLibrary(MAPIModule);
end;
if Result <> 0 then
MessageDlg('Gagal mengirim email (' + IntToStr(Result) + ').', mtError, [mbOK], 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
SendMail(edtSubject.Text,
MemoMessage.Text,
'',
edtNamaPengirim.Text, edtEmailPengirim.Text,
edtNamaPenerima.Text, edtEmailPenerima.Text);
end;

end.

Membaca Seri Prosesor Komputer

2009-08-27T00:40:00.000-07:00

uses Classes, SysUtils;

implementation

function GetCPUInfos: TStringList;
var
_eax, _ebx, _ecx, _edx: Longword;
i: Integer;
b: Byte;
s, s1, s2, s3, s_all: string;
begin
Result := TStringList.Create;
asm // asm call to the CPUID inst.
mov eax, 0 // sub. func call
db $0F, $A2 // db $0F,$A2 = CPUID instruction
mov _ebx, ebx
mov _ecx, ecx
mov _edx, edx
end;
for i := 0 to 3 do // extract vendor id
begin
b := Lo(_ebx);
s := s + chr(b);
b := Lo(_ecx);
s1:= s1 + chr(b);
b := Lo(_edx);
s2:= s2 + chr(b);
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
Result.Add('CPU' + '');
Result.Add(' - ' + 'Vendor ID: ' + s + s2 + s1);
asm
mov eax, 1
db $0F, $A2
mov _eax, eax
mov _ebx, ebx
mov _ecx, ecx
mov _edx, edx
end;
b := Lo(_eax) and 15;
Result.Add(' - ' + 'Stepping ID: ' + IntToStr(b));
b := Lo(_eax) shr 4;
Result.Add(' - ' + 'Model Number: ' + IntToHex(b, 1));
b := Hi(_eax) and 15;
Result.Add(' - ' + 'Family Code: ' + IntToStr(b));
b := Hi(_eax) shr 4;
Result.Add(' - ' + 'Processor Type: ' + IntToStr(b));
b := Lo((_eax shr 16)) and 15;
Result.Add(' - ' + 'Extended Model: ' + IntToStr(b));
b := Lo((_eax shr 20));
Result.Add(' - ' + 'Extended Family: ' + IntToStr(b));
b := Lo(_ebx);
Result.Add(' - ' + 'Brand ID: ' + IntToStr(b));
b := Hi(_ebx);
Result.Add(' - ' + 'Chunks: ' + IntToStr(b));
b := Lo(_ebx shr 16);
Result.Add(' - ' + 'Count: ' + IntToStr(b));
b := Hi(_ebx shr 16);
Result.Add(' - ' + 'APIC ID: ' + IntToStr(b));
if (_edx and $40000) = $40000 then // is serial number enabled?
Result.Add(' - ' + 'Serial Number ' + 'Enabled')
else
Result.Add(' - ' + 'Serial Number ' + 'Disabled');
s := IntToHex(_eax, 8);
asm // determine the serial number
mov eax, 3
db $0F, $A2
mov _ecx, ecx
mov _edx, edx
end;
s1 := IntToHex(_edx, 8);
s2 := IntToHex(_ecx, 8);
Insert('-', s, 5);
Insert('-', s1, 5);
Insert('-', s2, 5);
Result.Add(' - ' + 'Serial Number: ' + s + '-' + s1 + '-' + s2);
asm
mov eax, 1
db $0F, $A2
mov _edx, edx
end;
if (_edx and $800000) = $800000 then
Result.Add('MMX ' + 'Supported')
else
Result.Add('MMX ' + 'Not Supported');
if (_edx and $01000000) = $01000000 then
Result.Add('FXSAVE & FXRSTOR Instructions ' + 'Supported')
else
Result.Add('FXSAVE & FXRSTOR Instructions Not ' + 'Supported');
if (_edx and $02000000) = $02000000 then
Result.Add('SSE ' + 'Supported')
else
Result.Add('SSE ' + 'Not Supported');
if (_edx and $04000000) = $04000000 then
Result.Add('SSE2 ' + 'Supported')
else
Result.Add('SSE2 ' + 'Not Supported');
asm // execute the extended CPUID inst.
mov eax, $80000000 // sub. func call
db $0F, $A2
mov _eax, eax
end;
if _eax > $80000000 then // any other sub. funct avail. ?
begin
Result.Add('Extended CPUID: ' + 'Supported');
Result.Add(' - Largest Function Supported: ' + IntToStr(_eax - $80000000));
asm // get brand ID
mov eax, $80000002
db $0F
db $A2
mov _eax, eax
mov _ebx, ebx
mov _ecx, ecx
mov _edx, edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := Lo(_eax);
s3:= s3 + chr(b);
b := Lo(_ebx);
s := s + chr(b);
b := Lo(_ecx);
s1 := s1 + chr(b);
b := Lo(_edx);
s2 := s2 + chr(b);
eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
s_all := s3 + s + s1 + s2;
asm
mov eax, $80000003
db $0F
db $A2
mov _eax, eax
mov _ebx, ebx
mov _ecx, ecx
mov _edx, edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := Lo(_eax);
s3 := s3 + chr(b);
b := Lo(_ebx);
s := s + chr(b);
b := Lo(_ecx);
s1 := s1 + chr(b);
b := Lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
s_all := s_all + s3 + s + s1 + s2;
asm
mov eax, $80000004
db $0F
db $A2
mov _eax, eax
mov _ebx, ebx
mov _ecx, ecx
mov _edx, edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := Lo(_eax);
s3 := s3 + chr(b);
b := Lo(_ebx);
s := s + chr(b);
b := Lo(_ecx);
s1 := s1 + chr(b);
b := Lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
Result.Add('Brand String: ' + '');
if s2[Length(s2)] = #0 then setlength(s2, Length(s2) - 1);
Result.Add('' + ' - ' + s_all + s3 + s + s1 + s2);
end
else
Result.Add(' - Extended CPUID ' + 'Not Supported.');
end;

Sample skin application with source code ( Delphi )

2009-08-02T18:41:00.001-07:00

Beberapa waktu lalu, ada teman-teman menanyakan tentang pembuatan skin di program Kamus dan Shollu. Sebenarnya banyak komponen yang tersedia di internet untuk membuat aplikasi/program dengan antarmuka (skin) yang menarik. Misalnya saja AlphaSkins yang juga menyediakan komponen yang gratis. Jika untuk membuat program yang besar, mungkin tidak masalah, tetapi jika hanya ingin membuat program sederhana atau ingin agar tidak selalu bergantung dengan komponen tambahan, maka ada baiknya mencoba membuat skin sendiri. Karena terkadang dengan komponen tambahan, aplikasi yang kita jalankan menjadi lebih/sangat lambat dan banyak memakan memory.

Setelah utak-atik dengan graphics programming, dan berkali-kali try and error, akhirnya jadilah skin yang sederhana tetapi tetap menarik ( menurut saya pribadi… ). Selain itu dengan hanya menambahkan file-file bitmap yang total berukuran hanya sekitar 4 KB saja, bisa dihasilkan sekitar 20 macam skin, dan sangat mudah dikembangkan dan ditambah skinnya. Dengan hanya 4 KB tentu tidak banyak menambah ukuran file. Selain itu, proses perubahan skin relatif cepat dan tidak banyak memakan memory komputer, serta jalannya program juga cepat. Berikut sekilas contohnya :

Bagi anda yang penasaran dan ingin mencoba / mengembangkan sendiri, langsung download sample aplikasi, source code dan exe-nya disini (~59 KB). Sample source code dalam Delphi, diperlukan komponen KOL n MCK yang bisa di download disini. Ada pertanyaan, masukan dan tanggapan silahkan langsung email saja.

Kirim SMS dengan Delphi dan TOxygen

2009-07-31T19:38:00.001-07:00

Fitur :

Supports Nokia 3210, 3310, 3330, 3390, 3350, 3410, 3510, 5110, 5130, 5190, 5210, 6110, 6130, 6150, 6190, 6210, 6250, 6310, 6310i, 6510, 7110, 7190, 8210, 8290, 8250, 8310, 8390, 8850, 8855, 8890, 8910 phones.
Bekerja dengan kabel data atau InfraRed
Mendeteksi Model HP secara otomatis
Bisa kirim SMS ke SMS Center apa aja
Bisa kirim dan terima SMS teks atapun gambar
Bisa kirim ringtone, logo ataupun flash message
Bisa hapus pesan dan report nya otomatis
Bisa mendapatkan parameter HP seperti IMEI, model, SMSCenter phone number, Hardware/Software revision dan tanggaknya, Battery dan Signal level.
Componen di Borland Delphi 3,4,5,6,7 dan Borland C++ Builder 5.

Bayangkan, dengan kemampuan nya seperti itu, kita bisa buat aplikasi apa saja via SMS. Pooling, survey, undian dll. Bisa buat skripsi, tugas akhir, tugas de el el.

download componennnya disini

Custom MessageDlg

2009-07-31T19:32:00.000-07:00

Artikel ini merupakan lanjutan dari Meng-Indonesia-kan MessageDlg yang pernah saya publikasikan beberapa bulan yang lalu (lebih tepatnya tahun yang lalu). Sebenarnya saya ingin mengangkat tema lain yang menurut saya lebih menarik, namun berhubung ada diskusi di forum Delphi Indonesia (Delphi-ID) mengenai membuat MessageDlg sesuai dengan keinginan secara dinamis, maka saya putuskan untuk menulisnya terlebih dahulu.

Ada anggapan bahwa artikel tersebut hanya menitik beratkan pada lokalisasi teks MessageDlg, sebenarnya lebih dari itu. Jika dicermati, saya memaparkan trik bagaimana mengubah judul dan tombol yang digunakan MessageDlg pada saat aplikasi berjalan (run-time). Kemudian trik tersebut saya kuatkan dengan demo agar lebih jelas dipahami. Oiya sekedar untuk diketahui trik tersebut berlaku global, untuk semua MessageDlg yang dipanggil oleh aplikasi yang menggunakan, tidak peduli berasal dari mana form atau unit pemanggilnya sampai aplikasi ditutup.

Ada anggapan bahwa trik tersebut bersifat sekali pakai saja, tidak dinamis. Nah inilah yang perlu saya luruskan. Tentu saja trik tersebut dapat dipanggil dan digunakan berkali – kali untuk menampilkan MessageDlg dengan judul dan teks tombol yang berbeda – beda pula.

Lalu bagaimanakah cara agar dapat menampilkan MessageDlg sesuai dengan konteks teks judul dan tombol yang kita inginkan?

Tentu saja cukup mudah!

Cukup panggil method ReplaceResourceString dengan parameter judul, tombol mana yang ingin diubah teks-nya.

Misalnya:

ReplaceResourceString(@SMsgDlgConfirm, 'Konfirmasi Penyimpanan');
ReplaceResourceString(@SMsgDlgYes, 'Simpan Perubahan');
ReplaceResourceString(@SMsgDlgNo, 'Jangan Simpan');

Ok, cukup, saya rasa Anda sudah mendapatkan inti-nya. Jika masih belum, coba simak kode sumber demo berikut, bagi yang belum paham, baca juga penjelasan yang saya tambahkan sebagai komentar:

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: CustomMessageDlgDemoUnit.pas, released on 2008-08-05

The Initial Developer of the Original Code is Bayu Prasetio
Portions created by Bayu Prasetio are Copyright (C) 2007, 2008 Bayu Prasetio.
All Rights Reserved.
-----------------------------------------------------------------------------}

{-----------------------------------------------------------------------------
 Perhatian :
   Apa yang tertera pada kode sumber ini sebaiknya dipahami terlebih dahulu,
   jangan asal 'copy-paste' dan melakukan protes jika tidak sesuai dengan
   keinginan.

   Yang perlu saya tekankan adalah, bahwa materi yang terdapat dalam kode
   sumber ini sekedar demo, 'proof-of-concept' untuk mendukung eksplorasi
   lanjutan dari 'Meng-Indonesia-kan MessageDlg' sampai ke batas yang Anda
   tentukan sendiri berdasarkan imajinasi dan kreativitas Anda. Ingat, demo
   ini belum optimal dan terbaik. Dan tentu saja harapan saya adalah Anda
   dapat mengeksplorasi dan mengembangkan jauh lebih baik dari yang ada di
   demo ini.

   Kelemahan mendasar adalah:
   - Ukuran tombol hanya berubah pada saat 'ReplaceResourceString' pertama,
     pemanggilan berikutnya tidak mengubah ukuran tombol
-----------------------------------------------------------------------------}

unit CustomMessageDlgDemoUnit;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls, ComCtrls;

type
 TfrmCustomMessageDlg = class(TForm)
   btnStandard: TButton;
   btnIndonesian: TButton;
   btnContextSave: TButton;
   mmoLegend: TMemo;
   stbMain: TStatusBar;
   btnContextPrint: TButton;
   procedure btnStandardClick(Sender: TObject);
   procedure btnIndonesianClick(Sender: TObject);
   procedure btnContextSaveClick(Sender: TObject);
   procedure btnContextPrintClick(Sender: TObject);
 private
   { Private declarations }
   procedure ReplaceResourceString(RStringRec: PResStringRec; AString: PChar);
   procedure SetCustomMessageStandard;
   procedure SetCustomMessageIndonesian;
   procedure SetCustomMessageContextSave;
   procedure SetCustomMessageContextPrint;
 public
   { Public declarations }
 end;

var
 frmCustomMessageDlg: TfrmCustomMessageDlg;

implementation

{$R *.dfm}

uses
 Consts;

const
 // konstanta default untuk MessageDlg
 _SMsgDlgWarning = 'Warning';
 _SMsgDlgError = 'Error';
 _SMsgDlgInformation = 'Information';
 _SMsgDlgConfirm = 'Confirm';
 _SMsgDlgYes = '&Yes';
 _SMsgDlgNo = '&No';
 _SMsgDlgOK = 'OK';
 _SMsgDlgCancel = 'Cancel';
 _SMsgDlgHelp = '&Help';
 _SMsgDlgHelpNone = 'No help available';
 _SMsgDlgHelpHelp = 'Help';
 _SMsgDlgAbort = '&Abort';
 _SMsgDlgRetry = '&Retry';
 _SMsgDlgIgnore = '&Ignore';
 _SMsgDlgAll = '&All';
 _SMsgDlgNoToAll = 'N&o to All';
 _SMsgDlgYesToAll = 'Yes to &All';

 // konstanta MessageDlg untuk Bahasa Indonesia
 _SMsgDlgWarningIndonesian = 'Peringatan';
 _SMsgDlgErrorIndonesian = 'Kesalahan';
 _SMsgDlgInformationIndonesian = 'Informasi';
 _SMsgDlgConfirmIndonesian = 'Konfirmasi';
 _SMsgDlgYesIndonesian = '&Ya';
 _SMsgDlgNoIndonesian = '&Tidak';
 _SMsgDlgOKIndonesian = 'OK';
 _SMsgDlgCancelIndonesian = 'Batal';
 _SMsgDlgHelpIndonesian = '&Panduan';
 _SMsgDlgHelpNoneIndonesian = 'Panduan tidak tersedia';
 _SMsgDlgHelpHelpIndonesian = 'Panduan';
 _SMsgDlgAbortIndonesian = '&Batal';
 _SMsgDlgRetryIndonesian = '&Ulang';
 _SMsgDlgIgnoreIndonesian = 'A&cuh';
 _SMsgDlgAllIndonesian = '&Semua';
 _SMsgDlgNoToAllIndonesian = 'T&idak untuk Semua';
 _SMsgDlgYesToAllIndonesian = 'Ya untuk S&emua';

 // konstanta MessageDlg untuk konteks Pencetakan
 // yang digunakan adalah konfirmasi, mbOK, mbYes dan mbNo
 _SMsgDlgWarningContextPrint = 'Peringatan';
 _SMsgDlgErrorContextPrint = 'Kesalahan';
 _SMsgDlgInformationContextPrint = 'Informasi';
 _SMsgDlgConfirmContextPrint = 'Konfirmasi Tujuan Pencetakan';
 _SMsgDlgYesContextPrint = '&Printer';
 _SMsgDlgNoContextPrint = 'Dokumen PD&F Lebar Yak';
 _SMsgDlgOKContextPrint = '&Layar';
 _SMsgDlgCancelContextPrint = 'Batal';
 _SMsgDlgHelpContextPrint = '&Panduan';
 _SMsgDlgHelpNoneContextPrint = 'Panduan tidak tersedia';
 _SMsgDlgHelpHelpContextPrint = 'Panduan';
 _SMsgDlgAbortContextPrint = '&Batal';
 _SMsgDlgRetryContextPrint = '&Ulang';
 _SMsgDlgIgnoreContextPrint = 'A&cuh';
 _SMsgDlgAllContextPrint = '&Semua';
 _SMsgDlgNoToAllContextPrint = 'T&idak untuk Semua';
 _SMsgDlgYesToAllContextPrint = 'Ya untuk S&emua';

 // konstanta MessageDlg untuk konteks Penyimpanan
 // yang digunakan adalah konfirmasi, mbYes dan mbNo
 _SMsgDlgWarningContextSave = 'Peringatan';
 _SMsgDlgErrorContextSave = 'Kesalahan';
 _SMsgDlgInformationContextSave = 'Informasi';
 _SMsgDlgConfirmContextSave = 'Konfirmasi Penyimpanan';
 _SMsgDlgYesContextSave = '&Simpan';
 _SMsgDlgNoContextSave = '&Lanjut Saja';
 _SMsgDlgOKContextSave = 'OK';
 _SMsgDlgCancelContextSave = 'Batal';
 _SMsgDlgHelpContextSave = '&Panduan';
 _SMsgDlgHelpNoneContextSave = 'Panduan tidak tersedia';
 _SMsgDlgHelpHelpContextSave = 'Panduan';
 _SMsgDlgAbortContextSave = '&Batal';
 _SMsgDlgRetryContextSave = '&Ulang';
 _SMsgDlgIgnoreContextSave = 'A&cuh';
 _SMsgDlgAllContextSave = '&Semua';
 _SMsgDlgNoToAllContextSave = 'T&idak untuk Semua';
 _SMsgDlgYesToAllContextSave = 'Ya untuk S&emua';

procedure TfrmCustomMessageDlg.btnContextPrintClick(Sender: TObject);
begin
 SetCustomMessageContextPrint;
end;

procedure TfrmCustomMessageDlg.btnContextSaveClick(Sender: TObject);
begin
 SetCustomMessageContextSave;
end;

procedure TfrmCustomMessageDlg.btnIndonesianClick(Sender: TObject);
begin
 SetCustomMessageIndonesian;
end;

procedure TfrmCustomMessageDlg.btnStandardClick(Sender: TObject);
begin
 SetCustomMessageStandard;
end;

{-- taken from bpCodeReplacement.pas by Bayu Prasetio}
procedure TfrmCustomMessageDlg.ReplaceResourceString(RStringRec: PResStringRec;
 AString: PChar);
var
 OldProtect: Cardinal;
begin
 if RStringRec = nil then Exit;
 if VirtualProtectEx(GetCurrentProcess, RStringRec, SizeOf(RStringRec^), PAGE_EXECUTE_READWRITE, OldProtect) then
 begin
   RStringRec^.Identifier := Integer(AString);
   VirtualProtectEx(GetCurrentProcess, RStringRec, SizeOf(RStringRec^), OldProtect, @OldProtect);
 end;
end;

procedure TfrmCustomMessageDlg.SetCustomMessageContextPrint;
begin
 // sebagai contoh, ubah resource string untuk MessageDlg berdasarkan konteks kejadian
 // dalam hal ini adalah proses pencetakan
 // mbOK disetarakan tayang ke layar (preview)
 // mbYes disetarakan cetak ke printer
 // mbNo disetarakan cetak ke dokumen PDF
 ReplaceResourceString(@SMsgDlgConfirm, _SMsgDlgConfirmContextPrint);
 ReplaceResourceString(@SMsgDlgYes, _SMsgDlgYesContextPrint);
 ReplaceResourceString(@SMsgDlgNo, _SMsgDlgNoContextPrint);
 ReplaceResourceString(@SMsgDlgOK, _SMsgDlgOKContextPrint);

 // gunakan ModalResult dari MessageDlg untuk menentukan tindakan selanjutnya
 // hati - hati, Anda tidak dapat menggunakan ShowMessage sekehendak hati
 // karena ShowMessage sebenarnya MessageDlg dengan parameter MessageType mtInformation
 // dan Buttons [mbOK]. Pahamkan mengapa tombol 'OK' berubah menjadi 'Layar' ?
 case MessageDlg('Tentukan tujuan pencetakan dokumen ?', mtConfirmation, [mbOK, mbYes, mbNo], 0) of
   mrOK : ShowMessage('Dokumen ditayangkan ke layar');
   mrYes : ShowMessage('Dokumen dicetak ke printer');
   mrNo : ShowMessage('Dokumen disimpan dalam format .PDF');
 end;
end;

procedure TfrmCustomMessageDlg.SetCustomMessageContextSave;
begin
 // sebagai contoh, ubah resource string untuk MessageDlg berdasarkan konteks kejadian
 // dalam hal ini adalah proses simpan
 ReplaceResourceString(@SMsgDlgConfirm, _SMsgDlgConfirmContextSave);
 ReplaceResourceString(@SMsgDlgYes, _SMsgDlgYesContextSave);
 ReplaceResourceString(@SMsgDlgNo, _SMsgDlgNoContextSave);
 ReplaceResourceString(@SMsgDlgCancel, _SMsgDlgCancelContextSave);

 MessageDlg('Anda Yakin akan menyimpan dokumen ini ?', mtConfirmation, mbYesNoCancel, 0);
end;

procedure TfrmCustomMessageDlg.SetCustomMessageIndonesian;
begin
 // ubah semua resource string untuk MessageDlg ke bahasa Indonesia
 ReplaceResourceString(@SMsgDlgWarning, _SMsgDlgWarningIndonesian);
 ReplaceResourceString(@SMsgDlgError, _SMsgDlgErrorIndonesian);
 ReplaceResourceString(@SMsgDlgInformation, _SMsgDlgInformationIndonesian);
 ReplaceResourceString(@SMsgDlgConfirm, _SMsgDlgConfirmIndonesian);
 ReplaceResourceString(@SMsgDlgYes, _SMsgDlgYesIndonesian);
 ReplaceResourceString(@SMsgDlgNo, _SMsgDlgNoIndonesian);
 ReplaceResourceString(@SMsgDlgOK, _SMsgDlgOKIndonesian);
 ReplaceResourceString(@SMsgDlgCancel, _SMsgDlgCancelIndonesian);
 ReplaceResourceString(@SMsgDlgHelp, _SMsgDlgHelpIndonesian);
 ReplaceResourceString(@SMsgDlgHelpNone, _SMsgDlgHelpNoneIndonesian);
 ReplaceResourceString(@SMsgDlgHelpHelp, _SMsgDlgHelpHelpIndonesian);
 ReplaceResourceString(@SMsgDlgAbort, _SMsgDlgAbortIndonesian);
 ReplaceResourceString(@SMsgDlgRetry, _SMsgDlgRetryIndonesian);
 ReplaceResourceString(@SMsgDlgIgnore, _SMsgDlgIgnoreIndonesian);
 ReplaceResourceString(@SMsgDlgAll, _SMsgDlgAllIndonesian);
 ReplaceResourceString(@SMsgDlgNoToAll, _SMsgDlgNoToAllIndonesian);
 ReplaceResourceString(@SMsgDlgYesToAll, _SMsgDlgYesToAllIndonesian);

 MessageDlg('Anda Yakin akan menyimpan dokumen ini ?', mtConfirmation, mbYesNoCancel, 0);
end;

procedure TfrmCustomMessageDlg.SetCustomMessageStandard;
begin
 // ubah semua resource string untuk MessageDlg ke default
 ReplaceResourceString(@SMsgDlgWarning, _SMsgDlgWarning);
 ReplaceResourceString(@SMsgDlgError, _SMsgDlgError);
 ReplaceResourceString(@SMsgDlgInformation, _SMsgDlgInformation);
 ReplaceResourceString(@SMsgDlgConfirm, _SMsgDlgConfirm);
 ReplaceResourceString(@SMsgDlgYes, _SMsgDlgYes);
 ReplaceResourceString(@SMsgDlgNo, _SMsgDlgNo);
 ReplaceResourceString(@SMsgDlgOK, _SMsgDlgOK);
 ReplaceResourceString(@SMsgDlgCancel, _SMsgDlgCancel);
 ReplaceResourceString(@SMsgDlgHelp, _SMsgDlgHelp);
 ReplaceResourceString(@SMsgDlgHelpNone, _SMsgDlgHelpNone);
 ReplaceResourceString(@SMsgDlgHelpHelp, _SMsgDlgHelpHelp);
 ReplaceResourceString(@SMsgDlgAbort, _SMsgDlgAbort);
 ReplaceResourceString(@SMsgDlgRetry, _SMsgDlgRetry);
 ReplaceResourceString(@SMsgDlgIgnore, _SMsgDlgIgnore);
 ReplaceResourceString(@SMsgDlgAll, _SMsgDlgAll);
 ReplaceResourceString(@SMsgDlgNoToAll, _SMsgDlgNoToAll);
 ReplaceResourceString(@SMsgDlgYesToAll, _SMsgDlgYesToAll);

 MessageDlg('Anda Yakin akan menyimpan dokumen ini ?', mtConfirmation, mbYesNoCancel, 0);
end;

end.

Dan sebagai catatan, ada kelemahan yang perlu diketahui perihal trik, yaitu ukuran tombol hanya berubah pada saat ‘ReplaceResourceString’ pertama, pemanggilan berikutnya tidak mengubah ukuran tombol.

Ok, seperti yang telah saya tulis komentar di kode sumber, “harapan saya adalah Anda dapat mengeksplorasi dan mengembangkan jauh lebih baik dari yang ada di demo ini”. Saya sengaja membuat demo ini belum optimal, jadi silahkan gunakan logika, kreativitas dan imajinasi Anda.

Semoga bermanfaat.

Hindari FieldByName pada Penggunaan Intensif

2009-07-30T23:16:00.000-07:00

Hindari FieldByName pada Penggunaan Intensif

Bagi Delphiers yang sering berinteraksi dengan database, tentu tidak asing dengan penggunaan FieldByName. Pada operasi akses field yang bersifat intensif, misalnya konversi data, penyalinan data dari satu database atau tabel ke database atau tabel lainnya, penggunaan FieldByName harus dihindari.

Untuk mencapai suatu field dengan menggunakan FieldByName, terlebih dahulu harus dilakukan pencarian alamat referensi field yang dimaksud dengan melakukan iterasi setiap field pada daftar field (FieldList) dari awal hingga akhir untuk mencocokkan namanya (FieldName). Proses iterasi akan berhenti ketika ditemukan nama field pada daftar field. Proses kemudian mengembalikan alamat referensi field yang dimaksud.

Sekilas, proses yang terjadi pada FieldByName ditunjukkan pada potongan kode berikut:

function TFields.FieldByName(const FieldName: WideString): TField;
begin
 Result := FindField(FieldName);
 if Result = nil then DatabaseErrorFmt(SFieldNotFound, [FieldName], DataSet);
end;

Jika ditelusuri, fungsi FindField adalah sebagai berikut:

function TFields.FindField(const FieldName: WideString): TField;
var
 I: Integer;
begin
 for I := 0 to FList.Count - 1 do
 begin
   Result := FList.Items[I];
   if WideCompareText(Result.FFieldName, FieldName) = 0 then Exit;
 end;
 Result := nil;
end;

Oke, untuk lebih mantapnya, perlu kita buat sebuah rutin untuk mengukur bagaimana penggunaan FieldByName pada operasi yang intensif mengakses field. Perlu diingat bahwa kode yang dijadikan sebagai contoh dibuat sesederhana mungkin, hanya mengakses 2 field saja dan tidak ada operasi lain yang menyertainya seperti perhitungan, seleksi kondisi dan sebagainya. Pada keadaan sesungguhnya, bentuk operasi bisa jauh lebih kompleks dan bervariasi.

Berikut gambaran singkat mengenai data yang akan dijadikan bahan pengukuran
- Sistem Core2Duo 1.66GHz, 667MHz FSB, 2MB L2 Cache, 1GB RAM, dengan free ram > 256MB (ada program yg berjalan: Delphi2007, FF, EMS SQL Manager, Notepad++)
- Windows XP Professional SP3
- MySQL 5.1.21, akses lokal, konfigurasi standar
- Tabel dengan jenis InnoDB, jumlah record sekitar 29000-an
- Pengukuran menggunakan QueryPerformaceCounter & QueryPerformanceFrequency
- Sangat dimungkinkan terjadi proses caching pembacaan hasil proses sebelumnya. Untuk itu lakukan proses perhitungan dengan jeda waktu yang lama dan berkali - kali untuk meyakinkan nilainya.

Metode 1

Metode 1 menggunakan FieldByName seperti pada potongan kode berikut:

procedure TForm2.btnMethod1Click(Sender: TObject);
var
 A, B          : Double;
 FFreq         : Int64;
 FStartCounter : Int64;
 FStopCounter  : Int64;
 I             : Integer;
begin
 MyConnection1.Connected := True;
 MyQuery1.Active := True;

 A := 0;
 B := 0;
 QueryPerformanceFrequency(FFreq);
 QueryPerformanceCounter(FStartCounter);
 for I := 0 to 1000 do
 begin
   MyQuery1.First;
   while not MyQuery1.Eof do
   begin
     A := MyQuery1.FieldByName('jumlah').AsFloat;
     B := MyQuery1.FieldByName('jumlahnetto').AsFloat;
     MyQuery1.Next;
   end;
 end;
 QueryPerformanceCounter(FStopCounter);

 Label1.Caption := FloatToStr((FStopCounter - FStartCounter) / FFreq);

 MyQuery1.Active := False;
 MyConnection1.Connected := False;
end;

Hasil dari eksekusi rutin tersebut adalah 117,7975 detik.

Hasil Pengukuran Metode 1

Cukup lama bukan ? Lalu adakah teknik untuk mempersingkat operasi tersebut ? Tentu saja ada !

Metode 2

Teknik ini mungkin sudah banyak diketahui, namun mungkin jarang digunakan. Alih - alih menggunakan nama field untuk mencari field yang dikehendaki, teknik ini langsung mengakses alamat referensi dari field yang dikehendaki dengan memanfaatkan nomor indeks field tersebut dalam daftar field. Tentu saja untuk melakukannya harus diketahui terlebih dahulu nomor indeks yang tepat. Field pertama diakses melalui nomor indeks 0, field kedua diakses melalui nomor indeks 1, demikian seterusnya.

Salah satu sebab teknik ini jarang dilakukan adalah karena konsistensi nomor urut field. Jika misalnya terdapat perubahan susunan tabel atau perintah query, maka nomor urut field dimungkinkan tidak sesuai lagi. Dengan demikian harus dilakukan perubahan nomor urut pada kode sumber.

Disisi lain, teknik ini sangat sesuai apabila diterapkan pada aplikasi konversi / migrasi database / tabel dimana jumlah dan nama field sangat variatif. Disini, nama field tidak dapat dijadikan sebagai acuan. Yang perlu dilakukan hanyalah memberikan nomor indeks dari awal hingga akhir dan lakukan proses iterasi per record, dari field awal sampai akhir.

Berdasarkan kode metode 1, maka dilakukan perubahan seperti pada kode berikut:

procedure TForm2.btnMethod2Click(Sender: TObject);
var
 A, B          : Double;
 FFreq         : Int64;
 FStartCounter : Int64;
 FStopCounter  : Int64;
 I             : Integer;
begin
 MyConnection1.Connected := True;
 MyQuery1.Active := True;

 A := 0;
 B := 0;
 QueryPerformanceFrequency(FFreq);
 QueryPerformanceCounter(FStartCounter);
 for I := 0 to 1000 do
 begin
   MyQuery1.First;
   while not MyQuery1.Eof do
   begin
     A := MyQuery1.Fields[12].AsFloat;
     B := MyQuery1.Fields[13].AsFloat;
     MyQuery1.Next;
   end;
 end;
 QueryPerformanceCounter(FStopCounter);

 Label2.Caption := FloatToStr((FStopCounter - FStartCounter) / FFreq);

 MyQuery1.Active := False;
 MyConnection1.Connected := False;
end;

Hasil dari eksekusi rutin tersebut adalah 27,1231 detik. Sangat manjur bukan ?

Hasil Pengukuran Metode 2

Masih belum puas dengan hasil tersebut ? Simak teknik berikutnya.

Metode 3

Teknik ini lebih jarang lagi digunakan. Alih - alih melakukan penunjukan field yang dimaksud dengan memberikan nomor indeks yang sesuai pada setiap iterasi record dimana proses penunjukan field membutuhkan proses untuk mengakses kelas TField, teknik ini langsung mengakses kelas TField tersebut berada. Caranya adalah dengan terlebih dahulu mendapatkan alamat dimana kelas TField tersebut berada. Alamat tersebut kemudian di simpan pada variabel lokal yang akan digunakan untuk mengakses field tersebut secara langsung.

Berikut kode untuk metode 3:

procedure TForm2.btnMethod3Click(Sender: TObject);
var
 A, B          : Double;
 FFreq         : Int64;
 FStartCounter : Int64;
 FStopCounter  : Int64;
 I             : Integer;
 AField        : TField;
 AField2       : TField;
begin
 MyConnection1.Connected := True;
 MyQuery1.Active := True;

 A := 0;
 B := 0;
 QueryPerformanceFrequency(FFreq);
 QueryPerformanceCounter(FStartCounter);
 AField := MyQuery1.FieldByName('jumlah');
 AField2 := MyQuery1.FieldByName('jumlahnetto');
 for I := 0 to 1000 do
 begin
   MyQuery1.First;
   while not MyQuery1.Eof do
   begin
     A := AField.AsFloat;
     B := AField2.AsFloat;
     MyQuery1.Next;
   end;
 end;
 QueryPerformanceCounter(FStopCounter);

 Label3.Caption := FloatToStr((FStopCounter - FStartCounter) / FFreq);

 MyQuery1.Active := False;
 MyConnection1.Connected := False;
end;

Hasil dari eksekusi rutin tersebut adalah 26,9201 detik.

Hasil Pengukuran Metode 3

Tentu saja masih ada celah perbaikan walaupun pengaruhnya mungkin tidak signifikan, tergantung dari kode Anda, yaitu dengan mengganti kode FieldByName menjadi Fields[x] dimana x adalah nomor indeks field yang dikehendaki.

Contoh kode diatas sangat intensif menggunakan variabel bertipe TField untuk menampung alamat referensi dari field yang dikehendaki. Lalu bagaimana apabila jumlah field yang diakses sangat banyak atau bahkan sangat bervariasi ? Bukankah sangat tidak efisien apabila mendeklarasikan semua variabel yang diperlukan ? Lalu adakah teknik untuk mensiasatinya ? Simak metode selanjutnya.

Metode 4

Salah satu teknik yang dapat digunakan adalah dengan menggunakan array dinamis. Namun untuk menyederhanakan pembahasan, pada contoh ini hanya akan mengunakan array statis.

procedure TForm2.btnMehtod4Click(Sender: TObject);
var
 A, B          : Double;
 FFreq         : Int64;
 FStartCounter : Int64;
 FStopCounter  : Int64;
 I             : Integer;
 AField        : array [1..2] of TField;
begin
 MyConnection1.Connected := True;
 MyQuery1.Active := True;

 A := 0;
 B := 0;
 QueryPerformanceFrequency(FFreq);
 QueryPerformanceCounter(FStartCounter);
 AField[1] := MyQuery1.FieldByName('jumlah');
 AField[2] := MyQuery1.FieldByName('jumlahnetto');
 for I := 0 to 1000 do
 begin
   MyQuery1.First;
   while not MyQuery1.Eof do
   begin
     A := AField[1].AsFloat;
     B := AField[2].AsFloat;
     MyQuery1.Next;
   end;
 end;
 QueryPerformanceCounter(FStopCounter);

 Label4.Caption := FloatToStr((FStopCounter - FStartCounter) / FFreq);

 MyQuery1.Active := False;
 MyConnection1.Connected := False;
end;

Sama seperti sebelumnya, tentu saja masih ada celah perbaikan walaupun pengaruhnya mungkin tidak signifikan, tergantung dari kode Anda, yaitu dengan mengganti kode FieldByName menjadi Fields[x] dimana x adalah nomor indeks field yang dikehendaki.

Hasil dari eksekusi rutin tersebut adalah 26,8862 detik.

Hasil Pengkuran Metode 4

Sebagai latihan, silahkan mencoba dengan jumlah field yang lebih banyak dan bandingkan hasilnya. Adakah terjadi peningkatan kecepatan ? Silahkan cari tahu sendiri sebabnya.

Semoga bermanfaat.

Make System Tray Application in delphi,

2009-07-30T22:49:00.000-07:00

Make System Tray Application in Delphi in order to run background or placed on system tray is very easy. We Only need one API function that is Shell_NotifyIcon,the Application will be run as system tray with there function.
The First at private you must declaration
private
{ Private declarations }
systemTrayIcon:TNotifyIconData;

And Then, make a form, on event on Create add script below this
with systemTrayIcon do begin cbSize := Sizeof(systemTrayIcon); Wnd:=Handle; uID := 0; uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP; uCallbackMessage := WM_USER; hIcon := Application.Icon.Handle; StrCopy(szTip,'Aplikasi System Tray'); End; Shell_NotifyIcon(NIM_ADD,@systemTrayIcon);
xplanation script above are :
Wnd is parameter from systemTrayIcon that use for appear icon on system tray and receive message information from system.
hIcon is parameter for appear icon on system tray
szTip is parameter for appear icon tips on system tray
And then the most important part is Shell_NotifyIcon(NIM_ADD,@systemTrayIcon); that useful to place application on system tray
To make our application disable on taskbar we must add some line in project part :
begin Application.Initialize; Application.ShowMainForm := false; //tambahkan baris ini Application.CreateForm(TForm1, Form1); Application.Run; end.

If you want to disable icon when you close yout application you must add some code below on even OnDestroy at Form1
Shell_NotifyIcon(NIM_DELETE,@systemTrayIcon);

After you finished, now we make our application can run normally or foreground, we can make a procedure,
Example i have declaration procedure gotoTray at private section
procedure gotoTray(pesan :TMessage); message WM_USER;

if you have been declaration, we must make implementation of procedure gotoTray.
This script below is implementation of procedure gotoTray

procedure TForm1.gotoTray(pesan :TMessage);
begin
case pesan.LParam of
WM_LBUTTONDOWN:
begin
ShowMessage('Form ditampilkan');
Form1.Show;
end;
WM_RBUTTONDOWN:
begin
ShowMessage('Form Menuju System Tray');
Form1.Hide;
end;
end;
end;

ganti atribut file

2008-08-26T00:45:00.001-07:00

The following code reads a file's attributes into a set variable, sets the check boxes in a file-attribute dialog box to represent the current attributes, then executes the dialog box. If the user changes and accepts any dialog box settings, the code sets the file attributes to match the changed settings:

procedure TFMForm.Properties1Click(Sender: TObject);
var
Attributes, NewAttributes: Word;
begin
with FileAttrForm do
begin
FileDirName.Caption := FileList.Items[FileList.ItemIndex];
{ set box caption }
PathName.Caption := FileList.Directory;
{ show directory name }
ChangeDate.Caption :=
DateTimeToStr(FileDateToDateTime(FileAge(FileList.FileName)));
Attributes := FileGetAttr(FileDirName.Caption);
{ read file attributes }
ReadOnly.Checked := (Attributes and SysUtils.faReadOnly) = faReadOnly;
Archive.Checked := (Attributes and faArchive) = faArchive;
System.Checked := (Attributes and faSysFile) = faSysFile;
Hidden.Checked := (Attributes and faHidden) = faHidden;
if ShowModal <> id_Cancel then { execute dialog box }
begin
NewAttributes := Attributes;
{ start with original attributes }
if ReadOnly.Checked then
NewAttributes := NewAttributes or SysUtils.faReadOnly
else
NewAttributes := NewAttributes and not SysUtils.faReadOnly;
if Archive.Checked then
NewAttributes := NewAttributes or faArchive
else
NewAttributes := NewAttributes and not faArchive;
if System.Checked then
NewAttributes := NewAttributes or faSysFile
else
NewAttributes := NewAttributes and not faSysFile;
if Hidden.Checked then
NewAttributes := NewAttributes or faHidden
else
NewAttributes := NewAttributes and not faHidden;
if NewAttributes <> Attributes then { if anything changed... }
FileSetAttr(FileDirName.Caption, NewAttributes);
{ ...write the new values }
end;
end;
end;

Delphi - membuka control panel

2008-08-26T00:03:00.001-07:00

Membuka Control Panel

Gunakan kode di bawah ini untuk membuka Control Panel dari program Delphi Anda. Jangan lupa tampahkan ShellApi pada bagian uses :

procedure TForm1.Buton1Click(Sender : TObject);
begin
ShellExecute(Handle,\'Open\',\'control\',
nil,nil,SW_SHOWNORMAL);
end;

How to minimize to System Tray

2008-08-25T02:22:00.001-07:00

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ShellApi;

const
WM_NOTIFYICON = WM_USER+333;

type
TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
tnid: TNotifyIconData;
HMainIcon: HICON;

procedure CMClickIcon(var msg: TMessage); message WM_NOTIFYICON;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.CMClickIcon(var msg: TMessage);
begin
case msg.lparam of
WM_LBUTTONDBLCLK : Show;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
HMainIcon := LoadIcon(MainInstance, \'MAINICON\');

Shell_NotifyIcon(NIM_DELETE, @tnid);

tnid.cbSize := sizeof(TNotifyIconData);
tnid.Wnd := handle;
tnid.uID := 123;
tnid.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
tnid.uCallbackMessage := WM_NOTIFYICON;
tnid.hIcon := HMainIcon;
tnid.szTip := \'POP3 Server\';

Shell_NotifyIcon(NIM_ADD, @tnid);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caNone;
Hide;
end;

end.

shutdown komputer

2008-08-24T19:11:00.001-07:00

Men-shutdown komputer

Untuk melakukan restart, shutdown atau log off komputer, gunakan fungsi ExitWindowsEx. Ada pun deklarasi dari fungsi ExitWindowsEx adalah sebagai berikut :

function ExitWindowsEx (uFlags : word ; dwReserved : DWORD): BOOL;

Parameter pertama menerangkan \"apa yang harus dilakukan\" oleh komputer. Parameter ini dapat bernilai :
Konstanta

Keterangan
EWX_RESTART Melakukan restart dengan menampilkan peringatan.
EWX_SHUTDOWN Melakukan shutdown dengan menampilkan peringatan.
EWX_LOGOFF Melakukan log off dengan menampilkan peringatan.
EWX_FORCE Melakukan shutdown tanpa menampilkan peringatan. Sehingga ada kemungkinan Anda akan kehilangan data yang belum disimpan (belum di-save).

Sedangkan parameter kedua bernilai 0.

Sehingga bila ingin melakukan shutdown cukup tulis kode berikut ini :

ExitWindowsEx (EWX_SHUTDOWN, 0);