发信人: bbbbbbbbbbbb (刀剑笑), 信区: BorlandDev
标 题: [合集]关于VCL的FAQ -- CF dumpaged
发信站: 哈工大紫丁香 (2002年12月30日15:46:46 星期一), 站内信件
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日11:40:41 星期天 说道:
以下文章转至http://www.scalabium.com/faq/
VCL
#0002 How can I draw the rotated text on canvas?
#0005 To change a font style (bold nodes) in standard TTreeview component
#0008 To disable a form movement
#0010 To add the horizontal scrollbar in listbox
#0012 To set a checkbox without OnClick event
#0013 To disable the on-fly tooltips in TTreeView
#0018 The form life cycle after creation
#0023 To get a line/column number that a memo/richtext cursor is on
#0025 To use a combobox instead inplace editor in TStringGrid
#0028 The offsets for TMemo
#0029 The quick filling a listbox with file names
#0034 To change alignment for TEdit
#0035 To make a form like system modal
#0036 To create a non-rectangular control
#0038 How to add a flat/hot track effect to components
#0057 To delete the row in TStringGrid component
#0065 To save/restore the component into BLOB-field
#0067 Access to some item of TRadioGroup component
#0085 To save/load the glyphs to/from external file
#0094 To assign a values to TStrings instead objects
#0102 To scroll a text in memo in run-time
#0146 Standard RichEdit component and URL highlighting
※ 来源:·哈工大紫丁香 bbs.hit.edu.cn·[FROM: 218.8.78.140]
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日16:59:04 星期天 说道:
------------------------------------------------------------------------
--------
With next procedure you can display the text with any angle.
procedure AngleTextOut(ACanvas: TCanvas; Angle, X, Y: Integer; Str:
string);
var
LogRec: TLogFont;
OldFontHandle,
NewFontHandle: hFont;
begin
GetObject(ACanvas.Font.Handle, SizeOf(LogRec), Addr(LogRec));
LogRec.lfEscapement := Angle*10;
NewFontHandle := CreateFontIndirect(LogRec);
OldFontHandle := SelectObject(ACanvas.Handle, NewFontHandle);
ACanvas.TextOut(X, Y, Str);
NewFontHandle := SelectObject(ACanvas.Handle, OldFontHandle);
DeleteObject(NewFontHandle);
end;
Angle is the angle of rotation in the degrees, clockwise.
If somebody know how display the rotated text with wordwrap property,
then
send a sources or link to me.
PS: I hope that you not forget that on my site you can download a
freeware
TAngleLabel component with correct layout and alignment calculations.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日16:59:38 星期天 说道:
#5: Can I display a node in standard TTreeView component with bold style
without custom drawing?
--------
Time-to-time I receive the question how I realized a selection by the
bold font for some nodes in the SMReport Explorer form.
Today I have decided to describe this very simple way (but very useful).
It does not require an override of any custom drawing methods/events,
creating
a new component etc. It's a real standard way.
**********************************************************
The standard Windows Treeview control have a few state flags
(TVIS_BOLD and TVIS_CUT in our example), due to which it's possible to
reach wished.
At first, let's write the procedure SetNodeState:
procedure SetNodeState(node: TTreeNode; Flags: Integer);
var tvi: TTVItem;
begin
FillChar(tvi, SizeOf(tvi), 0);
tvi.hItem := node.ItemID;
tvi.Mask := TVIF_STATE;
tvi.StateMask := TVIS_BOLD or TVIS_CUT;
tvi.State := Flags;
TreeView_SetItem(node.Handle, tvi);
end;
And now we can set a wished flags:
SetNodeState(node, TVIS_BOLD) - to set the node as Bold
SetNodeState(node, TVIS_CUT) - to set the node as Cutted
SetNodeState(node, TVIS_BOLD or TVIS_CUT) - to set the node as Bold
and
Cutted
SetNodeState(node, 0) - to set a node as normal
*******************************************
PS: tomorrow I'll release a new SMReport Designer and SMReport
Autogenerated.
In new distribution kit I shall include the new demo
application with sources, in which you can view a SetNodeState procedure
using too.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:00:17 星期天 说道:
------------------------------------------------------------------------
--------
If you want to add a horizontal scrollbar in TListBox
(which have a vertical scrollbar only by default),
you need send a LB_SETHORIZONTALEXTENT message:
SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, FMaxItemWidth, 0);
For example, the next code shows how you can scroll a data
with maximum width of item strings:
procedure TForm1.FormCreate(Sender: TObject);
var i, intWidth, intMaxWidth: Integer;
begin
intMaxWidth := 0;
for i := 0 to ListBox1.Items.Count-1 do
begin
intWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i] +
'x');
if intMaxWidth < intWidth then
intMaxWidth := intWidth;
end;
SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, intMaxWidth, 0);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:00:55 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes it's necessary to change a state of TCheckBox component, but
without operation of OnClick event. This task can be solved so:
{set a checked}
yourCheckBox.Perform(BM_SETCHECK, 1, 0);
{set a unchecked}
yourCheckBox.Perform(BM_SETCHECK, 0, 0);
or else in one procedure
procedure ChangeChecked(ACheckBox: TCheckBox; AState: Boolean);
begin
ACheckBox.Perform(BM_SETCHECK, Ord(AState), 0);
end;
For example, if you will call the ChangeChecked(myCheckBox, True),
then will be myCheckBox.Checked = True.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:01:10 星期天 说道:
------------------------------------------------------------------------
--------
If you have installed the Internet Explorer 4.0 or high, in TTreeView
component always displaying a hint for cutted items. It's useful but
sometimes prevents and irritates (at least, me). But there is a simple
way to switch off this feature:
const TVS_NOTOOLTIPS = $0080;
begin
SetWindowLong(yourTreeView.Handle, GWL_STYLE,
GetWindowLong(yourTreeView.Handle, GWL_STYLE) xor
TVS_NOTOOLTIPS);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:01:31 星期天 说道:
------------------------------------------------------------------------
1. OnCreate
2. OnShow
3. OnPaint
4. OnActivate
5. OnResize
6. OnPaint again
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:02:02 星期天 说道:
------------------------------------------------------------------------
--------
If you want to retrieve the line and/or column number you must send a
messages to control and retrieve the result:
For TRichEdit you must send a EM_EXLINEFROMCHAR and EM_LINEINDEX
messages.
For TMemo you must send a EM_LINEFROMCHAR and EM_LINEINDEX messages.
The WParam contains the character number that you wish the line number
for, or -1 for the current line (where the caret is located or the
beginning of a text selection).
View examples:
- for TMemo
LineNumber := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, -1, 0);
- for TRichEdit
LineNumber := SendMessage(RichEdit1.Handle, EM_EXLINEFROMCHAR, 0,
RichEdit1.SelStart);
ColNumber := (RichEdit1.SelStart - SendMessage(RichEdit1.Handle,
EM_LINEINDEX, LineNumber, 0));
PS: not forget that starting values is 0.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:02:33 星期天 说道:
------------------------------------------------------------------------
--------
I wrote a small app which demonstrates how you can use the some combobox
instead standard inplace editor in TStringGrid component.
Also in this app you can view how change font and/or alignment for
some cells.
PS: you can download this app from hotinfo page on my site. The direct
link:
http://www.scalabium.com/faq/strgrid.zip (120K)
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:02:55 星期天 说道:
------------------------------------------------------------------------
--------
Today I have read in book that for standard TMemo component you can
set the offsets!
Try it:
var Rect: TRect;
begin
SendMessage( Memo1.Handle, EM_GETRECT, 0, LongInt(@Rect));
Rect.Left:= 20;
SendMessage(Memo1.Handle, EM_SETRECT, 0, LongInt(@Rect));
Memo1.Refresh;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:03:14 星期天 说道:
------------------------------------------------------------------------
--------
Today I have read, that you can fill a listbox items with file names
by one message only! Try it - it's cool:
var s: string;
begin
s := 'c:\windows\*.bmp'#0;
ListBox1.Perform(LB_DIR, DDL_READWRITE, LongInt(@s[1]));
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:04:09 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes you need change the text alignment in standard TEdit
component.
For some reason the developers in Microsoft decided, that for data
editing in single line we do not need to change alignment and haven't
provided such possibility:(
But sometimes I need it! For example, I like view a numbers with right
alignment...
If you need it too then this delphi tip for you:
type TEditAlignment = class(TCustomEdit)
protected
{ Protected declarations }
procedure CreateParams(var Params: TCreateParams); override;
end;
procedure TEditAlignment.CreateParams(var Params: TCreateParams);
const Alignments: array[TAlignment] of Longint =
(ES_LEFT, ES_RIGHT, ES_CENTER);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or ES_MULTILINE or
Alignments[FAlignment];
end;
In Windows 98 you can set a Params.Style without ES_MULTILINE flag and
it too will work.
Also after such edit control can't correctly work with PasswordChar <>
#0 (but I think for password input it's not necessary to change
alignment).
PS: remark, that after that your TEdit is not "real" edit control -
now is a control like "memo" but single line... Of course, you can use a
standard TMemo component with height equal to one line.
PPS: You can download our freeware TTypedEdit
component(http://www.scalabium.com/edittype.htm)
with extended possibilities for control of user typing, button in right side of
edit, alignment and more
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:04:34 星期天 说道:
------------------------------------------------------------------------
--------
If you need stop any process and wait until your window will be closed
(set a window system modal), you need call:
SetSystemModalWindow(yourForm.Handle);
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:04:44 星期天 说道:
------------------------------------------------------------------------
--------
If you want to create a non-rectangular control or form, you can
create a some region and set this region to your wished window control.
For example, write in OnYourFormCreate event:
SetWindowRgn(Edit1.Handle, CreateRoundRectRgn(2, 2, Edit1.Width - 2,
Edit1.Height - 2, 15, 15), True);
This make the oval edit control.
Also view help for CreateRectRegn, CreateRectRgnIndirect API's
functions.
You can set a region to any window control (to change a form shape, edit
shape etc) - use a YourControl.Handle instead Edit1.Handle in the
example.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:05:43 星期天 说道:
------------------------------------------------------------------------
--------
If you want to add a useful feature to your component (like URL in
html or PageControl/TabControl.HotTrack) you must handle the
CM_MOUSEENTER and CM_MOUSELEAVE messages:
type
TyourControl = class(TDescControl)
private
{ Private declarations }
FLinkFont: TFont;
FPassiveFont: TFont;
procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
end;
implementation
procedure TyourControl.CMMouseEnter(var Msg: TMessage);
begin
//Change color when mouse is over control
Font.Assign(FLinkFont);
end;
procedure TyourControl.CMMouseLeave(var Msg: TMessage);
begin
//Change color when mouse leaves control
Font.Assign(FPassiveFont);
end;
As example, you can view a sources of the
TURLLabel(http://www.scalabium.com/urllbl.htm)
and/or
THighLightLabel(http://www.scalabium.com/hllbl.htm)
components on our site.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:06:35 星期天 说道:
------------------------------------------------------------------------
--------
If you worked with TStringGrid component, then you saw that in this
component the Borland developers not provided the method for row
deleting. In this tip I describe the few ways for it.
1. navigate by rows and copy the row contains to the prev row:
procedure DeleteRow(yourStringGrid: TStringGrid; ARow: Integer);
var i, j: Integer;
begin
with yourStringGrid do
begin
for i := ARow to RowCount-2 do
for j := 0 to ColCount-1 do
Cells[j, i] := Cells[j, i+1];
RowCount := RowCount - 1
end;
end;
2. the modificated #1:
procedure DeleteRow(yourStringGrid: TStringGrid; ARow: Integer);
var i: Integer;
begin
with yourStringGrid do
begin
for i := ARow to RowCount-2 do
Rows[i].Assign(Rows[i+1]);
RowCount := RowCount - 1
end;
end;
3. the "hacked" way. The TCustomGrid type (the TStringGrid is
TCustomGrid's successor) have the DeleteRow method. But this method
allocated not in public section but in protected section. So the all
successors can "see" this DeleteRow method.
type
THackStringGrid = class(TStringGrid);
procedure DeleteRow(yourStringGrid: TStringGrid; ARow: Integer);
begin
with THackStringGrid(yourStringGrid) do
DeleteRow(ARow);
end;
Personally I use the third method but the first and second are more
visual.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:06:48 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in applications you must save the component into BLOB-field of
the own table and in run-time to restore it. For example, to save the
report form and in run-time the end-user will select the wished report
before report generation.
The next two procedure allows to save the component with all
properties and restore it.
procedure SaveCompToBlob(AField: TBlobField; AComponent: TComponent);
var
Stream: TBlobStream;
CompName: string;
begin
CompName := Copy(AComponent.ClassName, 2, 99);
Stream := TBlobStream.Create(AField, bmWrite);
try
Stream.WriteComponentRes(CompName, AComponent);
finally
Stream.Free;
end;
end;
procedure LoadCompFromBlob(AField: TBlobField; AComponent: TComponent);
var
Stream: TBlobStream;
i: integer;
begin
try
Stream := TBlobStream.Create(AField, bmRead);
try
{delete the all child components}
for i := AComponent.ComponentCount - 1 downto 0 do
AComponent.Components[i].Free;
Stream.ReadComponentRes(AComponent);
finally
Stream.Free;
end;
except
on EFOpenError do {nothing};
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:07:18 星期天 说道:
------------------------------------------------------------------------
--------
If you want to change a some property for item in TRadioGroup, you can
do it:
procedure TForm1.Button1Click(Sender: TObject);
begin
TRadioButton(RadioGroup1.Controls[1]).Enabled := False;
end;
Of course, you can change the any property for each item.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:07:30 星期天 说道:
------------------------------------------------------------------------
--------
In some small programms sometimes very useful to store a glyphs in
some external file and in run-time to load these glyphs in own
TImageList. Also if the user can change the images, then in
application closing you can save the TImageList contents into this
external file.
For example, now I develop the small aplication for password keeper
but I don't want to have the any database engine (BDE, ADO etc). I use
the own file format for password storing. Each password record have
the category field. For example, the Provider login, Bank secure code,
Credit Card PIN, Serial Number of application etc
Of course, very useful to assign the some glyph to each category and
show this glyph in password list instead full category name.
I use the next code:
procedure SaveGlyphs(FileName: string; lstImages: TImageList);
begin
with TFileStream.Create(FileName, fmCreate or fmShareExclusive) do
try
WriteComponent(lstImages);
finally
Free;
end;
end;
The similar code you can use for glyphs loading:
procedure ReadGlyphs(FileName: string; lstImages: TImageList);
begin
with TFileStream.Create(FileName, fmOpenRead) do
try
ReadComponent(lstImages);
finally
Free;
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:07:47 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in development you must use the some values (for example,
integer or strings) as data to each item in list (TStrings).
For example, you have the listbox with country name but you want to link
a code value for each item. Or other example: you have a combobox
with colors and you needs to link a color value to each colored line.
These tasks can be easy solved - the TStrings type have:
- the Items property: the string items which will be displayed in
combobox or listbox
- the Objects property: the data which can be linked to each visible
item.
Each Objects[i] is the pointer to some external data.
In this tip I want to explain how you can use this Objects property
for storing of some additional info.
1. to store the integer values:
with qryGroups do
begin
First;
while not Eof do
begin
cbGroups.Items.AddObject(FieldByName('Name').AsString,
TObject(FieldByName('ID').AsInteger));
Next;
end;
end;
to read the integer value from selected item:
strID := LongInt(cbGroups.Items.Objects[cbGroups.ItemIndex]);
Comments: in this example, I used the type convertion - each pointer
is address. But address is an integer value so we can place to item data
the "virtual" address.
2. to store the string values:
with qryGroups do
begin
First;
while not Eof do
begin
cbGroups.Items.AddObject(FieldByName('Name').AsString,
TObject(LongInt(NewStr(FieldByName('ID').
AsString))));
Next;
end;
end;
to read a value from selected item:
strID := PString(cbGroups.Items.Objects[cbGroups.ItemIndex])^;
Comments: in this example I used the address on string which I created
(see a help topic on NewStr).
Also don't forget that you must destroy the objects data which you
created in this example. For exampe, you can do it in OnDestroy event:
for i := 0 to cbGroups.Items.Count-1 do
DisposeStr(PString(cbGroups.Items.Objects[i]));
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:08:01 星期天 说道:
------------------------------------------------------------------------
--------
In few tasks I needs to add a some strings in end of TMemo in run-time
but after that I must show a first strings. For example, it's very
useful in logging system when you inserted a lot of status messages
but user must view a first lines.
This task can be solved in two lines of code:
<.. to add a lines ..>
{set a current position of cursor to start}
SendMessage(Memo1.Handle, EM_SETSEL, 0, 0);
{scroll a memo to start position}
SendMessage(Memo1.Handle, EM_SCROLLCARET, 0, 0);
As alternative method you can set a Memo1.Visible := False before
insertion of new strings and after that to set a Memo1.Visible := True.
You'll receive a same result.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:08:32 星期天 说道:
------------------------------------------------------------------------
--------
Very popular question in delphi forums is: how can I highlight URLs in
RichEdit and how can I detect a mouse click in text where URL is...
And everytime I see the answers like "go to XXXX site and use this
superb XXX product instead RichEdit".
Today I want to show how to implement URL highlighting and URL
navigation without any third-party components. This functionality is
implemented in RichEdit from Microsoft (and MS Outlook use this feature,
for example) and only Borland's developers didn't publish it for us.
So what we need:
1. drop on your form a RichEdit component from win32 page of component
palette
2. in OnCreate event of your form write the next code:
var
mask: Integer;
begin
mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);
SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK);
SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, Integer(True), 0);
RichEdit1.Text := 'Scalabium Software'#13#10 +
' Site is located at www.scalabium.com. Welcome to our site.';
end;
After that your Richedit will convert automatically any URLs in
highlighted (blue color and underlined). Even if you'll start to enter
any text directly in Richedit, any begings for URL will be converted too
(not only existing text string but new too)
3. now we must detect mouse clicks in URL range. For this task we must
override WndProc method of our form:
type
TForm1 = class(TForm)
protected
procedure WndProc(var Message: TMessage); override;
end;
...
procedure TForm1.WndProc(var Message: TMessage);
var
p: TENLink;
strURL: string;
begin
if (Message.Msg = WM_NOTIFY) then
begin
if (PNMHDR(Message.LParam).code = EN_LINK) then
begin
p := TENLink(Pointer(TWMNotify(Message).NMHdr)^);
if (p.msg = WM_LBUTTONDOWN) then
begin
SendMessage(RichEdit1.Handle, EM_EXSETSEL, 0, LongInt(@(p.
chrg)));
strURL := RichEdit1.SelText;
ShellExecute(Handle, 'open', PChar(strURL), 0, 0,
SW_SHOWNORMAL);
end
end
end;
inherited;
end;
Now you can compile your project (don't forget to include Richedit and
ShellAPI units in uses clause) and your RichEdit component will work
like a sharm.
Of course, you can modify a code and process this parsed strURL as you
like instead implemented navigation in browser as I did...
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:10:01 星期天 说道:
Databases
#0021 Database programming technology (Design Patterns)
#0043 To navigate by selected rows in DBGrid
#0062 To get the alias list, tables list etc
#0063 To copy (to dublicate) the dataset record
#0065 To save/restore the component into BLOB-field
#0079 To export a dataset into XML-file
#0081 To check if BDE exists
#0091 To play a wav-file from memory or BLOB-field
#0092 To switch a DBGrid in edit mode and set a cursor in some position
#0108 To generate the script for table creation
#0109 To generate the script for SELECT-statement
#0111 To create table in MS Access with DAO
#0141 To save file in BLOB and restore later
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:10:32 星期天 说道:
------------------------------------------------------------------------
--------
Today I answer in Delphi-DB mailing list about subj. I remember, that
few weeks ago we too wanted to discuss this theme. Also I decided to
post this message here too. Let it will be by today's delphi tip.
********************************************
On server database I have a few own "system" tables with descriptions of
project:
1. CLASS table is a list of all available user queries with short
description, select/update/insert/delete statements
2. DESCRIPTION table stores the descriptions of fields for each record
in CLASS
3. a few additional tables with security (user, groups, privileges,
access modes etc)
PS I do not describe them, as for the basic description they are not
so important
In application I have a main datamodule, which contains the one
TDatabase component (linked to my alias).
Also I have a some TDataModule component which are the parent for each
other. On this component I dropped the TQuery (linked to main
TDataBase), and TUpdateSQL and TDataSource, which are linked to TQuery.
Also in this parent datamodule I included the some additional properties
and procedures/functions:
1. to get a descriptions from server by class name
2. to fill a update/delete/insert properties of TUpdateSQL
3. to change a filter (via where clause), a data order (via order by)
etc (any clause in sql - I use a some macros in own sqls)
4. save/cancel changes, refresh data
5. to get the new ID (for autoincremental fields)
6. to read a user privileges
7. to open class
8. to get a "lookup" class
PS: I not use a delphi lookup fields. Instead it I store in class
descriptions for some fields the additional info (which class I must
open for edit/view of data, which fields are linked in "lookup" class
etc and more)
9. and more additional features
Each datamodule are successor of this parent DM with "personal"
extension in business logic. For example, in the class for details of
orders I defined the specific calculations (some subtotals and sums)
or procedures (check of outputing qnt). The full logic I included in
these DMs only (in visual forms I use a calls only!).
Also I have a basic visual TForm with grid, navigator, filter panel
etc.
This form have a "linked" DataModule. Also this form known how:
1. to fill the info from DM (a columns list for dbgrid (from description
in DM), form caption and more)
2. to call a form for edit/append of record (those form not uses the any
DB-components!!)
3. to generate report (I use a SMReport)
4. to export data (I use a SMExport)
5. to find a record by some criteria
6. to select a records (the some forms I use for selecting of some
recors)
PS: for example, in orders mode my users can select a records from
product class and append the wished
7. to open a "lookup" class
PS: for example, in grid with customer list my users can open a class of
customer types (instead standard delphi lookup field) or "drill" in
orders list for this customer
8. to setup the visualization of data (fonts, colors, order etc, filter,
sort and grouping)
9. and more additional features
All the rest forms are successors of this parent and are different one
from other in needed possibilities only. For example, if my users want
to calculate a sum of some order for specific product type only, of
course, I add a calc function in linked DM and drop a button on form for
calling of this function in DM
PS: in visual forms (when I need to calc or to do a something) I call
the "assigned" method in "assigned" DM.
Also I have a two list - opened DMs and created forms. So if I need open
a "lookup" class, I search it in list of DM and create only if I not
found. And with forms I work similar.
PS: this technology I uses in tens projects (current and finished), in
small app and in big projects. I described the customers-orders-products
schema for availability of understanding only. Of course, sometimes
(more often in the beginning of development of small app) the
perspective of the extension of functionality up to large
client-server system (and especially multi-tier) is not visible and it's
possible to go on easy way - drop on form the ttables (or even to
allocate them in separate datamodule), linked it with grids, use a
master-detail link and lookup fields etc
But when you decide to expand possibilities of the app and transfer it
from local DB (Paradox/DBase/Access etc) on normal DB server and maybe
use a 3-tier you will understand, that is necessary to change the
approach to DB programming for rise of productivity, easy support and
extension of project.
Of course, it's my opinion only, but I have come to such technology by
many cuts and tries during 10 years on different DBs and tools of
development. Though I still do not have also thirty years I have a large
number of successful developments in other departs and if I can to
someone reduce this long way, it will be well.
I do not apply for indisputable true and I know many weak places in
the described technology, but they not impasses - it is simply not up to
the end are realized (and it's good:)))
I shall read criticism of other with pleasure too.
PSS: I'm sorry for long message. I shall be in vacation for Monday (from
6 to 20 September) and if someone will want to ask me (or simply to
write a message), send it not only in list but duplicate it on my e-mail
too, please. I shall be on work today and tomorrow only, but after
vacation I shall answer all messages (if I not answer before vacation
shall have time).
********************************************
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:11:03 星期天 说道:
------------------------------------------------------------------------
--------
If your users can select a rows in the DBGrid, then you must navigate
and process them. The TDBGrid component have a SelectedRows property, in
which stores a list with bookmarks on each selected record.
var i: Integer;
begin
for i := 0 to yourMDBGrid.SelectedRows.Count-1 do
begin
yourMDBGrid.DataSource.DataSet.Bookmark := yourMDBGrid.
SelectedRows[i];
{here you can process a selected record.
For example, to sum the Amount field values}
Inc(intSumAmount, yourMDBGrid.DataSource.DataSet.
FieldByName('Amount').AsFloat);
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:11:30 星期天 说道:
------------------------------------------------------------------------
--------
If you need show in your application the available alias list or
available table list for some alias, you must use the Session variable.
This variable have a lot of useful methods.
For example, if you have the cbAliasNames component (combobox for
alias names), then call:
Session.GetAliasNames(cbAliasnames.Items)
and the items of this combobox will contain the available BDE aliases.
Second example: if you have the cbTablesNames component (combobox for
tables names for some alias), then call:
Session.GetTableNames(strAliasName, cbAliasnames.Items, '', true, False,
cbTablesNames)
and the items of this combobox will contain the available table list for
strAliasName alias. In the second parameter you can specify the
wildcard symbols. Also you can retrieve the data tables only or data and
system tables (view fourth parameter).
The GetAliasParams method allows to retrieve the parameters associated
with wished BDE alias. For example, if you want to read the default user
name and database folder parameters, you must use the next code:
Session.GetAliasParams(strAliasName, cbAliasParams.Items);
edUserName.Text := cbAliasParams.Items.Values['USER NAME'];
edDirectory.Text := cbAliasParams.Items.Values['PATH'];
Also you can retrieve a list of the stored procedures for some
database (view the GetStoredProcNames method of Session variable).
If you need retrieve a list of available BDE drivers only, you must call
the GetDriverNames method. To retrieve the parameters of some driver,
you must call the GetDriverParams methods.
The GetIndexNames method of the TTable component allows to retrieve a
list of all available indexes for a table:
tbl.GetIndexNames(cbIndexNames.Items)
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:11:48 星期天 说道:
------------------------------------------------------------------------
--------
In some apllications, in which user must add a lot of the records in the
dataset, very useful the "copy record" mode.
For example, the operator added the new record and must add the new, but
this second record is "similar" to first and only few attributes are
different. In this case, I use the possibility to dublicate the values
of the wished record, insert a new record and open the dialog for
editing these values.
Those from you, who uses the my freeware TSMDBNavigator component, saw
the new additional Copy button with the next handler:
procedure TSMDBNavigator.CopyRecord;
var varCopyData: Variant;
i: Integer;
begin
with DataSource.DataSet do
begin
varCopyData := VarArrayCreate([0, FieldCount-1], varVariant);
for i := 0 to FieldCount-1 do
varCopyData[i] := Fields[i].Value;
Insert;
for i := 0 to FieldCount-1 do
Fields[i].Value := varCopyData[i];
end;
end;
So you can assign to the TSMDBNavigator.OnEditRecord event the dialog
opening for record edit. In this event I pass the second parameter: is
copy mode or edit mode only.
Of course, you can cut this procedure and use this code for run-time
record dublication without using TSMDBNavigator component. Also you
can modify it and exclude the wished fields (for example,
autoincremental fields).
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:12:23 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in applications you must save the component into BLOB-field of
the own table and in run-time to restore it. For example, to save the
report form and in run-time the end-user will select the wished report
before report generation.
The next two procedure allows to save the component with all
properties and restore it.
procedure SaveCompToBlob(AField: TBlobField; AComponent: TComponent);
var
Stream: TBlobStream;
CompName: string;
begin
CompName := Copy(AComponent.ClassName, 2, 99);
Stream := TBlobStream.Create(AField, bmWrite);
try
Stream.WriteComponentRes(CompName, AComponent);
finally
Stream.Free;
end;
end;
procedure LoadCompFromBlob(AField: TBlobField; AComponent: TComponent);
var
Stream: TBlobStream;
i: integer;
begin
try
Stream := TBlobStream.Create(AField, bmRead);
try
{delete the all child components}
for i := AComponent.ComponentCount - 1 downto 0 do
AComponent.Components[i].Free;
Stream.ReadComponentRes(AComponent);
finally
Stream.Free;
end;
except
on EFOpenError do {nothing};
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:12:43 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in our development we must export a data from dataset into
different formats like MS Excel, Word, HTML, Text etc. Now in the
Internet we have a new popular format - XML-file. So for large part of
applications we wants to include the possibility of export into XML,
of course. I want to demonstrate the sample of one procedure for
exporting of dataset's data into XML:
procedure DatasetToXML(Dataset: TDataset; FileName: string);
The first Dataset parameter is source dataset with data (your Table or
Query component, or some other third-party dataset). The second FileName
parameter is a name of target XML-file.
{ SMExport suite's free demo
Data export from dataset into XML-file
Copyright(C) 2000, written by Scalabium, Shkolnik Mike
E-Mail: smexport@scalabium.com
mshkolnik@yahoo.com
WEB: http://www.scalabium.com
http://www.geocities.com/mshkolnik
}
unit DS2XML;
interface
uses
Classes, DB;
procedure DatasetToXML(Dataset: TDataset; FileName: string);
implementation
uses
SysUtils;
var
SourceBuffer: PChar;
procedure WriteString(Stream: TFileStream; s: string);
begin
StrPCopy(SourceBuffer, s);
Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
end;
procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataset);
function XMLFieldType(fld: TField): string;
begin
case fld.DataType of
ftString: Result := '"string" WIDTH="' + IntToStr(fld.Size) +
'"';
ftSmallint: Result := '"i4"'; //??
ftInteger: Result := '"i4"';
ftWord: Result := '"i4"'; //??
ftBoolean: Result := '"boolean"';
ftAutoInc: Result := '"i4" SUBTYPE="Autoinc"';
ftFloat: Result := '"r8"';
ftCurrency: Result := '"r8" SUBTYPE="Money"';
ftBCD: Result := '"r8"'; //??
ftDate: Result := '"date"';
ftTime: Result := '"time"'; //??
ftDateTime: Result := '"datetime"';
else
end;
if fld.Required then
Result := Result + ' required="true"';
if fld.Readonly then
Result := Result + ' readonly="true"';
end;
var
i: Integer;
begin
WriteString(Stream, '<?xml version="1.0" standalone="yes"?><!--
Generated by SMExport --> ' +
'<DATAPACKET Version="2.0">');
WriteString(Stream, '<METADATA><FIELDS>');
{write th metadata}
with Dataset do
for i := 0 to FieldCount-1 do
begin
WriteString(Stream, '<FIELD attrname="' +
Fields[i].FieldName +
'" fieldtype=' +
XMLFieldType(Fields[i]) +
'/>');
end;
WriteString(Stream, '</FIELDS>');
WriteString(Stream, '<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1"
LCID="1033"/>');
WriteString(Stream, '</METADATA><ROWDATA>');
end;
procedure WriteFileEnd(Stream: TFileStream);
begin
WriteString(Stream, '</ROWDATA></DATAPACKET>');
end;
procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '<ROW');
end;
procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '/>');
end;
procedure WriteData(Stream: TFileStream; fld: TField; AString:
ShortString);
begin
if Assigned(fld) and (AString <> '') then
WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"');
end;
function GetFieldStr(Field: TField): string;
function GetDig(i, j: Word): string;
begin
Result := IntToStr(i);
while (Length(Result) < j) do
Result := '0' + Result;
end;
var Hour, Min, Sec, MSec: Word;
begin
case Field.DataType of
ftBoolean: Result := UpperCase(Field.AsString);
ftDate: Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
ftTime: Result := FormatDateTime('hhnnss', Field.AsDateTime);
ftDateTime: begin
Result := FormatDateTime('yyyymmdd', Field.
AsDateTime);
DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <>
0) then
Result := Result + 'T' + GetDig(Hour, 2) + ':' +
GetDig(Min, 2) + ':' + GetDig(Sec, 2) + GetDig(MSec, 3);
end;
else
Result := Field.AsString;
end;
end;
procedure DatasetToXML(Dataset: TDataset; FileName: string);
var
Stream: TFileStream;
bkmark: TBookmark;
i: Integer;
begin
Stream := TFileStream.Create(FileName, fmCreate);
SourceBuffer := StrAlloc(1024);
WriteFileBegin(Stream, Dataset);
with DataSet do
begin
DisableControls;
bkmark := GetBookmark;
First;
{write a title row}
WriteRowStart(Stream, True);
for i := 0 to FieldCount-1 do
WriteData(Stream, nil, Fields[i].DisplayLabel);
{write the end of row}
WriteRowEnd(Stream, True);
while (not EOF) do
begin
WriteRowStart(Stream, False);
for i := 0 to FieldCount-1 do
WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
{write the end of row}
WriteRowEnd(Stream, False);
Next;
end;
GotoBookmark(bkmark);
EnableControls;
end;
WriteFileEnd(Stream);
Stream.Free;
StrDispose(SourceBuffer);
end;
end.
PS: I created this simple procedure from own TSMExportToXML component
which have a lot of other useful extensions in export process. This
component is part of shareware SMExport suite for Delphi/C++Builder so I
cutted a part of code and created a simple procedure for exporting into
XML.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:12:57 星期天 说道:
------------------------------------------------------------------------
--------
you can check it in two methods:
1. read the registry key:
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('SOFTWARE\Borland\Database Engine', False);
try
s := ReadString('CONFIGFILE01');
//BDE installed
finally
CloseKey;
end;
2. you can try to initialize the BDE
IsBDEExist := Check(dbiInit(nil))
PS: I prefer the second because the some no-good un-installators may
remove the BDE-file but forget to remove the key in registry:)
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:13:11 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes you needs to play a some sounds from own app but store these
sounds in BLOB-field of table or in some external files.
To play a wav-file you must call the PlaySound procedure which have
the few parameters - sound (which you want to play), handle of file with
resource (only for wav from exe/dll-file) and flags for playing.
For example, if you want to play a wav from BLOB, you can use the next
code:
var
b: TBlobStream;
m: TMemoryStream;
begin
b := TBlobStream.Create(yourTable, bmRead);
try
m := TMemoryStream.Create;
try
{copy a wav from BLOB into memory}
m.CopyFrom(b, b.Size);
{Play it but if we'll have an error, raise exception}
Win32Check(PlaySound(m.Memory, 0, SND_SYNC or SND_MEMORY));
finally
m.Free
end;
finally
b.Free
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:13:27 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in development you must control the edit mode of your DBGrid
and, for example, to place a cursor in some position for user typing.
You can view the next code, which show how you can solve this task:
procedure TForm1.Button1Click(Sender: TObject);
var
h: THandle;
begin
{set a focus to DBGrid}
DbGrid1.SetFocus;
{switch to edit mode}
DbGrid1.EditorMode := True;
{receive the handle of current window with edit}
h := Windows.GetFocus;
{send the EM_SETSEL.
You must include the two parameters: the start position of cursor and
end
position of selection. In the next example, I set a cursor in
position of
third character without any selection}
SendMessage(h, EM_SETSEL, 3, 3);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:13:40 星期天 说道:
------------------------------------------------------------------------
--------
As you know in DIM: Database Information Manager I realized the few
typical autogenerated scripts.
For example, for some dataset to generate a standard SELECT-statement or
INSERT-statement.
Today I want to post a sample code which allows to generate the CREATE
TABLE-stetement.
function GetCreateTable(Dataset: TDataSet): TStrings;
var
i: Integer;
str: string;
begin
Result := TStringList.Create;
try
for i := 0 to DataSet.FieldCount-1 do
begin
with DataSet.Fields[i] do
begin
str := ' ' + DataSet.Fields[i].FieldName + ' ' +
GetFieldTypeName(DataType);
if DataType = ftString then
str := str + '(' + IntToStr(Size) + ')';
if Required then
str := str + ' NOT';
str := str + ' NULL';
end;
if (i <> DataSet.FieldCount-1) then
str := str + ',';
Result.Add(str);
end;
except
Result.Free;
Result := nil;
end;
end;
where GetFieldTypeName is
function GetFieldTypeName(AType: TFieldType): string;
const
FieldTypes: array [TFieldType] of PChar =
('?Unknown?', 'Char', 'Smallint', 'Integer', 'Word', 'Boolean',
'Float', 'Currency', 'BCD', 'Date', 'Time', 'DateTime',
'Bytes', 'VarBytes', 'AutoInc', 'Blob', 'Memo', 'Graphic',
'Blob', 'Blob', 'Blob', 'Blob', 'Cursor',
'FixedChar', 'WideString', 'Largeint', 'ADT', 'Array',
'Reference',
'DataSet', 'OraBlob', 'OraClob', 'Variant', 'Interface',
'IDispatch', 'Guid'
);
begin
if AType < Low(FieldTypes) then
AType := Low(FieldTypes)
else
if AType > High(FieldTypes) then
AType := Low(FieldTypes);
Result := UpperCase(StrPas(FieldTypes[AType]));
end;
Few important notes:
1. this code uses the Delphi 5/C++Builder 5 declaration of TFieldType
type. If you use the other version, you must change the declaration of
FieldTypes array
2. syntax of CREATE TABLE-statement depends from database type. So you
must modify it for own needs. You must do it in values of FieldTypes
array items. For example, client-server databases haven't in-build
logical type, so you must declare that CHAR(1) is boolean. Or to use the
MONEY syntax for Currency fields in MS SQL.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:13:52 星期天 说道:
------------------------------------------------------------------------
--------
I know that you have a fan holiday (a Merry Christmas to all!) but I
work today so serie of tips for SQL-script autogeneration is continue..
.
Today I want to publish a small procedure that generate a
SELECT-statement for data of table. This code I uses in DIM: Database
Information Manager:
function GetSelectTable(Dataset: TTable): TStrings;
var
i: Integer;
str: string;
begin
Result := TStringList.Create;
Result.Add('SELECT');
try
for i := 0 to DataSet.FieldCount-1 do
begin
if i = 0 then
str := 'SELECT'
else
str := ',';
str := str + ' ' + DataSet.Fields[i].FieldName;
Result.Add(str);
end;
Result.Add('FROM ' + DataSet.TableName)
except
Result.Free;
Result := nil;
end;
end;
Of course, you can add the ORDER BY-clause (just iterate by index
fields) and/or GROUP BY-clause...
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:14:25 星期天 说道:
------------------------------------------------------------------------
--------
In this tip I want to describe how you can in run-time create a table in
MS Access database using DAO.
I used the next method in SMExport suite:
1. declare the variables:
var
access, db, td, recordset: Variant;
2. declare the array of consts with data type mappings
(between Delphi field types and DAO field types)
arrMDBTypes: array[TFieldType] of Integer =
({dbText} 10 {ftUnknown},
{dbText} 10 {ftString},
{dbInteger} 3 {ftSmallint},
{dbLong} 4 {ftInteger},
{dbInteger} 3 {ftWord},
{dbBoolean} 1 {ftBoolean},
{dbDouble} 7 {ftFloat},
{dbCurrency} 5 {ftCurrency},
{dbDouble} 7 {ftBCD},
{dbDate} 8 {ftDate},
{dbTime} 22 {ftTime},
{dbDate} 8 {ftDateTime},
{dbLongBinary} 11 {ftBytes},
{dbLongBinary} 11 {ftVarBytes},
{dbInteger} 3 {ftAutoInc},
{dbLongBinary} 11 {ftBlob},
{dbMemo} 12 {ftMemo},
{dbLongBinary} 11 {ftGraphic},
{dbMemo} 12 {ftFmtMemo},
{dbLongBinary} 11 {ftParadoxOle},
{dbLongBinary} 11 {ftDBaseOle},
{dbBinary} 9 {ftTypedBinary},
{dbText} 10 {ftCursor}
{$IFDEF VER120}
,
{dbText} 10 {ftFixedChar},
{dbText} 10 {ftWideString},
{dbBigInt} 16 {ftLargeint},
{dbText} 10 {ftADT},
{dbText} 10 {ftArray},
{dbText} 10 {ftReference},
{dbText} 10 {ftDataSet}
{$ELSE}
{$IFDEF VER125}
,
{dbText} 10 {ftFixedChar},
{dbText} 10 {ftWideString},
{dbBigInt} 16 {ftLargeint},
{dbText} 10 {ftADT},
{dbText} 10 {ftArray},
{dbText} 10 {ftReference},
{dbText} 10 {ftDataSet}
{$ELSE}
{$IFDEF VER130}
,
{dbText} 10 {ftFixedChar},
{dbText} 10 {ftWideString},
{dbBigInt} 16 {ftLargeint},
{dbText} 10 {ftADT},
{dbText} 10 {ftArray},
{dbText} 10 {ftReference},
{dbText} 10 {ftDataSet},
{dbLongBinary} 11 {ftOraBlob},
{dbLongBinary} 11 {ftOraClob},
{dbText} 10 {ftVariant},
{dbText} 10 {ftInterface},
{dbText} 10 {ftIDispatch},
{dbGUID} 15 {ftGuid}
{$ENDIF}
{$ENDIF}
{$ENDIF}
);
3. load a DAO:
try
access := GetActiveOleObject('DAO.DBEngine.35');
except
access := CreateOleObject('DAO.DBEngine.35');
end;
4. open a database
try
db := access.OpenDatabase(yourDatabaseName);
except
exit
end;
5. create a new table in opened database
td := db.CreateTableDef(yourTableName, 0, '', '');
6. add a field descriptions in table
td.Fields.Append(td.CreateField(strFieldName,
arrMDBTypes[intDataType], Size));
for example,
td.Fields.Append(td.CreateField('ID', arrMDBTypes[intDataType],
Size));
td.Fields.Append(td.CreateField('NAME', arrMDBTypes[intDataType],
Size));
7. add a table definition in table list
db.TableDefs.Append(td);
8. open the created table in database
recordset := db.OpenTable(yourTableName, 0);
9. append the new record in opened table
recordset.AddNew;
10. change the field values
curField := recordset.Fields[0].Value := 1;
curField := recordset.Fields[1].Value := 'First record';
11. post the new record
recordset.Update(dbUpdateRegular, False);
where
const
dbUpdateRegular = 1;
12. close a recordset
recordset.Close;
13. close a database
db.Close;
14. free a DAO instance
access := UnAssigned;
For example, you can call this code in some cycle. For some task is very
useful.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:14:42 星期天 说道:
------------------------------------------------------------------------
--------
If you develop a database related software, then very popular task is to
save some files (documents/images/reports/etc) in some BLOB field of
table and use these saved data later.
In this tip I want to show how this task could be solved.
To save a file to BLOB:
blob := yourDataset.CreateBlobStream(yourDataset.
FieldByName('YOUR_BLOB'), bmWrite);
try
blob.Seek(0, soFromBeginning);
fs := TFileStream.Create('c:\your_name.doc', fmOpenRead
orfmShareDenyWrite);
try
blob.CopyFrom(fs, fs.Size)
finally
fs.Free
end;
finally
blob.Free
end;
To load from BLOB:
blob := yourDataset.CreateBlobStream(yourDataset.
FieldByName('YOUR_BLOB'), bmRead);
try
blob.Seek(0, soFromBeginning);
with TFileStream.Create('c:\your_name.doc', fmCreate) do
try
CopyFrom(blob, blob.Size)
finally
Free
end;
finally
blob.Free
end;
Using this code you can work with any database engine
(BDE/ADO/DAO/ODBC/DBISAM/etc) and any file format (document of MS Word,
spreadsheet of MS Excel, bitmap or jpeg pictures, wav-files etc)
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:14:57 星期天 说道:
Reports, printing
#0017 Printer settings - page sizes and margins (part1)
#0019 To get a printer settings (part 2)
#0020 To set a printer settings
#0022 Printing on the TPrinter using default resident font (part 1)
#0026 The printer capabilities to print a graphics
#0032 To change the default printer in Windows
#0047 The list of jobs in the MS Windows print spooler
#0068 To use a resident font for printing (part 2)
#0083 To print/preview the MS Access's report
#0087 To send a command strings to printer
#0090 To print a bitmap on printer
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:15:39 星期天 说道:
------------------------------------------------------------------------
--------
From today I shall post a some useful functions for printer settings
detect. Today I include a functions for printer page width/height and
margins getting.
function GetPageWidth: Integer;
begin
Result := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH)
end;
function GetPageHeight: Integer;
begin
Result := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT)
end;
function GetPageOffsetLeft: Integer;
begin
Result := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX)
end;
function GetPageOffsetRight: Integer;
begin
Result := GetPageWidth - GetPageOffsetLeft - GetDeviceCaps(Printer.
Handle, HORZRES)
end;
function GetPageOffsetTop: Integer;
begin
Result := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY)
end;
function GetPageOffsetBottom: Integer;
begin
Result := GetPageHeight - GetPageOffsetTop - GetDeviceCaps(Printer.
Handle, VERTRES)
end;
function GetPixelsPerInchX: Integer;
begin
Result := GetDeviceCaps(Printer.Handle, LOGPIXELSX)
end;
function GetPixelsPerInchY: Integer;
begin
Result := GetDeviceCaps(Printer.Handle, LOGPIXELSY)
end;
PS: of course, the GetPage* and GetPageOffset* results will be in
printer units. If you want to convert in screen units you must
calculate: Result := Screen.PixelsPerInch*GetPage.. div
GetPixelsPerInchX (or Y)
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:15:50 星期天 说道:
------------------------------------------------------------------------
--------
Today I continue to post a tips for printer settings. At first, you must
open the printer device:
At first, you must open the printer device:
var
FDevice: PChar;
FDriver: PChar;
FPort: PChar;
DeviceMode: THandle;
DevMode: PDeviceMode;
procedure OpenThePrinterDevice;
var
Driver_Info2: PDriverInfo2;
Retrieved: dword;
hPrinter: THandle;
begin
Printer().GetPrinter(FDevice, FDriver, FPort, DeviceMode);
if DeviceMode = 0 then
Printer().GetPrinter(FDevice, FDriver, FPort, DeviceMode);
OpenPrinter(FDevice, hPrinter, nil);
GetMem(Driver_Info2, 255);
GetPrinterDriver(hPrinter, nil, 2, Driver_info_2, 255, Retrieved);
StrLCopy(FDriver, PChar(ExtractFileName(StrPas(Driver_Info2^.
PDriverPath)) + #0), 63);
FreeMem(Driver_info_2, 255);
DevMode := GlobalLock(DeviceMode);
end;
And now you can get the information from printer. For example, the
orientation settings:
if ((DevMode^.dmFields and DM_ORIENTATION) = DM_ORIENTATION) and
(DevMode^.dmOrientation = DMORIENT_LANDSCAPE) then
//Landscape
else
//Portrait
Also you can detect a paper size, paper source, print duplex and quality
etc. View a const description in Windows.pas.
At last, don't forget to unlock a device:
GlobalUnlock(DeviceMode);
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:16:01 星期天 说道:
------------------------------------------------------------------------
--------
The next part of the tip for printer settings.
At first, of course, you must open the printer device (as I described in
previous tip " to get a printer settings").
Now you can set the any settings (supported only, of course) in
properties of DevMode^ variable and add a "assigned" flag in DevMode^.
dmFields. After that you need call a SetPrinter procedure and unlock
device.
View small example:
procedure SetPrinterSettings(FPrinter: TPrinter);
var
FDevice: PChar;
FDriver: PChar;
FPort: PChar;
DeviceMode: THandle;
DevMode: PDeviceMode;
begin
{to get a current printer settings}
FPrinter.GetPrinter(FDevice, FDriver, FPort, DeviceMode);
{lock a printer device}
DevMode := GlobalLock(DeviceMode);
{set a paper size as A4-Transverse}
if ((DevMode^.dmFields and DM_PAPERSIZE) = DM_PAPERSIZE) then
begin
DevMode^.dmFields := DevMode^.dmFields or DM_PAPERSIZE;
DevMode^.dmPaperSize := DMPAPER_A4_TRANSVERSE;
end;
{set a paper source as Tractor bin}
if ((DevMode^.dmFields and DM_DEFAULTSOURCE) = DM_DEFAULTSOURCE)
then
begin
DevMode^.dmFields := DevMode^.dmFields or DM_DEFAULTSOURCE;
DevMode^.dmDefaultSource := DMBIN_TRACTOR;
end;
{set a Landscape orientation}
if ((DevMode^.dmFields and DM_ORIENTATION) = DM_ORIENTATION) then
begin
DevMode^.dmFields := DevMode^.dmFields or DM_ORIENTATION;
DevMode^.dmOrientation := DMORIENT_LANDSCAPE;
end;
{set a printer settings}
FPrinter.SetPrinter(FDevice, FDriver, FPort, DeviceMode);
{unlock a device}
GlobalUnlock(DeviceMode);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:16:10 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes for quick printing on the printer canvas I load a default
resident font and draw on the canvas using it.
View a small example:
uses Printers;
procedure TForm1.Button1Click(Sender: TObject);
begin
Printer.BeginDoc;
Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT);
Printer.Canvas.TextOut(100, 50, 'Text string1');
Printer.Canvas.TextOut(100, 150, 'Text string2');
Printer.EndDoc;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:16:20 星期天 说道:
------------------------------------------------------------------------
--------
If you want to detect if your printer is capable of printing graphics,
large bitmaps, and DIBs, then you can check it by the next procedure:
begin
if (GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and RC_NONE) =
RC_NONE then
<graphic is not capable>;
if (GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
RC_STRETCHDIB) =
RC_STRETCHDIB then
<printer supports the StretchDIB>
else
<Windows will simulate the StretchDIB>;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:16:35 星期天 说道:
------------------------------------------------------------------------
--------
If you want to change the the default printer in Windows OS, you must
change
the device key in the Windows section of the WIN.INI. After that you
must
send a WM_WININICHANGE message:
var
strIni: array[0..MAX_PATH] of Char;
arrWindows: array[0..64] of Char;
begin
GetWindowsDirectory(strIni, SizeOf(strIni));
StrCat(strIni, '\win.ini');
with TIniFile.Create(strIni) do
try
WriteString('windows', 'device', 'HP LaserJet 4 Plus,HPPCL5MS,
LPT1:');
finally
Free;
end;
StrCopy(arrWindows, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0,
LongInt(@arrWindows));
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:16:48 星期天 说道:
------------------------------------------------------------------------
--------
If you need detect how many jobs are in the MS Windows print spooler,
then you must handle a WM_SPOOLERSTATUS message. When job is added or
deleted in the spooler querue, this message will be broadcast.
So you must create a message handler for this message trapping:
type
TyourForm = class(TForm)
private
{ Private declarations }
procedure WMSpoolerStatus(var Msg: TWMSpoolerStatus);
message WM_SPOOLERSTATUS;
public
{ Public declarations }
end;
implementation
{$R *.DFM}
procedure TyourForm.WMSpoolerStatus(var Msg: TWMSpoolerStatus);
begin
ShowMessage('Now in the spooler a ' + IntToStr(msg.JobsLeft) + '
jobs';
msg.Result := 0;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:16:58 星期天 说道:
------------------------------------------------------------------------
--------
If you want to print a data on printer with max speed, you must print
with resident font which installed in your printer.
At first, you must receive the handle of font (using the Windows API's
GetStockObject function with DEVICE_DEFAUL_FONT parameter).
After that you must assign this handle to font handle of printer
canvas.
procedure TForm1.Button1Click(Sender: TObject);
var
tm: TTextMetric;
i: Integer;
begin
if PrintDialog1.Execute then
begin
Printer.BeginDoc;
Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT);
GetTextMetrics(Printer.Canvas.Handle, tm);
for i := 1 to 10 do
Printer.Canvas.TextOut(100, i*tm.tmHeight + tm.tmExternalLeading,
'Test string');
Printer.EndDoc;
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:17:35 星期天 说道:
#83: How I can open a report (in Print Preview mode and also print
direct) in an MS Access database?
------------------------------------------------------------------------
In the next small example I'll demonstrate how you can call the report
in MS Access:
var
Access: Variant;
begin
{open the Access application}
try
Access := GetActiveOleObject('Access.Application');
except
Access := CreateOleObject('Access.Application');
end;
Access.Visible := True;
{ open the database
The second parameter specifies whether you want to open the
database in Exclusive mode}
Access.OpenCurrentDatabase('C:\My Documents\Books.mdb', True);
{ open the report
The value for the second parameter should be one of
acViewDesign, acViewNormal, or acViewPreview. acViewNormal, which
is the
default, prints the report immediately. If you are not using the
type
library, you can define these values like this:
const
acViewNormal = $00000000;
acViewDesign = $00000001;
acViewPreview = $00000002;
The third parameter is for the name of a query in the current
database. The fourth parameter is for a SQL WHERE clause - the
string must
be valid SQL, minus the WHERE.}
Access.DoCmd.OpenReport('Titles by Author', acViewPreview, EmptyParam,
EmptyParam);
<...>
{close the database}
Access.CloseCurrentDatabase;
{close the Access application}
{const
acQuitPrompt = $00000000;
acQuitSaveAll = $00000001;
acQuitSaveNone = $00000002;}
Access.Quit(acQuitSaveAll);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:17:49 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes useful to control a printer using direct command strings. It's
a "DOS"-style but for some tasks this method is very useful.
For example, the Epson or HP printers have a lot of internal commands
which allows to change a mode of printer, define the some parameters
etc.
The everybody who tried to convert the DOS-programs from Pascal to
Windows/Delphi, knows that the next statement
WriteLn(lst, Chr(27) + '&l12D')
don't work in Windows. You must use the Escape function to send data
directly to the printer.
View the example code which allows to send a command to printer:
type
TPassThroughData = record
nLen: Word;
Data: array[0..255] of Byte;
end;
procedure PrintText(s: string);
var
PTBlock: TPassThroughData;
begin
PTBlock.nLen := Length(s);
StrPCopy(@PTBlock.Data, s);
Escape(Printer.Handle, PASSTHROUGH, 0, @PTBlock, nil);
end;
procedure PrintOut;
begin
Printer.BeginDoc;
PrintText(#27'&l12D' + 'Hello, World!');
Printer.EndDoc;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:18:09 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes you must from own application to print a some bitmap.
Of course, you can use the some report designer and create a report form
with this bitmap. But you can solve this task and easy - to print a
bitmap on printer canvas directly without any report engine.
Someone from you can say - easy task with solution in few lines of
code:
with Printer do
begin
BeginDoc;
Canvas.Draw(X, Y, bmp);
EndDoc;
end;
But this code will work correctly not with any printer! For example,
Epson Stylus 300 this code will print the image with very bad quality
and on some printer you can receive a blank paper... The reason of
this - using the StretchBlt function for output but in MSDN you can read
that this function does not guarantee a correct outputing from one
device to other.
As alternative you must use the StretchDIBits function:
var
Info: PBitmapInfo;
InfoSize: DWORD;
Image: Pointer;
ImageSize: DWORD;
Bits: HBITMAP;
DIBWidth, DIBHeight: LongInt;
begin
Printer.BeginDoc;
try
Canvas.Lock;
try
{ Paint bitmap to the printer }
with Printer do
begin
Bits := bmp.Handle;
GetDIBSizes(Bits, InfoSize, ImageSize);
Info := AllocMem(InfoSize);
try
Image := AllocMem(ImageSize);
try
GetDIB(Bits, 0, Info^, Image^);
with Info^.bmiHeader do
begin
DIBWidth := biWidth;
DIBHeight := biHeight;
end;
StretchDIBits(Canvas.Handle, 0, 0, DIBWidth, DIBHeight, 0,
0,
DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS,
SRCCOPY);
finally
FreeMem(Image, ImageSize);
end;
finally
FreeMem(Info, InfoSize);
end;
end;
finally
Canvas.Unlock;
end;
finally
Printer.EndDoc;
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:18:35 星期天 说道:
E-mail, Internet, Network
#0037 How to get your local IP?
#0041 PC is connected to a network
#0049 To create the e-mail message in MS Outlook
#0080 To download the file from web
#0088 How do I find a MAC address?
#0095 To receive a modem list, which is installed in Win95/98
#0115 To create an email messaqe by MAPI
#0116 To download a file from internet using sockets
#0117 To select a recipient from addressbook
#0120 To retrieve a folder list from MS Outlook
#0121 To retrieve items (messages/tasks/etc) from any Outllok folder
#0123 To retrieve and save the attachments from MS Outllok message
#0126 HTTP/Url encoding
#0127 to print url/html file using IE browser
#0139 TWebBrowser and POST request
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:18:52 星期天 说道:
------------------------------------------------------------------------
--------
Using the next code you can read a local IP address
function TForm1.LocalIP: string;
type
TaPInAddr = array [0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr: PaPInAddr;
Buffer: array [0..63] of char;
i: Integer;
GInitData: TWSADATA;
begin
WSAStartup($101, GInitData);
Result := '';
GetHostName(Buffer, SizeOf(Buffer));
phe :=GetHostByName(buffer);
if phe = nil then Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
i := 0;
while pptr^[i] <> nil do
begin
result:=StrPas(inet_ntoa(pptr^[i]^));
Inc(i);
end;
WSACleanup;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:19:39 星期天 说道:
------------------------------------------------------------------------
--------
If you want to know if the PC is connected to a network under MS Windows
then you can call a GetSystemMetrics() function (Windows API) with
SM_NETWORK parameter:
if (GetSystemMetrics(SM_NETWORK) AND $01 = $01) then
<PC is attached to network>
else
<PC is not attached to network>
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:19:52 星期天 说道:
------------------------------------------------------------------------
--------
If you need create the message in your mailing app from your Delphi
code, you can:
1. create a message via default mailer using shell api:
uses ShellAPI;
var
pCh: PChar;
begin
pCh := 'mailto:mshkolnik@scalabium.
com?subject=your_subject&body=your_body';
ShellExecute(0, 'open', pCh, nil, nil, SW_SHOWNORMAL);
end;
Few additional comments:
1. the some mailers supports the extended syntax with some usefule
features. For example, the MS Outlook supports the file attachment via
ShellExecute:
var
pCh: PChar;
begin
pCh := 'mailto:mshkolnik@scalabium.
com?subject=your_subject&body=your_body&file="c:\autoexec.bat"';
ShellExecute(0, 'open', pCh, nil, nil, SW_SHOWNORMAL);
end;
But other mailers don't supports this file attachment.
2. you must convert a texts which you want to place into subject or body
- to change a spaces into "%20"
3. on some builds of MS Windows the all characters from subject and body
will be trancated to small length or converted to lower case
2. create a message in Outlook using OLE:
const
olMailItem = 0;
var
Outlook, MailItem: OLEVariant;
begin
try
Outlook := GetActiveOleObject('Outlook.Application');
except
Outlook := CreateOleObject('Outlook.Application');
end;
MailItem := Outlook.CreateItem(olMailItem);
MailItem.Recipients.Add('mshkolnik@scalabium.com');
MailItem.Subject := 'your subject';
MailItem.Body := 'Welcome to my homepage: http://www.scalabium.com';
MailItem.Attachments.Add('C:\Windows\Win.ini');
MailItem.Send;
Outlook := Unassigned;
end;
If you want to create a message in html-format, you can use the HTMLBody
property instead a Body. But note that this HTMLBody property is
available staring from Outlook 98 only.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:20:05 星期天 说道:
------------------------------------------------------------------------
--------
If you needs to download a some file from web, you can use the next code
of DownloadFile procedure.
For example,
begin
Memo1.Lines.Text := DownloadFile('http://www.scalabium.com/sme/index.
htm')
end;
uses WinInet;
function DownloadFile(const Url: string): string;
var
NetHandle: HINTERNET;
UrlHandle: HINTERNET;
Buffer: array[0..1024] of Char;
BytesRead: dWord;
begin
Result := '';
NetHandle := InternetOpen('Delphi 5.x', INTERNET_OPEN_TYPE_PRECONFIG,
nil, nil, 0);
if Assigned(NetHandle) then
begin
UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0,
INTERNET_FLAG_RELOAD, 0);
if Assigned(UrlHandle) then
{ UrlHandle valid? Proceed with download }
begin
FillChar(Buffer, SizeOf(Buffer), 0);
repeat
Result := Result + Buffer;
FillChar(Buffer, SizeOf(Buffer), 0);
InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer),
BytesRead);
until BytesRead = 0;
InternetCloseHandle(UrlHandle);
end
else
{ UrlHandle is not valid. Raise an exception. }
raise Exception.CreateFmt('Cannot open URL %s', [Url]);
InternetCloseHandle(NetHandle);
end
else
{ NetHandle is not valid. Raise an exception }
raise Exception.Create('Unable to initialize Wininet');
end;
PS: in this code I used the functions from WinInet.dll. This dll is a
part of MS Internet Explorer so if you haven't the installed browser
from Microsoft, this code will no workable (you'll receive the exception
message).
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:20:15 星期天 说道:
------------------------------------------------------------------------
--------
The code below gets your MAC address. Should you have more than one
NIC in your machine you will get the MAC off the first one.
function CoCreateGuid(var guid: TGUID): HResult; stdcall; far external
'ole32.dll';
function Get_MACAddress: string;
var
g: TGUID;
i: Byte;
begin
Result := '';
CoCreateGUID(g);
for i := 2 to 7 do
Result := Result + IntToHex(g.D4[i], 2);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:20:26 星期天 说道:
------------------------------------------------------------------------
--------
If you needs to retrieve a list of modems which was installed in MS
Windows, you can use the next procedure:
function EnumModems: TStrings;
var
R: TRegistry;
s: ShortString;
N: TStringList;
i, j: integer;
begin
Result:= TStringList.Create;
R:= TRegistry.Create;
try
with R do
begin
RootKey:= HKEY_LOCAL_MACHINE;
if OpenKey('\System\CurrentControlSet\Services\Class\Modem',
False) then
if HasSubKeys then
begin
N:= TStringList.Create;
try
GetKeyNames(N);
for i := 0 to N.Count-1 do
begin
CloseKey;
OpenKey(N[i], False);
s:= ReadString('AttachedTo');
for j := 1 to 4 do
if Pos(Chr(j+Ord('0')), s) > 0 then
Break;
Result.AddObject(ReadString('DriverDesc'), TObject(j));
CloseKey;
end;
finally
N.Free;
end;
end;
end;
finally
R.Free;
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:20:43 星期天 说道:
------------------------------------------------------------------------
--------
Few months ago I posted a code sample for email sending using MS Outlook
as OLE-object. Today I want to post a tip for email sending using MAPI.
Using MAPI you can control the default mailer whcih was installed in MS
Windows - MS Outlook, MS Outlook Express, Lotus, Netscape etc
The SendMail procedure (view below) can be used in any your project -
just call with parameteres:
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('Error sending mail (' + IntToStr(Result) + ').',
mtError,
[mbOK], 0);
end;
PS: you must add the MAPI unit in USES-clause. To execute this
procedure:
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMail('Re: mailing from Delphi',
'Welcome to http://www.scalabium.com'#13#10'Mike Shkolnik',
'c:\autoexec.bat',
'your name', 'your@address.com',
'Mike Shkolnik', 'mshkolnik@scalabium.com');
end;
Of course, the any parameter of this procedure can be empty.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:20:55 星期天 说道:
------------------------------------------------------------------------
--------
Sometime ago I posted a code sample for file downloading using WinInet.
dll API of MS Internet Explorer). Today I want to post a tip for file
downloading using sockets. Using sockets you can download any file
from any site and no matter which browser type was used in MS Windows
- Explorer, Netscape, Opera etc
The DownloadFile procedure (view below) can be used in any your
project - just call with defined parameters:
procedure DownloadFile(strHost, strRemoteFileName, strLocalFileName:
string;
ClientSocket: TClientSocket);
var
intReturnCode: Integer;
s: string;
szBuffer: array[0..128] of Char;
FileOut: TFileStream;
begin
if strRemoteFileName[1] <> '/' then
strRemoteFileName := '/' + strRemoteFileName;
FileOut := TFileStream.Create(strLocalFileName, fmCreate);
try
with ClientSocket do
begin
Host := strHost;
ClientType := ctBlocking;
Port := 80;
try
Open;
{send query}
s := 'GET ' + strRemoteFileName + ' HTTP/1.0'#13#10 +
'Host: ' + strHost + #13#10#13#10;
intReturnCode := Socket.SendBuf(Pointer(s)^, Length(s));
if intReturnCode > 0 then
begin
{receive the answer}
{ iterate until no more data }
while (intReturnCode > 0) do
begin
{ clear buffer before each iteration }
FillChar(szBuffer, SizeOf(szBuffer), 0);
{ try to receive some data }
intReturnCode := Socket.ReceiveBuf(szBuffer,
SizeOf(szBuffer));
{ if received a some data, then add this data to the
result string }
if intReturnCode > 0 then
FileOut.Write(szBuffer, intReturnCode);
end
end
else
MessageDlg('No answer from server', mtError, [mbOk], 0);
Close;
except
MessageDlg('No connection', mtError, [mbOk], 0);
end;
end;
finally
FileOut.Free
end;
end;
To execute this procedure:
procedure TForm1.Button1Click(Sender: TObject);
begin
DownloadFile('www.scalabium.com', '/forums.htm', 'd:\forums.htm',
ClientSocket1);
end;
PS: the last parameter is ClientSocket component which you must drop
on form from component pallete or create in run-time.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:21:07 星期天 说道:
------------------------------------------------------------------------
--------
Today I want to post a tip about copying of recipients from default
addressbook. For example, user must select a list of recipients and
you'll process this list in own code (to send a message to these
recipients or just import them into own database).
For this task you can use the MAPIAddress procedure from MAPI. This
procedure requires a handle of current session (which you'll receive
from MAPILogOn procedure), custom caption of dialog, structure for
recepient attributes and variable where you'll receive a number of
selected recipients.
If MSPIAddress returns SUCCESS_SUCCESS, this mean that user closed a
dialog and selected some recipients. After that you must navigater by
recipient structure (which you defined as parameter) and process the
each recipient.
For example:
var
lpRecip: TMapiRecipDesc;
intRecips: ULONG;
lpRecips: PMapiRecipDesc;
i: Integer;
begin
if (MAPIAddress(intMAPISession, 0, 'Select the recipients', 4, '', 0,
lpRecip, 0, 0, @intRecips, lpRecips) = SUCCESS_SUCCESS) then
begin
for i := 0 to intRecips-1 do
yourListBox.Items.Add(PMapiRecipDesc(PChar(lpRecips) +
i*SizeOf(TMapiRecipDesc))^.lpszAddress);
MAPIFreeBuffer(lpRecips)
end;
end;
where intMAPISession is an integer varaiable wchich store the handle
of current MAPI session. If you don't use the MapiLogOn which return
this handle, just place a zero value there:
intMAPISession := 0;
I hope that this tip will help you and save some time. At least when I
wrote (in October 2000) this code for own GroupMail, I spent a lot of
time for correct work without errors:-)
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:21:19 星期天 说道:
------------------------------------------------------------------------
--------
I want to post a few tips which are replated to MS Outlook application
and interaction with it from Delphi. The procedure below allow to load a
tree of available folders into TTreeView:
procedure TfrmMain.RetrieveOutlookFolders(tvFolders: TTreeView);
procedure LoadFolder(ParentNode: TTreeNode; Folder: OleVariant);
var
i: Integer;
node: TTreeNode;
begin
for i := 1 to Folder.Count do
begin
node := tvFolders.Items.AddChild(ParentNode, Folder.Item[i].Name;
LoadFolder(node, Folder.Item[i].Folders);
end;
end;
var
outlook, NameSpace: OLEVariant;
begin
outlook := CreateOleObject('Outlook.Application');
NameSpace := outlook.GetNameSpace('MAPI');
LoadFolder(nil, NameSpace.Folders);
outlook := UnAssigned;
end;
A few comments:
1. the data in Outlook have the next structure: outlook application
defines a MAPI's namespace which have a collection of folders. Each
folder contains an items or sub-folders
2. this code load a full tree in TreeView. Of course, if you have a
lot of pst-files with messages (active, archive, backup etc) and each of
this pst-file have a large structure of folders, this code will work
slowly. So as suggestion: you can rewrite a code and load the one
level only. In this case code will work quickly and a list of
sub-folders you'll receive in OnExpanding event of your TreeView
3. each folder of Outlook have an unique idenifier. You can save it
somewhere (for example, in Data property of TTreeNode). Remember that
this ID is long string value which you can receive as EntryID in loop of
LoadFolder procedure: Folder.Item[i].EntryID
PS: if this topic is interested for you, I'll continue this serie of
tips and shall show how to load the messages/contacts/tasks/etc from
some folder or create a new item.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:21:41 星期天 说道:
------------------------------------------------------------------------
--------
Today I want to continue a story about MS Outlook programming.
In previous tip I described how you can retrieve a folder structure
and the next task is to read the items from some folder. As you remember
each folder have the unique identifier (EntryID). So when you want to
read items, you must find this folder by id in MAPI namespace:
outlook := CreateOleObject('Outlook.Application');
NameSpace := outlook.GetNameSpace('MAPI');
Folder := NameSpace.GetFolderByID(EntryID);
After that you must retrieve a type of items in this folder:
intFolderType := Folder.DefaultItemType;
where intFolderType: Integer and can have the one from the next values:
olMailItem $00000000
olAppointmentItem $00000001
olContactItem $00000002
olTaskItem $00000003
olJournalItem $00000004
olNoteItem $00000005
olPostItem $00000006
For example, your folder have an olMailItem type. So the items in your
folder are email messages and the next task is to retrieve a list of
these messages.
Each folder have an Items collection where all items are placed.
To read a number of messages in folder you must check an Folder.Items.
Count.
So the task to navigate by messages is very sample - easy looping.
Important note:
in VBA the first index in collection is 1 instead 0 as in Delphi:
for i := 1 to Folder.Items.Count do
begin
oiItem := Folder.Items[i];
...
end;
Now when you have each item in this folder, you can read any property of
this item. Note that available property list depends from folder type.
For
example, for olMailItem you can read the SenderName, Subject,
ReceivedName, ReceivedByName etc but for olAppointmentItem these
properties are not
available because this folder type have the ReplyTime, Subject and other
properties
Of course, within your looping you can write a standard case-of
statement,
check a folder type and read the specific properties for each folder
type.
For example:
case intFolderType of
olMailItem: s := VarToStr(oiItem.SenderName) + oiItem.Subject +
oiItem.ReceivedTime + oiItem.ReceivedByName;
olAppointmentItem: s := oiItem.Subject + oiItem.ReplyTime;
olContactItem: s := oiItem.FullName + oiItem.Email;
olTaskItem: s := oiItem.SenderName + oiItem.DueDate + oiItem.
PercentComplete;
olJournalItem: s := oiItem.SenderName;
olNoteItem: s := oiItem.Subject + oiItem.CreationTime + oiItem.
LastModificationTime;
olPostItem: s := VarToStr(oiItem.SenderName) + oiItem.Subject +
oiItem.ReceivedTime;
end;
Of course, you can place each item property into separated variable -
I just shown the string concatenation as example. It's very nice to
place the items into string grid or listview but it depends from your
client application
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:22:02 星期天 说道:
------------------------------------------------------------------------
--------
I want to continue the postings about MS Outlook programming in
Borland Delphi.
Today I want to show how you can recieve a list of files in attachment
for any message and save some from these attachments to disk:
Each message have the Attachments collection which contains a list of
files. As usual collection, the Attachments property have the Count
property where you can read a number of files and access to each file
using Item method.
For example, in code below you'll see how to add in TListView
component the rows for each attachment file:
for i := 1 to itemOL.Attachments.Count do
with lvAttachments.Items.Add do
Caption := itemOL.Attachments.Item(i);
Of course, don't forget that VB's collection have the 1 as starting
index.
Also each item in Attachments collection have the SaveAsFile method
which allow to save an attachment into file on disk. The parameter of
SaveAsFile is a desired file name.
itemOL.Attachments.Item(i).SaveAsFile(itemOL.Attachments.Item(i));
I prepeared a small demo application where I included all described tips
for MS Outlook programming. You can download this project with sources:
http://www.scalabium.com/faq/delphioutlook.zip (150Kb)
PS: if you'll have some questions or suggestions, please contact me
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:22:32 星期天 说道:
------------------------------------------------------------------------
--------
Everybody, who wrote some tools for web, know that
urls/filename/script parameters etc are encoded (contains the %xx
substrings).
For example,
http://groups.google.com/groups?q=http%3A%2F%2Fwww.scalabium.
com&hl=ru&meta= site%3Dgroups or http://groups.google.
com/groups?th=1223ec006df22d25&seekm=3b98e41d_2%40dnews
Of course, in code you must decode a value in "real" value. The
algorithm is easiest - after % character the next 2 positions are
decimal code of character.
But also for this task you can use the HTTPEncode function from
HttpApp unit:
function HTTPEncode(const AStr: String): String;
const
NoConversion = ['A'..'Z','a'..'z','*','@','.','_','-'];
var
Sp, Rp: PChar;
begin
SetLength(Result, Length(AStr) * 3);
Sp := PChar(AStr);
Rp := PChar(Result);
while Sp^ <> #0 do
begin
if Sp^ in NoConversion then
Rp^ := Sp^
else
if Sp^ = ' ' then
Rp^ := '+'
else
begin
FormatBuf(Rp^, 3, '%%%.2x', 6, [Ord(Sp^)]);
Inc(Rp,2);
end;
Inc(Rp);
Inc(Sp);
end;
SetLength(Result, Rp - PChar(Result));
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:22:44 星期天 说道:
------------------------------------------------------------------------
--------
today I want to show how you can activate printing of any url and/or
html file using installed IE.
I solved this task yesterday and solution is very useful and have a
small size:-)
uses ComObj;
procedure PrintHTMLByIE(const url: string);
const
OLECMDID_PRINT = $00000006;
OLECMDEXECOPT_DONTPROMPTUSER = $00000002;
var
ie, vaIn, vaOut: Variant;
begin
ie := CreateOleObject('InternetExplorer.Application');
ie.Navigate(url);
ie.Visible := True;
ie.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;
Sample:
PrintHTMLByIE('file:\\c:\misha\webpage\index.htm');
or
PrintHTMLByIE('http:\\www.scalabium.com\sme\index.htm');
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:22:55 星期天 说道:
------------------------------------------------------------------------
--------
Today I want to describe how you can send some data to web-server from
your remote script using TWebBrowser component.
var
strData: string;
PostData: OleVariant;
Headers: OleVariant;
i: Integer;
begin
{1. you must create a string with parameter names and values
Result string must be in the next format:
Param1=Value1&Param2=Value2&Param3=Value3...}
strData := 'Param1Name=' + HTTPEncode(Param1Value) + '&' +
'Param2Name=' + HttpEncode(Param2Value) + ...;
{2. you must convert a string into variant array of bytes and
every character from string is a value in array}
PostData := VarArrayCreate([0, Length(strData) - 1], varByte);
{ copy the ordinal value of the character into the PostData array}
for i := 1 to Length(strData) do
PostData[i-1] := Ord(strData[i]);
{3. prepare headers which will be sent to remote web-server}
Headers := 'Content-Type: application/x-www-form-urlencoded' +
#10#13;
{4. you must navigate to the URL with your script and send as
parameters
your array with POST-data and headers}
yourWebBrowserComponent.Navigate('http://www.yourdomain.
com/your_post_script.asp', EmptyParam, EmptyParam, PostData, Headers);
end;
Of course, the same task can be solved with any internet component which
implement the http-client (not only TWebBrowser). But for every
component the data for script will be posted by own rules (most
components have pre-defined properties for this task).
For example, you can use my TSMIHTTPClient component from SMInternet
suite. There you must set Action=haPost and fill the Headers property
with own Post-data.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:23:20 星期天 说道:
Multimedia
#0015 To open/close a CD-drive
#0078 To sound a beep for some action
#0091 To play a wav-file from memory or BLOB-field
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:23:36 星期天 说道:
------------------------------------------------------------------------
--------
1. If you want to open a CD-drive from your program, you need:
mciSendString('Set cdaudio door open wait', nil, 0, Handle);
2. If you want to close a CD-drive from your program, you need:
mciSendString('Set cdaudio door closed wait', nil, 0, Handle);
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:23:47 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in development very useful to sound a "context" beep. For
example, user entered the incorrect value - you can show the message
dialog with information about it but also useful to beep with "error"
sound.
Try this - it's very useful for end-user as context help/assistent:
uses Windows;
procedure PlayBeep(ActionType: TMsgDlgType);
var mb: dWord;
begin
case ActionType of
mtInformation: mb := MB_ICONASTERISK; //SystemAsterisk
mtWarning: mb := MB_ICONEXCLAMATION; //SystemExclamation
mtError: mb := MB_ICONHAND; //SystemHand
mtConfirmation: mb := MB_ICONQUESTION; //SystemQuestion
mtCustom: mb := MB_OK; //SystemDefault
else
mb:= $0FFFFFFFF; //Standard beep using the computer speaker
end;
MessageBeep(mb);
end;
PS: don't use it very frequently because users'll be angry:)
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:23:58 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes you needs to play a some sounds from own app but store these
sounds in BLOB-field of table or in some external files.
To play a wav-file you must call the PlaySound procedure which have
the few parameters - sound (which you want to play), handle of file with
resource (only for wav from exe/dll-file) and flags for playing.
For example, if you want to play a wav from BLOB, you can use the next
code:
var
b: TBlobStream;
m: TMemoryStream;
begin
b := TBlobStream.Create(yourTable, bmRead);
try
m := TMemoryStream.Create;
try
{copy a wav from BLOB into memory}
m.CopyFrom(b, b.Size);
{Play it but if we'll have an error, raise exception}
Win32Check(PlaySound(m.Memory, 0, SND_SYNC or SND_MEMORY));
finally
m.Free
end;
finally
b.Free
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:24:15 星期天 说道:
Conversions
#0042 To convert the bitmap to Jpeg and vice versa
#0044 To convert a color string into HTML format
#0045 To convert color value into gray-scaled color value
#0132 To add leading zeros for numbers
#0137 To create a disabled bitmap
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:24:35 星期天 说道:
------------------------------------------------------------------------
--------
You can use the next code for conversion of bitmap into jpeg or jpeg
into bitmap:
uses Jpeg;
procedure Bmp2Jpeg(const BmpFileName, JpgFileName: string);
var
Bmp: TBitmap;
Jpg: TJPEGImage;
begin
Bmp := TBitmap.Create;
Jpg := TJPEGImage.Create;
try
Bmp.LoadFromFile(BmpFileName);
Jpg.Assign(Bmp);
Jpg.SaveToFile(JpgFileName);
finally
Jpg.Free;
Bmp.Free;
end;
end;
procedure Jpeg2Bmp(const BmpFileName, JpgFileName: string);
var
Bmp: TBitmap;
Jpg: TJPEGImage;
begin
Bmp := TBitmap.Create;
Jpg := TJPEGImage.Create;
try
Jpg.LoadFromFile(JpgFileName);
Bmp.Assign(Jpg);
Bmp.SaveToFile(BmpFileName);
finally
Jpg.Free;
Bmp.Free;
end;
end;
I uses these procedures for picture format changing in own PictView
application.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:24:46 星期天 说道:
------------------------------------------------------------------------
--------
If you want to create a HTML-file, you must define a tag for font
color or backgroubd color. But you can't insert a Delphi's TColor
value - you must convert the color into RGB-format. In own SMExport
suite I use the next
function:
function GetHTMLColor(cl: TColor; IsBackColor: Boolean): string;
var rgbColor: TColorRef;
begin
if IsBackColor then
Result := 'bg'
else
Result := '';
rgbColor := ColorToRGB(cl);
Result := Result + 'color="#' + Format('%.2x%.2x%.2x',
[GetRValue(rgbColor),
GetGValue(rgbColor),
GetBValue(rgbColor)]) +
'"';
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:24:55 星期天 说道:
------------------------------------------------------------------------
--------
If you want to convert a colored image into same gray scaled, then you
must convert the color of the each pixel by the next schema:
function RgbToGray(Source: TColor) : TColor;
var Target: Byte;
begin
Target := Round((0.30 * GetRValue(Source)) +
(0.59 * GetGValue(Source)) +
(0.11 * GetBValue(Source)));
Result := RGB(Target, Target, Target);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:25:11 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes you need add the leading zeros to numbers for formatted
printing of report forms or data exporting.
For this task I wrote a small function which return a formatted string
(see below the AddLeadingZeros function).
But today I found that standard Format function allow to do a same!
Format('%.10d', [15]) will return '0000000015'
Don't ask me why in Delphi help you'll not find the description of
this formatted string or why I didn't find it before:-(
Below is my old function:
function AddLeadingZeros(const Source: string; Len: Integer): string;
var
i: Integer;
begin
Result := Source;
for i := 1 to (Len-Length(Source)) do
Result := '0' + Result;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:25:36 星期天 说道:
------------------------------------------------------------------------
--------
After some delay when I released a lot of new versions/components I want
to post a new tip:-)
Everyone from you saw that standard TSpeedButton allow to show a
loaded glyph in "disabled" state when your original glyph will be
converted into gray-scheme.
Sometimes to create similar bitmap is useful not only for TSpeedButton.
You can use the next my CreateDisabledBitmap procedure where such
"disabled" bitmap (Destination parameter) will be created from your
original bitmap (Source).
procedure CreateDisabledBitmap(Source, Destination: TBitmap);
const
ROP_DSPDxax = $00E20746;
var
DDB, MonoBmp: TBitmap;
IWidth, IHeight: Integer;
IRect: TRect;
begin
IWidth := Source.Width;
IHeight := Source.Height;
Destination.Width := IWidth;
Destination.Height := IHeight;
IRect := Rect(0, 0, IWidth, IHeight);
Destination.Canvas.Brush.Color := clBtnFace;
Destination.Palette := CopyPalette(Source.Palette);
MonoBmp := nil;
DDB := nil;
try
MonoBmp := TBitmap.Create;
DDB := TBitmap.Create;
DDB.Assign(Source);
DDB.HandleType := bmDDB;
{ Create a disabled version }
with MonoBmp do
begin
Assign(Source);
HandleType := bmDDB;
Canvas.Brush.Color := clBlack;
Width := IWidth;
if Monochrome then
begin
Canvas.Font.Color := clWhite;
Monochrome := False;
Canvas.Brush.Color := clWhite;
end;
Monochrome := True;
end;
with Destination.Canvas do
begin
Brush.Color := clBtnFace;
FillRect(IRect);
Brush.Color := clBtnHighlight;
SetTextColor(Handle, clBlack);
SetBkColor(Handle, clWhite);
BitBlt(Handle, 1, 1, IWidth, IHeight,
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
Brush.Color := clBtnShadow;
SetTextColor(Handle, clBlack);
SetBkColor(Handle, clWhite);
BitBlt(Handle, 0, 0, IWidth, IHeight,
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
end;
finally
DDB.Free;
MonoBmp.Free;
end;
Source.Dormant;
end;
Sample of use:
procedure TfrmMain.ButtonClick(Sender: TObject);
var
Destination: TBitmap;
begin
Destination := TBitmap.Create;
try
CreateDisabledBitmap(Image1.Picture.Bitmap, Destination);
Image2.Picture.Bitmap.Assign(Destination);
finally
Destination.Free
end
end;
where Image1 is TImage where you have an original bitmap and TImage2
will a container for created disabled bitmap.
Hope this tip will be useful for someone from you...
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:26:37 星期天 说道:
Algorithms
#0039 To save/load a font information in INI/text-file
#0048 CRC32 calculation
#0056 To play with colors (dark/light)
#0093 Hash function for strings
#0113 Correct round of number
#0124 extended DayOfWeek function
#0125 second Wednesday of November
#0129 checksum by modulus 10
#0136 ELF hash algorithm
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:26:40 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes you need to save/to load a font information in INI-file,
Registry or some text file.
Now I desribe the some different methods.
1. very easy but not result isn't compact and effective (by data
storage)
procedure SaveFont(FStream: TIniFile; Section: string; smFont: TFont);
begin
FStream.WriteString(Section, Ident + 'Name', smFont.Name);
FStream.WriteInteger(Section, Ident + 'CharSet', smFont.CharSet);
FStream.WriteInteger(Section, Ident + 'Color', smFont.Color);
FStream.WriteInteger(Section, Ident + 'Size', smFont.Size);
FStream.WriteInteger(Section, Ident + 'Style', Byte(smFont.Style));
end;
procedure LoadFont(FStream: TIniFile; Section: string; smFont: TFont);
begin
smFont.Name := FStream.ReadString(Section, Ident + 'Name', smFont.
Name);
smFont.CharSet := TFontCharSet(FStream.ReadInteger(Section, Ident +
'CharSet', smFont.CharSet));
smFont.Color := TColor(FStream.ReadInteger(Section, Ident + 'Color',
smFont.Color));
smFont.Size := FStream.ReadInteger(Section, Ident + 'Size', smFont.
Size);
smFont.Style := TFontStyles(Byte(FStream.ReadInteger(Section, Ident
+ 'Style', Byte(smFont.Style))));
end;
2. more hardly than first method, but result is compact. I use this
method in all own apps.
procedure SaveFont(FStream: TIniFile; Section: string; smFont: TFont);
begin
FStream.WriteString(Section, 'Font', smFont.Name + ',' +
IntToStr(smFont.CharSet) + ','
+
IntToStr(smFont.Color) + ',' +
IntToStr(smFont.Size) + ',' +
IntToStr(Byte(smFont.Style)));
end;
procedure LoadFont(FStream: TIniFile; Section: string; smFont: TFont);
var s, Data: string;
i: Integer;
begin
s := FStream.ReadString(Section, 'Font', ',,,,');
try
i := Pos(',', s);
if i > 0 then
begin
{Name}
Data := Trim(Copy(s, 1, i-1));
if Data <> '' then
smFont.Name := Data;
Delete(s, 1, i);
i := Pos(',', s);
if i > 0 then
begin
{CharSet}
Data := Trim(Copy(s, 1, i-1));
if Data <> '' then
smFont.Charset := TFontCharSet(StrToIntDef(Data, smFont.
Charset));
Delete(s, 1, i);
i := Pos(',', s);
if i > 0 then
begin
{Color}
Data := Trim(Copy(s, 1, i-1));
if Data <> '' then
smFont.Color := TColor(StrToIntDef(Data, smFont.Color));
Delete(s, 1, i);
i := Pos(',', s);
if i > 0 then
begin
{Size}
Data := Trim(Copy(s, 1, i-1));
if Data <> '' then
smFont.Size := StrToIntDef(Data, smFont.Size);
Delete(s, 1, i);
{Style}
Data := Trim(s);
if Data <> '' then
smFont.Style := TFontStyles(Byte(StrToIntDef(Data,
Byte(smFont.Style))));
end
end
end
end;
except
end;
end;
3. as alternative for 1&2 methods I can offer the third - you can create
a temporary stream, save the wished font component in this stream
(Stream.SaveComponent) and then you can navigate the byte-by-byte in
stream, to convert each byte into hex (or some other radix) and save
into your text file as string. Each byte is a two symbols for hex radix.
For font reading - on the contrary...
PS: personally I not used this method:)))
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:26:53 星期天 说道:
------------------------------------------------------------------------
--------
If you need calculate a CRC32 for some file or some string, then you
must do:
1. build a CRC table
2. calculate a CRC for each line of your file
3. calculate a total CRC
1. CRC table creation:
type
Long = record
LoWord: Word;
HiWord: Word;
end;
const
CRCPOLY = $EDB88320;
var
CRCTable: array[0..512] Of Longint;
procedure BuildCRCTable;
var
i, j: Word;
r: Longint;
begin
FillChar(CRCTable, SizeOf(CRCTable), 0);
for i := 0 to 255 do
begin
r := i shl 1;
for j := 8 downto 0 do
if (r and 1) <> 0 then
r := (r Shr 1) xor CRCPOLY
else
r := r shr 1;
CRCTable[i] := r;
end;
end;
2. CRC calculation for file:
function RecountCRC(b: byte; CrcOld: Longint): Longint;
begin
RecountCRC := CRCTable[byte(CrcOld xor Longint(b))] xor ((CrcOld shr
8) and $00FFFFFF)
end;
function HextW(w: Word): string;
const
h: array[0..15] Of char = '0123456789ABCDEF';
begin
HextW := '';
HextW := h[Hi(w) shr 4] + h[Hi(w) and $F] + h[Lo(w) shr 4]+h[Lo(w) and
$F];
end;
function HextL(l: Longint): string;
begin
with Long(l) do
HextL := HextW(HiWord) + HextW(LoWord);
end;
function GetCRC32(FileName: string): string;
var
Buffer: PChar;
f: File of Byte;
b: array[0..255] of Byte;
CRC: Longint;
e, i: Integer;
begin
BuildCRCTable;
CRC := $FFFFFFFF;
AssignFile(F, FileName);
FileMode := 0;
Reset(F);
GetMem(Buffer, SizeOf(B));
repeat
FillChar(b, SizeOf(b), 0);
BlockRead(F, b, SizeOf(b), e);
for i := 0 to (e-1) do
CRC := RecountCRC(b[i], CRC);
until (e < 255) or (IOresult <> 0);
FreeMem(Buffer, SizeOf(B));
CloseFile(F);
CRC := Not CRC;
Result := '$' + HextL(CRC);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:27:03 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in run-time you need play with colors. For example, you have
the some color value and you want to make it more dark or light. The
next two function were written for it.
function Dark(Col: TColor; Percent: Byte): TColor;
var R, G, B: Byte;
begin
R := GetRValue(Col);
G := GetGValue(Col);
B := GetBValue(Col);
R := Round(R*Percent/100);
G := Round(G*Percent/100);
B := Round(B*Percent/100);
Result := RGB(R, G, B);
end;
function Light(Col: TColor; Percent: Byte): TColor;
var R, G, B: Byte;
begin
R := GetRValue(Col);
G := GetGValue(Col);
B := GetBValue(Col);
R := Round(R*Percent/100) + Round(255 - Percent/100*255);
G := Round(G*Percent/100) + Round(255 - Percent/100*255);
B := Round(B*Percent/100) + Round(255 - Percent/100*255);
Result := RGB(R, G, B);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:27:14 星期天 说道:
------------------------------------------------------------------------
--------
Today I found a good hash function in delphi sources (dbtables.pas):
function GetHashCode(Str: PChar): Integer;
var
Off, Len, Skip, I: Integer;
begin
Result := 0;
Off := 1;
Len := StrLen(Str);
if Len < 16 then
for I := (Len - 1) downto 0 do
begin
Result := (Result * 37) + Ord(Str[Off]);
Inc(Off);
end
else
begin
{ Only sample some characters }
Skip := Len div 8;
I := Len - 1;
while I >= 0 do
begin
Result := (Result * 39) + Ord(Str[Off]);
Dec(I, Skip);
Inc(Off, Skip);
end;
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:27:25 星期天 说道:
------------------------------------------------------------------------
--------
From first times when was released a Borland Pascal, in sources was
included a "bank" algorithm of number rounding.
For example,
Round(25.5) = 26
but
Round(26.5) = 26.
For banks or some other financial organizations this algorithm is good
but in other type of calculations we want a standard rounding. For
this tasks I use the own small function that I use instead standard:
function CorrectRound(x: Extended): LongInt;
begin
Result := Trunc(x);
if (Frac(x) >= 0.5) then
Result := Result + 1;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:27:38 星期天 说道:
------------------------------------------------------------------------
--------
As you know, the default DayOfWeek function from SysUtils unit returns
the day of week for some date. But in this function uses the Sunday as
first day of the week and the Saturday as the seventh.
In some countries this function is not useful because the first day of
the week is a Monday instead Sunday. The function below can be used in
this case:
For example, in code below you'll see how to add in TListView
component the rows for each attachment file:
function DayOfWeekMon2Sun(dtDate: TDateTime): Integer;
const
StartOfWeek: Integer = 2;
begin
Result := (DayOfWeek(dtDate) - StartOfWeek + 7) mod 7 + 1;
end;
I wrote this function a lot of time ago when I started the development
of scheduler program and wanted to add a possibility to define a
custom timesheet (like in MS Outlook).
I hope that this function will be useful for you too.
PS: as you see, I used the const value (StartOfWeek) as shift. So if
your country use the some other order in days of the week, you can
change this const value.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:27:49 星期天 说道:
------------------------------------------------------------------------
--------
Today I want to continue a posting of small routunies for date playing.
In any scheduler you can define the desired time of execution as "Second
Wednesday" of some month/year. To calculate such dates is very simple
task.
I'll show it on small sample. For example, you want to calculate a
date of second Wednesday of November in the 2001.
In this case you must:
1. to receive a date of first day in November 2001:
dt := EncodeDate(2001, 11, 1);
2. to calculate a first Wednesday in the November:
while (DayOfWeek(dt) <> 4) do
dt := dt + 1;
3. to calculate a next Wednesday:
dt := dt + 7;
The similar method you can use for calculation of last Wednesday of
November 2001:
1. to receive a date of last day in November 2001:
dt := EncodeDate(2001, 11, 30);
2. to calculate a last Wednesday in the November:
while (DayOfWeek(dt) <> 4) do
dt := dt - 1;
Of course, you can use the similar code for calculation of third
Sunday or fourth Friday in any month of any year.
I used this schema in own application for database synchronization which
supports a custom scheduler and my users like this feature. I hope that
you'll add something like that in the own applications.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:28:07 星期天 说道:
------------------------------------------------------------------------
--------
Today I want to publish a code for checksum calculation by modulus 10.
This algirithm is very popular for UPC barcodes (Universal Product
Code), hash code or serial number generation for applications etc...
The basic algorithm:
add the values of the digits in the odd positions (1, 3, 5...)
multiply this result by 3
add the values of the digits in the even positions (2, 4, 6...)
sum the results of steps 2 and 3
the check digit is the smallest number which, when added to the result
in step 4, produces a multiple of 10.
Small example. Assume the source data is 08137919805
0+1+7+8+5=22
22*3=66
8+3+9+9+0=29
66+29=95
95+??=100 where ?? is a 5 (our checksum)
My implementation in the Pascal:
function Mod10(const Value: string): Integer;
var
i, intOdd, intEven: Integer;
begin
{add all odd seq numbers}
intOdd := 0;
i := 1;
while (i < Length(Value)) do
begin
Inc(intOdd, StrToIntDef(Value[i], 0));
Inc(i, 2);
end;
{add all even seq numbers}
intEven := 0;
i := 2;
while (i < Length(Value)) do
begin
Inc(intEven, StrToIntDef(Value[i], 0));
Inc(i, 2);
end;
Result := 3*intOdd + intEven;
{modulus by 10 to get}
Result := Result mod 10;
if Result <> 0 then
Result := 10 - Result
end;
You can expand this algorithm for own needs.
For example, I modified it and\par now I use it for any characters
(not only digits) in source value.
The original algorithm I use for UPC-barcode validation in the
SMReport Designer and the my extended algorithm I use in the serial
number generation as part of the protection schema (in the shareware
projects).
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:28:33 星期天 说道:
------------------------------------------------------------------------
--------
Sometime ago I posted a code for hash calculation of strings (CRC32
and easy method which is extracted from VCL sources). Today I want to
post a code for ELF algorithm which allow to receive a strong
distributed hash from string. This algorithm is very popular because can
be implemented in any programming language (from VB to Java) and is a
very-very fast (contain one easy loop only).
See a code below:
function ElfHash(const Value: string): Integer;
var
i, x: Integer;
begin
Result := 0;
for i := 1 to Length(Value) do
begin
Result := (Result shl 4) + Ord(Value[i]);
x := Result and $F0000000;
if (x <> 0) then
Result := Result xor (x shr 24);
Result := Result and (not x);
end;
end;
A few examples you can see in table below:
Text value
Calculated elf-hash
Scalabium Software 189378421
Scalabium 136833325
scalabium.com 153641565
www.scalabium.com 156665277
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:30:01 星期天 说道:
Files, drives
#0031 To detect a drive type
#0046 To get a file datetime
#0050 How do I execute a program and have my code wait until it is
finished?
#0051 To create a shell link/shortcut
#0055 To get the serial number of a disk
#0058 To accept the dropped files from Windows Explorer
#0066 The file in use or not
#0075 To map the network disk
#0114 To load a file list by some wildcard
#0118 To recieve a number of files in some folder by wildcard
#0122 To change a creation date/time for file on disk
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:30:39 星期天 说道:
------------------------------------------------------------------------
--------
If you want to detect a drive type (CD/Floppy/Network...), then you must
use a GetDriveType function from Windows API.
For example,
case GetDriveType('C:\') of
0: <unknown>;
1: <root directory does not exist>;
DRIVE_REMOVABLE: <floppy>;
DRIVE_FIXED: <hard drive>;
DRIVE_REMOTE: <network>;
DRIVE_CDROM: <CD-ROM>;
DRIVE_RAMDISK: <RAM disk>;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:30:48 星期天 说道:
------------------------------------------------------------------------
--------
If you want to receive a datetime of the specified file, then you must
to call a FileAge function and convert the returned value using the
FileDateToDateTime function into a TDateTime value:
function GetFileDateTime(FileName: string): TDateTime;
var intFileAge: LongInt;
begin
intFileAge := FileAge(FileName);
if intFileAge = -1 then
Result := 0
else
Result := FileDateToDateTime(intFileAge)
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:31:01 星期天 说道:
------------------------------------------------------------------------
--------
The next procedure allows you to execute a program and to wait until
it's finished:
function WinExecAndWait32(FileName: string; Visibility: Integer):
dWord;
var
zAppName: array[0..512] of Char;
zCurDir: array[0..255] of Char;
WorkDir: string;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
StrPCopy(zAppName, FileName);
GetDir(0, WorkDir);
StrPCopy(zCurDir, WorkDir);
FillChar(StartupInfo, Sizeof(StartupInfo), #0);
StartupInfo.cb := Sizeof(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not CreateProcess(nil,
zAppName, { pointer to command line string }
nil, { pointer to process security attributes }
nil, { pointer to thread security attributes }
false, { handle inheritance flag }
CREATE_NEW_CONSOLE or { creation flags }
NORMAL_PRIORITY_CLASS,
nil, { pointer to new environment block }
nil, { pointer to current directory name }
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo) then
Result := -1 { pointer to PROCESS_INF }
else
begin
WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, Result);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:31:17 星期天 说道:
------------------------------------------------------------------------
--------
If you need create a shell link from your application (for example, from
you setup app), you can use the next code:
procedure CreateShortCut(ShortCut, Application, Parameters, WorkDir:
string; SW_State: Integer; IconFile: string; IconIndex: Byte);
var
SCObject: IUnknown;
SCSLink: IShellLink;
SCPFile: IPersistFile;
WFName: WideString;
begin
SCObject := CreateComObject(CLSID_ShellLink);
SCSLink := SCObject as IShellLink;
SCPFile := SCObject as IPersistFile;
SCSLink.SetPath(PChar(Application));
SCSLink.SetArguments(PChar(Parameters));
SCSLink.SetWorkingDirectory(PChar(WorkDir));
SCSLink.SetShowCmd(SW_State);
SCSLink.SetIconLocation(PChar(IconFile), IconIndex);
WFName := ShortCut;
SCPFile.Save(PWChar(WFName), False);
end;
For example:
CreateShortCut(ShortCut, Application, Parameters, WorkDir: string;
SW_State: Integer; IconFile: string; IconIndex: Byte);
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:31:59 星期天 说道:
------------------------------------------------------------------------
--------
If you need retrieve the serial number of a disk, you can call the
GetVolumeInformation function from Windows API. View example:
var
VolumeSerialNumber: DWORD;
MaximumComponentLength: DWORD;
FileSystemFlags: DWORD;
SerialNumber: string;
begin
GetVolumeInformation('C:\',
nil,
0,
@VolumeSerialNumber,
MaximumComponentLength,
FileSystemFlags,
nil,
0);
SerialNumber := IntToHex(HiWord(VolumeSerialNumber), 4) +
'-' +
IntToHex(LoWord(VolumeSerialNumber), 4);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:33:08 星期天 说道:
------------------------------------------------------------------------
--------
If you need accept the dropped files from the some external
application (for example, from Windows Explorer), you must call the
DragAcceptFiles for your form (in which you want to accept) and handle
the WM_DROPFILES message.
I used this algoritm when I wrote the small editor.
I post the next code as simple example:
type
TForm1 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
protected
procedure WMDROPFILES (var Msg: TWMDropFiles); message
WM_DROPFILES;
private
public
end;
var
Form1: TForm1;
implementation
uses ShellApi;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Handle, True);
end;
procedure TForm1.WMDROPFILES(var Msg: TWMDropFiles);
var
i, amount: Integer;
FileName: array[0..MAX_PATH] of Char;
begin
inherited;
try
Amount := DragQueryFile(Msg.Drop, $FFFFFFFF, FileName, MAX_PATH);
for i := 0 to (Amount - 1) do
begin
DragQueryFile(Msg.Drop, i, FileName, MAX_PATH);
listbox1.items.add(FileName);
end;
finally
DragFinish(Msg.Drop);
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:33:19 星期天 说道:
------------------------------------------------------------------------
--------
In some situations of your applications you must check: the file is
locked for exclusive access or not. The next function you can use for
this check:
function FileInUse(FileName: string): Boolean;
var hFileRes: HFILE;
begin
Result := False;
if not FileExists(FileName) then exit;
hFileRes := CreateFile(PChar(FileName),
GENERIC_READ or GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
Result := (hFileRes = INVALID_HANDLE_VALUE);
if not Result then
CloseHandle(hFileRes);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:33:37 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in run-time you must map/unmap the some remote resource. You
can make it with the next code:
uses Windows;
var nw: TNetResource;
begin
nw.dwType := RESOURCETYPE_DISK;
nw.lpLocalName := nil;
nw.lpRemoteName := PChar('\\yourServerName\yourDiskOnServer');
nw.lpProvider := nil;
errCode := WNetAddConnection2(nw, nil, nil, 0);
if errCode = NO_ERROR then
<Ok, disk mapped>
end;
If the remote server have the password, then you must call the
errCode := WNetAddConnection2(nw, 'strPassword', nil, 0);
If you want to map this disk as own local resource, you must define
the lpLocalName. For example,
nw.lpLocalName := 'F:';
When you want to un-map resource, you must call the
WNetCancelConnection2 procedure.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:33:52 星期天 说道:
------------------------------------------------------------------------
--------
After small delay with tip posting I want to continue this important
task:-)
Today I'll post a small sample which show how you can receive a list
of files from some specific directory by some custom wildcard. For
example, to load in listbox the bmp-files from Windows directory.
procedure LoadFilesByMask(lst: TStrings; const SpecDir, WildCard:
string);
var
intFound: Integer;
SearchRec: TSearchRec;
begin
lst.Clear;
intFound := FindFirst(SpecDir + WildCard, faAnyFile, SearchRec);
while intFound = 0 do
begin
lst.Add(SpecDir + SearchRec.Name);
intFound := FindNext(SearchRec);
end;
FindClose(SearchRec);
end;
For example, to load bmp-files from application folder:
LoadFilesByMask(lbFiles.Items, ExtractFilePath(Application.ExeName),
'*.bmp')
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:34:04 星期天 说道:
------------------------------------------------------------------------
--------
Today I want to post tip with small function which allow to calculate
a number of files in a specified directory.
function GetFilesCount(Folder, WildCard: string): Integer;
var
intFound: Integer;
SearchRec: TSearchRec;
begin
Result := 0;
if (Folder <> '') and (Folder[Length(Folder)] <> '\') then
Folder := Folder + '\';
intFound := FindFirst(Folder + WildCard, faAnyFile, SearchRec);
while (intFound = 0) do
begin
if not (SearchRec.Attr and faDirectory = faDirectory) then
Inc(Result);
intFound := FindNext(SearchRec);
end;
FindClose(SearchRec);
end;
To use:
i := GetFilesCount('d:\', '*.zip'); //retrieve a number of
zip-archives
i := GetFilesCount('c:\windows\', '*.bmp'); //retrieve a number of
bitmaps
i := GetFilesCount('c:\My Documents', '*.*'); //retrieve a total
number of any files
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:34:17 星期天 说道:
------------------------------------------------------------------------
--------
Today I want to show how you can change a datetime of file creation from
own application:
function SetDateToFile(const FileName: string; Value: TDateTime):
Boolean;
var
hFile: THandle;
intResult: Integer;
begin
Result := False;
try
{open a file handle}
hFile := FileOpen(FileName, fmOpenWrite or fmShareDenyNone);
{if opened succesfully}
if (hFile > 0) then
{convert a datetime into DOS format and set a date}
intResult := (FileSetDate(hFile, DateTimeToFileDate(Value)) = 0)
finally
{close an opened file handle}
FileClose(hFile);
end;
end;
To use:
SetDateToFile('C:\My Documents\application.cfg', Now());
This code can be useful in case of application protection - you can
store in creation date of some your file a same important value. For
example, version of application or date of first start for your trial.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:34:39 星期天 说道:
Menu
#0030 To add item into system menu
#0033 To add bitmaps to menu items
#0060 To align a menu item to right
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:34:57 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes I must insert a new items into system menu of some form. I
think that I such not one...
type TyourForm = class(TForm)
private
{ Private declarations }
procedure wmSysCommand(var Message:TMessage); message
WM_SYSCOMMAND;
end;
const
ID_ABOUT = Word(-1);
implementation
procedure TyourForm.wmSysCommand;
begin
if Message.wParam = ID_ABOUT then
begin
<some actions>
end;
inherited;
end;
procedure TyourForm.FormCreate(Sender: TObject);
var sysMenu: THandle;
begin
sysMenu := GetSystemMenu(Handle, False);
AppendMenu(sysMenu, MF_SEPARATOR, Word(-1), '');
AppendMenu(sysMenu, MF_BYPOSITION, ID_ABOUT, 'About...');
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:35:08 星期天 说道:
------------------------------------------------------------------------
--------
From Delphi 4 you can add the bitmaps to your menu items.
But in Delphi 2/3 you haven't such useful possibility.
I use the next method:
1. you must declare a TBitmap variable:
var bmp: TBitmap
2. load the bitmap (from file, resource etc):
bmp.LoadFromFile('c:\yourPath\...\copy.bmp');
In default MS Windows settings the glyphs in menu have a 12x12pixels. If
your bitmap have other size, then this bitmap will stretched.
3. set bitmap to menu item:
SetMenuItemBitmaps(yourMenu.Handle, intIndex, MF_BYPOSITION, bmp.Handle,
bmp.Handle),
where:
- yourMenu is a menu component (TMainMenu or TPopupMenu)
- intIndex is a menu item position (from 0)
- first bmp.Handle is a handle of bitmap for unchecked state
- second bmp.Handle is a handle of bitmap for checked state
Of course, you can set the same bmp.Handle or set the different
bitmaps for unchecked/checked states
PS: some days ago the one registered user ask me: "why in your
SMReport Designer you not use a glyphs in menu?". I forgot it! Of
course, yesterday I included such feature in few minutes and "SMReport
use the bitmaps in menu and is MS Office compatible now...":))
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:35:20 星期天 说道:
------------------------------------------------------------------------
--------
The Microsoft GUI guide not allow to change the align of some menu
item but from DOS-time personally I like to align a Help menu item to
right.
But in some applications from Microsoft I saw the right-aligned menu
item too:) If you want to align the item in own application, you can
call the ModifyMenu function with MF_POPUP or MF_HELP flag.
View example:
uses
Windows;
procedure TForm1.FormCreate(Sender: TObject);
begin
ModifyMenu(yourMainMenu.Handle, 0, MF_BYPOSITION or MF_POPUP or
MF_HELP, yourMenuItem.Handle, 'yourCaption');
end;
The altrenative method:
var
MMI: TMenuItemInfo;
MyMenu: hMenu;
Buffer: array[0..79] of Char;
begin
MyMenu := GetMenu(Handle);
// Handle is the handle of the form that contains the menu
MMI.cbSize := SizeOf(MMI);
MMI.fMask := MIIM_TYPE;
MMI.dwTypeData := Buffer;
MMI.cch := SizeOf(Buffer);
GetMenuItemInfo(MyMenu, 1, True, MMI);
// (..., 1, True, ...) means that help is the second menu item.
MMI.fType := MMI.fType or MFT_RIGHTJUSTIFY;
SetMenuItemInfo(MyMenu, 1, True, MMI);
end;
PS: I'm not sure that this code will work on each Windows platform.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:35:39 星期天 说道:
Tools API
#0003 How can I check the Delphi/C++Builder version?
#0040 To read/write a property by name
#0054 To get a name of enum value
#0069 To receive a names of all registered components
#0070 To receive a names of all palettes, which was registered in IDE
#0073 To receive the list of published properties of component (part
1)
#0074 To receive the list of published properties of component (part
2)
#0103 To change a default font in IDE
#0104 To disable a new project creation
#0119 To register a component editor which will be actavted by right
mouse click in Delphi IDE
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:36:14 星期天 说道:
------------------------------------------------------------------------
--------
* VER70 is Borland Pascal 7.0
* VER80 is Delphi 1.0
* VER90 is Delphi 2.0
* VER93 is BCB++ 1.0
* VER100 is Delphi 3.0
* VER110 is BCB++ 3.0
* VER120 is Delphi 4.0
* VER125 is BCB++4.0
* VER130 is Delphi 5.0
* VER140 is Delphi 6.0
* VER150 is Delphi 7.0
In program source you can check this value. For example, in sources of
TSMDBGrid component I use
the next:
var
{$IFDEF VER120}
I: TColorRef;
{$ELSE}
I: Integer;
{$ENDIF}
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:36:31 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes you need to change a some property for each components. Of
course, if these components have a common ancestor, then you can write:
var i: Integer;
begin
for i := 0 to ComponentCount-1 do
if Components[i] is TyourAncestor then
TyourAncestor(Components[i]).yourProperty := yourValue;
end;
For example,
var i: Integer;
begin
for i := 0 to ComponentCount-1 do
if Components[i] is TSpeedButton then
TSpeedButton(Components[i]).Flat := True;
end;
But frequently you need change a property but the components haven't a
common ancestor. In an example above you can have a TSpeedButton's
components and TDBNavigator component on same panel. These components
have taken place from different ancesors and you must change a
property as different. You can make following:
var i: Integer;
PropInfo: PPropInfo;
begin
for i := 0 to ComponentCount-1 do
begin
PropInfo := GetPropInfo(Components[i].ClassInfo, yourPropertyName);
{if such property exists}
if Assigned(PropInfo) then
SetOrdProp(Components[i], PropInfo, LongInt(yourPropertyValue));
end;
end;
Of course, if you have not ordinary property (like Flat), you need
call a different procedure. The following procedures were declared in
typinfo.pas:
procedure SetOrdProp(Instance: TObject; PropInfo: PPropInfo;
Value: Longint);
procedure SetStrProp(Instance: TObject; PropInfo: PPropInfo;
const Value: string);
procedure SetFloatProp(Instance: TObject; PropInfo: PPropInfo;
Value: Extended);
procedure SetVariantProp(Instance: TObject; PropInfo: PPropInfo;
const Value: Variant);
procedure SetMethodProp(Instance: TObject; PropInfo: PPropInfo;
const Value: TMethod);
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:36:41 星期天 说道:
------------------------------------------------------------------------
--------
For example, if you have the some enum type
TyourEnumType = (One, Two, Three, Four, Five, Six, Seven, Eight, Nine,
Ten)
and you want in run-time to get a string with same value for each of
them (for example, fill the combobox items with enum values), then you
can use the next procedure:
uses TypInfo;
var i: Integer;
begin
for i := Ord(Low(TyourEnumType)) to Ord(High(TyourEnumType)) do
Combobox1.Items.Add(GetEnumName(TypeInfo(TyourEnumType), i));
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:36:51 星期天 说道:
------------------------------------------------------------------------
--------
If you want to write the own expert for Delphi/C++Builder IDE and you
want to display the names of all registered components, you can use
the next code:
uses TypInfo, ToolIntf, Exptintf;
procedure GetComponentNames(lst: TStrings);
var
i, k: Integer;
CRef: TClass;
strName: ShortString;
begin
lst.Clear;
for i := 0 to ToolServices.GetModuleCount-1 do
begin
for k := 0 to ToolServices.GetComponentCount(i)-1 do
begin
CRef := TClass(GetClass(ToolServices.GetComponentName(i, k)));
while CRef <> nil do
begin
strName := CRef.ClassName;
if lst.IndexOf(strName) = -1 then
lst.Add(strName);
if str <> 'TComponent' then
CRef := CRef.ClassParent
else
CRef := nil;
end;
end;
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:37:00 星期天 说道:
------------------------------------------------------------------------
--------
To continue the IDE expert subject:))
If you want to write the own expert for Delphi/C++Builder IDE and you
want to display the names of all registered palette, you can use the
next code:
uses Registry;
procedure GetPaletteNames(lst: TStrings);
var i: Integer;
begin
with TRegistry.Create do
try
if OpenKeyReadOnly('Software\Borland\Delphi\4.0\Palette') then
GetValueNames(lst);
finally
Free;
end;
for i := 0 to lst.Count-1 do
if Pos('.', lst.Strings[i]) > 0 then
lst.Delete(i);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:37:09 星期天 说道:
------------------------------------------------------------------------
--------
If you needs a list of published properties for some component, you must
use the GetPropInfos function in TypInfo unit. For example,
uses TypInfo;
procedure GetPublishedProperties(comp: TComponent; lst: TStrings);
var
Props: PPropList;
TypeData: PTypeData;
i: Integer;
begin
TypeData := GetTypeData(comp.ClassInfo);
if (TypeData = nil) or (TypeData^.PropCount = 0) then Exit;
GetMem(Props, TypeData^.PropCount * sizeof(Pointer));
try
GetPropInfos(comp.ClassInfo, Props);
for i := 0 to TypeData^.PropCount-1 do
begin
with Props^[i]^ do
lst.Add(Name);
end;
finally
FreeMem(Props);
end;
end;
PS: I started to develop the component like Object Inspector for
SMReport Designer. So maybe in some future I'll finish it...
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:37:21 星期天 说道:
------------------------------------------------------------------------
--------
Yesterday I posted the tip about list of published properties. Today I
found the second method to do a same but this method is easy:
var
i, j: Integer;
PropList: TPropList;
begin
GetPropList(Obj.ClassInfo, TypeKinds, @PropList);
j := High(PropList);
i := 0;
while (i < j) and Assigned(PropList[i]) do
begin
lbInspector.Items[i] := PropList[i].Name + ': ' + PropList[i].
PropType^.Name;
Inc(i)
end
end;
where
TypeKinds := tkProperties
or
TypeKinds := tkMethods
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:37:29 星期天 说道:
------------------------------------------------------------------------
--------
Each time when you must add a new form in own project, this form will be
created with MS SanSerif font as default font.
Of course, you can save a some form in the repository and create a
newest forms from this saved form or inherits this form from some own
"parent" form but you have the other solution too - you can define a
default font for forms. It's easy!
You must open the DELPHI.INI file (in Windows folder) and add the
FormDesign section. In this section you must add a value with default
font.
For example:
[FormDesign]
DefaultFont=Arial, 9
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:37:42 星期天 说道:
------------------------------------------------------------------------
--------
In the last weeks I had a lot of work with releases of SMLogging and
SMExport and I didn't post a delphi tips. In the next days I want to
release the SMImport but today I want to post a two tips:))
Each time when you run a Delphi you receive the new project with empty
form. You can change an IDE setting and set the option for loading of
last project. It's useful but what you must do when you want to run
the IDE without project opening? Solution is easy: you must run the
deklphi with additional parameter:
delphi32.exe /np
Just change the command line in your shortcut and will be happy:))
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:37:56 星期天 说道:
------------------------------------------------------------------------
--------
Today I want to show how you can register a custom component editor in
Delphi IDE.
For example, you wrote some own component and want to add some menu
items which will be shown in design-time popupmenu. You can assign a lot
of useful "shortcut" methods there.
For example, for any export/import component I assigned two menu items:
About and Execute, for report components I defined three menu items:
About, Preview and Print.
Such method is very useful for components. For example, for standard
TPageControl you can can in one click to add a new page or navigate by
pages (Next/Prev).
For this feature you must write and register a component editor for your
component:
type
TyourNewComponentEditor = class(TComponentEditor)
procedure ExecuteVerb(Index: Integer); override;
function GetVerb(Index: Integer): string; override;
function GetVerbCount: Integer; override;
end;
where
function TyourNewComponentEditor.GetVerbCount: Integer;
begin
{total number of your newest items in popup menu}
Result := 2;
end;
function TyourNewComponentEditor.GetVerb(Index: Integer): string;
begin
{names for each item}
case Index of
0: Result := 'Item1...';
1: Result := 'Item2...';
end;
end;
procedure TyourNewComponentEditor.ExecuteVerb(Index: Integer);
begin
{actions for each item}
with (Component as TyourNewComponent) do
case Index of
0: MethodForItem1;
1: MethodForItem2;
end
end;
and to register it:
procedure Register;
begin
RegisterComponentEditor(TyourNewComponent, TyourNewComponentEditor);
end;
It's all:-)
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:38:13 星期天 说道:
OLE, COM
#0049 To create the e-mail message in Outlook
#0051 To create a shell link/shortcut
#0083 print/preview the MS Access's report
#0086 To register the file extention and context menu
#0089 Description of Instancing and Threading Models in COM-servers
#0120 To retrieve a folder list from MS Outlook
#0128 To create an appointment in MS Outlook
#0142 To to read a sender address for MailItem (MS Outlook)
#0143 To check if OLE object is installed
#0144 Fast data transfer to MS Excel
#0145 Contact list in MS Outlook
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:38:52 星期天 说道:
------------------------------------------------------------------------
--------
If you need create the message in your mailing app from your Delphi
code, you can:
1. create a message via default mailer using shell api:
uses ShellAPI;
var
pCh: PChar;
begin
pCh := 'mailto:mshkolnik@scalabium.
com?subject=your_subject&body=your_body';
ShellExecute(0, 'open', pCh, nil, nil, SW_SHOWNORMAL);
end;
Few additional comments:
1. the some mailers supports the extended syntax with some usefule
features. For example, the MS Outlook supports the file attachment via
ShellExecute:
var
pCh: PChar;
begin
pCh := 'mailto:mshkolnik@scalabium.
com?subject=your_subject&body=your_body&file="c:\autoexec.bat"';
ShellExecute(0, 'open', pCh, nil, nil, SW_SHOWNORMAL);
end;
But other mailers don't supports this file attachment.
2. you must convert a texts which you want to place into subject or body
- to change a spaces into "%20"
3. on some builds of MS Windows the all characters from subject and body
will be trancated to small length or converted to lower case
2. create a message in Outlook using OLE:
const
olMailItem = 0;
var
Outlook, MailItem: OLEVariant;
begin
try
Outlook := GetActiveOleObject('Outlook.Application');
except
Outlook := CreateOleObject('Outlook.Application');
end;
MailItem := Outlook.CreateItem(olMailItem);
MailItem.Recipients.Add('mshkolnik@scalabium.com');
MailItem.Subject := 'your subject';
MailItem.Body := 'Welcome to my homepage: http://www.scalabium.com';
MailItem.Attachments.Add('C:\Windows\Win.ini');
MailItem.Send;
Outlook := Unassigned;
end;
If you want to create a message in html-format, you can use the HTMLBody
property instead a Body. But note that this HTMLBody property is
available staring from Outlook 98 only.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:39:07 星期天 说道:
------------------------------------------------------------------------
--------
If you need create a shell link from your application (for example, from
you setup app), you can use the next code:
procedure CreateShortCut(ShortCut, Application, Parameters, WorkDir:
string; SW_State: Integer; IconFile: string; IconIndex: Byte);
var
SCObject: IUnknown;
SCSLink: IShellLink;
SCPFile: IPersistFile;
WFName: WideString;
begin
SCObject := CreateComObject(CLSID_ShellLink);
SCSLink := SCObject as IShellLink;
SCPFile := SCObject as IPersistFile;
SCSLink.SetPath(PChar(Application));
SCSLink.SetArguments(PChar(Parameters));
SCSLink.SetWorkingDirectory(PChar(WorkDir));
SCSLink.SetShowCmd(SW_State);
SCSLink.SetIconLocation(PChar(IconFile), IconIndex);
WFName := ShortCut;
SCPFile.Save(PWChar(WFName), False);
end;
For example:
CreateShortCut(ShortCut, Application, Parameters, WorkDir: string;
SW_State: Integer; IconFile: string; IconIndex: Byte);
------------------------------------------------------------------------
--------
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:39:17 星期天 说道:
--------
#83: How I can open a report (in Print Preview mode and also print
direct) in an MS Access database?
------------------------------------------------------------------------
--------
In the next small example I'll demonstrate how you can call the report
in MS Access:
var
Access: Variant;
begin
{open the Access application}
try
Access := GetActiveOleObject('Access.Application');
except
Access := CreateOleObject('Access.Application');
end;
Access.Visible := True;
{ open the database
The second parameter specifies whether you want to open the
database in Exclusive mode}
Access.OpenCurrentDatabase('C:\My Documents\Books.mdb', True);
{ open the report
The value for the second parameter should be one of
acViewDesign, acViewNormal, or acViewPreview. acViewNormal, which
is the
default, prints the report immediately. If you are not using the
type
library, you can define these values like this:
const
acViewNormal = $00000000;
acViewDesign = $00000001;
acViewPreview = $00000002;
The third parameter is for the name of a query in the current
database. The fourth parameter is for a SQL WHERE clause - the
string must
be valid SQL, minus the WHERE.}
Access.DoCmd.OpenReport('Titles by Author', acViewPreview, EmptyParam,
EmptyParam);
<...>
{close the database}
Access.CloseCurrentDatabase;
{close the Access application}
{const
acQuitPrompt = $00000000;
acQuitSaveAll = $00000001;
acQuitSaveNone = $00000002;}
Access.Quit(acQuitSaveAll);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:40:46 星期天 说道:
------------------------------------------------------------------------
--------
When you create a new COM object, you must define the Instancing and
Threading Model, which will be used in your COM object. For example,
when you use the Automation Object Wizard (select File|New from main
menu, click the ActiveX tab and select Automation Object Wizard item)
you must select a desired values of Instancing/Threading Model from
comboboxes.
In this article I'll include a short description for each value.
1. Instancing refers to how many instances of the COM object are created
for a request of client. You can select a one option from three
available items: Single Instance, Multiple Instance and Internal.
a) Single Instance - allows only a single COM interface for each
executable. So creating multiple single instances results in creating
multiple copies of the server application. This option is commonly
used for multiple document interface (MDI) applications.
b) Multiple Instance - specifies that multiple applications can
connect to the object. Any time a client requests service, a separete
instance of the server gets invoked. That is, there can be multiple
instances in a single executable. For example, any time a user
attempts to open the Windows Explorer, a separate Explorer is created
c) Internal - means the object can only be created internally. An
external application cannot create an instance of the object directly.
For example, a word processor application may have an internal
document object that can only be created by calling a method of the
application that will create the document object.
2. The Threading Model refers to how your object is advertised to the
client applications via its thread support. You can select one from
the next options: Single, Apartment, Free or Both.
a) Single - no thread support. Client requests are serialized by the
standard calling mechanism. serialized by the calling mechanism. With
this threading model the clients are handled one at a time so no
threading
support is needed.
b) Apartment - different objects from the same server can be called on
different threads or different clients, but each object is called only
from that one thread. If two clients need to use the same object, they
have to take turns. With this threading model the instance data is safe,
global data must be protected using critical sections or some other
form of serialization. Of course, the thread's local variables are
reliable across multiple calls.
c) Free - clients can call any method of object from any thread at any
time. Objects can handle any number of threads at any time. That is,
more than one client can share the same object. Objects must protect all
instance and global data using critical sections or some other form
of serialization. Thread local variables are not reliable across
multiple calls. Primarily used for distributed DCOM environments.
d) Both - objects can support clients that use either Aprtment or Free
threading models. This threading model give a maximum performance and
flexibility.
So a correct value selection of Instancing and Threading Model can
affect on performance of your COM object and depends from task which you
want realize in this object.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:41:00 星期天 说道:
------------------------------------------------------------------------
--------
I want to post a few tips which are replated to MS Outlook application
and interaction with it from Delphi. The procedure below allow to load a
tree of available folders into TTreeView:
procedure TfrmMain.RetrieveOutlookFolders(tvFolders: TTreeView);
procedure LoadFolder(ParentNode: TTreeNode; Folder: OleVariant);
var
i: Integer;
node: TTreeNode;
begin
for i := 1 to Folder.Count do
begin
node := tvFolders.Items.AddChild(ParentNode, Folder.Item[i].Name;
LoadFolder(node, Folder.Item[i].Folders);
end;
end;
var
outlook, NameSpace: OLEVariant;
begin
outlook := CreateOleObject('Outlook.Application');
NameSpace := outlook.GetNameSpace('MAPI');
LoadFolder(nil, NameSpace.Folders);
outlook := UnAssigned;
end;
A few comments:
1. the data in Outlook have the next structure: outlook application
defines a MAPI's namespace which have a collection of folders. Each
folder contains an items or sub-folders
2. this code load a full tree in TreeView. Of course, if you have a
lot of pst-files with messages (active, archive, backup etc) and each of
this pst-file have a large structure of folders, this code will work
slowly. So as suggestion: you can rewrite a code and load the one
level only. In this case code will work quickly and a list of
sub-folders you'll receive in OnExpanding event of your TreeView
3. each folder of Outlook have an unique idenifier. You can save it
somewhere (for example, in Data property of TTreeNode). Remember that
this ID is long string value which you can receive as EntryID in loop of
LoadFolder procedure: Folder.Item[i].EntryID
PS: if this topic is interested for you, I'll continue this serie of
tips and shall show how to load the messages/contacts/tasks/etc from
some folder or create a new item.
------------------------------------------------------------------------
--------
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:41:11 星期天 说道:
------------------------------------------------------------------------
--------
Today I want to continue a serie of tips for MS Outlook automatization
from Delphi.
If you want to create a new appointment, you can use a code sample
below:
uses ComObj;
procedure CreateNewAppointment;
const
olAppointmentItem = $00000001;
olImportanceLow = 0;
olImportanceNormal = 1;
olImportanceHigh = 2;
{to find a default Contacts folder}
function GetCalendarFolder(folder: OLEVariant): OLEVariant;
var
i: Integer;
begin
for i := 1 to folder.Count do
begin
if (folder.Item[i].DefaultItemType = olAppointmentItem) then
Result := folder.Item[i]
else
Result := GetCalendarFolder(folder.Item[i].Folders);
if not VarIsNull(Result) and not VarIsEmpty(Result) then
break
end;
end;
var
outlook, ns, folder, appointment: OLEVariant;
begin
{initialize an Outlook}
outlook := CreateOLEObject('Outlook.Application');
{get MAPI namespace}
ns := outlook.GetNamespace('MAPI');
{get a default Contacts folder}
folder := GetCalendarFolder(ns.Folders);
{if Contacts folder is found}
if not VarIsNull(folder) and not VarIsEmpty(folder) then
begin
{create a new item}
appointment := folder.Items.Add(olAppointmentItem);
{define a subject and body of appointment}
appointment.Subject := 'new appointment';
appointment.Body := 'call me tomorrow';
{location of appointment}
appointment.Location := 'room 3, level 2';
{duration: 10 days starting from today}
appointment.Start := Now() + 0.05;
appointment.End := Now()+10; {10 days for execution}
appointment.AllDayEvent := 1; {all day event}
{set reminder in 20 minutes}
appointment.ReminderMinutesBeforeStart := 20;
appointment.ReminderSet := 1;
{set a high priority}
appointment.Importance := olImportanceHigh;
{add a few recipients}
appointment.Recipients.Add('person1@domain.com');
appointment.Recipients.Add('person2@domain.com');
{change an organizer name}
appointment.Organizer := 'organizer@domain.com';
{to save an appointment}
appointment.Save;
{to display an appointment}
appointment.Display(True);
{to print a form}
appointment.PrintOut;
end;
{to free all used resources}
folder := UnAssigned;
ns := UnAssigned;
outlook := UnAssigned
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:41:22 星期天 说道:
------------------------------------------------------------------------
--------
Sometime ago I posted a few tips for MS Outlook automation. I want to
continue this serie.
If you tried to work with messages from Delphi, you know that received
message have the SenderName property (name of sender) but doesn't
allow to read the real address of sender. Something like SenderAddress
is not available.
Exists a few methods to retrieve this information:
1. help file says that sender is in Recipients collection with Type
property - 0 (olOriginator).
But this way is not work for any version of MS Outlook. So just
iterate thru collection of Recipients and find an item with Type=0
couldn't return required value
2. as alternative you can read a ReplyTo property - there you'll receive
an address (but generally ReplyTo and Sender could be different).
For example, in messages which I send from own mail account these values
are different.
3. to create a new MailItem (just will be destroyed without saving in
end of work), define a Recipient as value which you received from
SenderName of your original message and call a Resolve method - after
that you'll recieve a correct email address of this sender.
4. more correct and fast solution is the next:
begin
objCDO := CreateOLEObject('MAPI.Session');
objCDO.Logon('', '', False, False);
objMsg := objCDO.GetMessage(itemOL.EntryID, itemOL.Parent.StoreID);
s := objMsg.Sender.Address;
showmessage(s);
objMsg := UnAssigned;
objCDO := UnAssigned;
end
where itemOL is a MailItem which contain a SenderName but doesn't
contain a SenderAddress:-)
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:41:33 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in development if you use OLE automation of some object,
your application will not work because application is not installed on
client computer. For example, you use MS excel automation but MS Excel
is not installed.
You can easy check if OLE object is installed and correctly registered
using CLSIDFromProgID function (for MS Excel as example only):
var
ClassID: TCLSID;
strOLEObject: string;
begin
strOLEObject := 'Excel.Application';
if (CLSIDFromProgID(PWideChar(WideString(strOLEObject)), ClassID) =
S_OK)
then
begin
<application is installed>
end
else
begin
<application is NOT installed>
end
end;
In same manner you can check any other required OLE object.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:41:47 星期天 说道:
------------------------------------------------------------------------
--------
Anyone who worked with OLE automation, know that OLE is very slowly.
Especially if you work using late binding (which have a lot of other
advantages which early binding haven't)
A reason of bad performance is the next: every command (method or
property) which you access (no matter in read or write mode) will be
interpretated (a-la script). I mean that this command must be found in
table of available methods/properties by string name and only if found,
a physical memory address for execution will be calculated.
So if your code contain a lot of access to methods/properties, your code
will be slow.
For example, you need transfer some data from Delphi application into
xls-spreadsheet.
You can solve a task in two different ways (now I describe only late
binding for OLE automation and don't describe another methods):
to navigate thru own data and export every data in required cell
to prepare a variant array with copied data and apply this array with
data into desired range of cells
I must say that second method will be faster than first because you'll
call less commands from OLE object and main code will be executed
without OLE automation.
Small sample: to export some StringGrid into xls-file.
var
xls, wb, Range: OLEVariant;
arrData: Variant;
begin
{create variant array where we'll copy our data}
arrData := VarArrayCreate([1, yourStringGrid.RowCount, 1,
yourStringGrid.ColCount], varVariant);
{fill array}
for i := 1 to yourStringGrid.RowCount do
for j := 1 to yourStringGrid.ColCount do
arrData[i, j] := yourStringGrid.Cells[j-1, i-1];
{initialize an instance of Excel}
xls := CreateOLEObject('Excel.Application');
{create workbook}
wb := xls.Workbooks.Add;
{retrieve a range where data must be placed}
Range := wb.WorkSheets[1].Range[wb.WorkSheets[1].Cells[1, 1],
wb.WorkSheets[1].
Cells[yourStringGrid.RowCount, yourStringGrid.ColCount]];
{copy data from allocated variant array}
Range.Value := arrData;
{show Excel with our data}
xls.Visible := True;
end;
Of course, you must understand that such method is not good for large
data arrays because to allocate in memory large array is not easy task.
You must find some optimal size for data transfer (for example, to copy
every 10 rows) and as result you'll receive an optimal code both for
memory use and performance.
Anyway more faster way to transfer data is not use OLE at all:-) You can
use my TSMExportToXLS component from SMExport suite for this task.
There is implemented a direct xls-file creation which doesn't require
installed MS Excel at all..
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:42:06 星期天 说道:
------------------------------------------------------------------------
--------
As you know I like MS Outlook because there a lot of possibilities and
OLE automation of Outlook allow to solve possible any task.
Today I want continue a serie of tips for MS Outlook.
So how to read a collection of Contacts which are exist in MS Outlook?
This task is very popular. For example, you want to develop a sample
tool which will notify you about birthday for someone or you want to
send messages to "mailing list". So you want to naviagte thru list of
defined contacts and process any item.
Below you'll find a sample code:
const
olFolderContacts = $0000000A;
var
outlook, NameSpace, Contacts, Contact: OleVariant;
i: Integer;
begin
outlook := CreateOleObject('Outlook.Application');
NameSpace := outlook.GetNameSpace('MAPI');
Contacts := NameSpace.GetDefaultFolder(olFolderContacts);
for i := 1 to Contacts.Items.Count do
begin
Contact := Contacts.Items.Item(i);
{now you can read any property of contact. For example, full name
and
email address}
ShowMessage(Contact.FullName + ' <' + Contact.Email1Address + '>');
end;
Outlook := UnAssigned;
end;
if you need a birthday, you can retrieve it as DateToStr(Contact.
Birthday)
Any contact item have a lot of properties. See a list (alphabet):
Birthday
Business2TelephoneNumber
BusinessAddress
BusinessAddressCity
BusinessAddressCountry
BusinessAddressPostalCode
BusinessAddressPostOfficeBox
BusinessAddressState
BusinessAddressStreet
BusinessFaxNumber
BusinessHomePage
BusinessTelephoneNumber
CompanyAndFullName
CompanyMainTelephoneNumber
CompanyName
ComputerNetworkName
Department
Email1Address
Email1AddressType
Email1DisplayName
Email2Address
Email2AddressType
Email2DisplayName
Email3Address
Email3AddressType
Email3DisplayName
FirstName
FTPSite
FullName
FullNameAndCompany
GovernmentIDNumber
Hobby
Home2TelephoneNumber
HomeAddress
HomeAddressCity
HomeAddressCountry
HomeAddressPostalCode
HomeAddressPostOfficeBox
HomeAddressState
HomeAddressStree
HomeFaxNumber
HomeTelephoneNumber
Initials
ISDNNumber
JobTitle
Language
LastName
LastNameAndFirstName
MailingAddress
MailingAddressCity
MailingAddressCountry
MailingAddressPostalCode
MailingAddressPostOfficeBox
MailingAddressState
MailingAddressStreet
MiddleName
NickName
OfficeLocation
OrganizationalIDNumber
PersonalHomePage
PrimaryTelephoneNumber
Profession
Suffix
Title
WebPage
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:42:52 星期天 说道:
Windows API
#0001 How can I create a screenshot?
#0004 How can I receive a list of processes running on a system?
#0006 Delete a file into Recycle Bin
#0007 To detect a Windows version
#0009 To switch a keyboard layout
#0011 To add a some forms in Windows Task Manager
#0014 To get a system icons
#0016 Turn monitor power on/off
#0024 Turn the screensaver on/off
#0027 The current computer and user names
#0052 To get a sizes of some system controls
#0053 To set the clock (system datetime) in Windows
#0070 To read the environment string
#0082 To read the current code page of system
#0084 To load the icons from external dll/exe
#0086 To register the file extention and context menu
#0098 To retrieve a full path of module in DLL
#0105 To refresh a desktop
#0106 To read a path of system folder
#0112 To press a mouse button from code
#0131 To use extended Windows dialogs
#0133 To read native text of current locale
#0138 To change a color of standard TProgressbar
#0140 To define a custom icon for some folder
#0147 To show/hide clocks in tray
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:43:16 星期天 说道:
------------------------------------------------------------------------
--------
In the next code I show how you can save in the file the current desktop
image:
procedure TForm1.Button1Click(Sender: TObject);
var DCDesk: HDC; // hDC of Desktop
bmp: TBitmap;
begin
{Create a bitmap}
bmp := TBitmap.Create;
{Set a bitmap sizes}
bmp.Height := Screen.Height;
bmp.Width := Screen.Width;
{Get a desktop DC handle - handle of a display device context}
DCDesk := GetWindowDC(GetDesktopWindow);
{Copy to any canvas, here canvas of an image}
BitBlt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
DCDesk, 0, 0, SRCCOPY);
{Save the bitmap}
bmp.SaveToFile('ScreenShot.bmp');
{Release desktop DC handle}
ReleaseDC(GetDesktopWindow, DCDesk);
{Release a bitmap}
bmp.Free;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:43:26 星期天 说道:
------------------------------------------------------------------------
--------
Using next procedure you can display the text with any angle.
Today I answered on question with same subject by e-mail to Marcus
Monaghan and I sure, that this example will useful for someone else.
procedure TForm1.Button1Click(Sender: TObject);
var handler: THandle;
data: TProcessEntry32;
function GetName: string;
var i:byte;
begin
Result := '';
i := 0;
while data.szExeFile[i] <> '' do
begin
Result := Result + data.szExeFile[i];
Inc(i);
end;
end;
begin
handler := CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0);
if Process32First(handler, data) then
begin
listbox1.Items.Add(GetName());
while Process32Next(handler, data) do
listbox1.Items.Add(GetName());
end
else
ShowMessage('Error');
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:43:36 星期天 说道:
------------------------------------------------------------------------
--------
uses ShellApi;
var FileOpStruc: TSHFileOpStruct;
s: PChar;
begin
s := 'C:\your_full_path\your_file_name.txt';
with FileOpStruc do
begin
Wnd := 0;
wFunc := FO_DELETE;
pFrom := s;
fFlags := FOF_ALLOWUNDO
end;
SHFileOperation(FileOpStruc);
end;
You can delete a files by some mask too.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:43:44 星期天 说道:
------------------------------------------------------------------------
--------
var
OSVersionInfo : TOSVersionInfo;
begin
OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
if GetVersionEx(OSVersionInfo) then
with OSVersionInfo do
begin
WinVerLabel.Caption := Format('%s%s%s%s%s%s%s%s',
['Windows: ', IntToStr(dwMajorVersion), '.',
IntToStr(dwMinorVersion), ' (Build ',
IntToStr(dwBuildNumber), szCSDVersion, ')']);
case dwPlatformId of
0: WinPlatformLabel.Caption := 'Platform: Win32s on Windows 3.
1';
1: WinPlatformLabel.Caption := 'Platform: Win32 on Windows 95';
2: WinPlatformLabel.Caption := 'Platform: Windows NT';
end;
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:43:56 星期天 说道:
------------------------------------------------------------------------
--------
If you want to change a current keyboard layout, you can:
1. var lang: HKL;
lang := LoadKeyboardLayout(pcKeyboard, 0);
SetActiveKeyboardLayout(lang);
2. LoadKeyboardLayout(pcKeyboard, KLF_ACTIVATE);
where pcKeyboard is:
'00000409' - english
'00000419' - russian
'00000422' - ukrainian
'00000407' - german
'0000040C' - french
'00000410' - italian
'00000416' - portuguese
'0000040A' - spanish
... (for more information view a language consts in windows.pas)
------------------------------------------------------------------------
--------
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:44:04 星期天 说道:
------------------------------------------------------------------------
--------
By default, when you create the application in Delphi/C++Builder, in
Windows Task Manager will be included a main form handle only. If you
want to add the additional form, you must override the CreateParams
procedure:
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle or WS_Ex_AppWindow;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:44:47 星期天 说道:
------------------------------------------------------------------------
--------
If you want to fill in TImageList the system icon list, then you can
write the next:
var FileInfo: TSHFileInfo;
begin
{to get a small icons}
imgListSysSmall := TImageList.Create(nil);
with imgListSysSmall do
begin
Handle := SHGetFileInfo('', 0, FileInfo, SizeOf(TSHFileInfo),
SHGFI_SMALLICON or SHGFI_SYSICONINDEX );
ShareImages := True;
end;
{to get a small icons}
imgListSysLarge := TImageList.Create(nil);
with imgListSysLarge do
begin
Handle := SHGetFileInfo('', 0, FileInfo, SizeOf(TSHFileInfo),
SHGFI_LARGEICON or SHGFI_SYSICONINDEX );
ShareImages := True;
end;
end;
Also if you want to get a "My Computer" icon, you must use the next
function:
var FileInfo: TSHFileInfo;
PIDL: PItemIDList;
begin
SHGetSpecialFolderLocation(Application.Handle, CSIDL_DRIVES, PIDL);
if SHGetFileInfo(PChar(PIDL), 0, FileInfo, SizeOf(TSHFileInfo),
SHGFI_PIDL or SHGFI_SYSICONINDEX ) <> 0 then
Result := FileInfo.iIcon;
end;
In this function you can use the constants from shlobj.pas:
CSIDL_DESKTOP = $0000;
CSIDL_PROGRAMS = $0002;
CSIDL_CONTROLS = $0003;
CSIDL_PRINTERS = $0004;
CSIDL_PERSONAL = $0005;
CSIDL_FAVORITES = $0006;
CSIDL_STARTUP = $0007;
CSIDL_RECENT = $0008;
CSIDL_SENDTO = $0009;
CSIDL_BITBUCKET = $000a;
CSIDL_STARTMENU = $000b;
CSIDL_DESKTOPDIRECTORY = $0010;
CSIDL_DRIVES = $0011;
CSIDL_NETWORK = $0012;
CSIDL_NETHOOD = $0013;
CSIDL_FONTS = $0014;
CSIDL_TEMPLATES = $0015;
CSIDL_COMMON_STARTMENU = $0016;
CSIDL_COMMON_PROGRAMS = $0017;
CSIDL_COMMON_STARTUP = $0018;
CSIDL_COMMON_DESKTOPDIRECTORY = $0019;
CSIDL_APPDATA = $001A;
CSIDL_PRINTHOOD = $001B;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:44:58 星期天 说道:
------------------------------------------------------------------------
--------
If you want, you can turn off or turn on the monitor power. Try it:
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);
or
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 1);
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:45:05 星期天 说道:
------------------------------------------------------------------------
--------
The following example shows how to turn the screensaver off.
1. turn off:
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, nil, 0);
2. turn on:
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, nil, 0);
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:45:15 星期天 说道:
------------------------------------------------------------------------
--------
To get a computer and user name you can so:
var ComputerName: array[1..20] of Char;
UserName: array[1..512] of Char;
arrSize: DWord;
begin
arrSize := SizeOf(ComputerName);
GetComputerName(@ComputerName, arrSize);
arrSize := SizeOf(UserName);
GetUserName(@UserName, arrSize);
ShowMessage('Computer name is: ' + ComputerName + #13#10 +
'User name is: ' + UserName)
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:45:46 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in run-time you must detect the sizes of some system controls.
For example, width of scrollbar or height of form caption etc.
If you want to get this system value, you must call the Windows API's
function GetSystemMetrics with different parameter. In result you'll get
the wished. For example,
intFormCaptionHeight := GetSystemMetrics(SM_CYCAPTION)
As result, you in intFormCaptionHeight you have a height of normal
caption area in pixels.
The full list of wished system metrics you can view in Windows API's
help by GetSystemMetrics topic.
The some useful metrics:
SM_CMOUSEBUTTONS - number of buttons on mouse
SM_CXFULLSCREEN, SM_CYFULLSCREEN - width/height of the client area for
full-screen window
SM_CXHSCROLL, SM_CYHSCROLL - width/height of the arrow bitmap on
horizontal scrollbar
SM_CXSCREEN, SM_CYSCREEN - width/height of the screen
SM_CXSIZE, SM_CYSIZE - width/height of a button in window caption
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:45:56 星期天 说道:
------------------------------------------------------------------------
--------
If you need set the system date and time in MS Windows from your
application, then you can use the next code:
function ChangeSystemDateTime(dtNeeded: TDateTime): Boolean;
var
tzi: TTimeZoneInformation;
dtSystem: TSystemTime;
begin
GetTimeZoneInformation(tzi);
dtNeeded := dtNeeded + tzi.Bias / 1440;
with dtSystem do
begin
wYear := StrToInt(FormatDateTime('yyyy', dtNeeded));
wMonth := StrToInt(FormatDateTime('mm', dtNeeded));
wDay := StrToInt(FormatDateTime('dd', dtNeeded));
wHour := StrToInt(FormatDateTime('hh', dtNeeded));
wMinute := StrToInt(FormatDateTime('nn', dtNeeded));
wSecond := StrToInt(FormatDateTime('ss', dtNeeded));
wMilliseconds := 0;
end;
Result := SetSystemTime(dtSystem);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:46:34 星期天 说道:
------------------------------------------------------------------------
--------
If you need read the environemnt strings, you must call the 2 API
functions:
GetEnvironemtnStrings and FreeEnvironmentStrings:
var
Env1, Env2: PChar;
lstStrings: TStrings;
begin
lstStrings := TStringList.Create;
Env1 := GetEnvironmentStrings;
Env2 := PEnv1;
if Env2 <> nil then
repeat
lstStrings.Add(StrPas(Env2));
inc(Env2, StrLen(Env2) + 1);
until Env2^ = #0;
FreeEnvironmentStrings(Env1);
Env2 := nil;
<...>
lstStrings.Free
end;
The GetEnvironmentStrings function returns the address of the
environment block for the current process. Each environment variable
is null terminated. The set of strings is double null terminated.
As alternative method, you can read a specified variable. The
GetEnvironmentVariable function retrieves the value of the specified
variable from the environment block of the calling process. The value is
in the form of a null-terminated string of characters.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:46:51 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in run-time you must detect the current values of code page.
To detect the code page of Windows operation system you must call the
GetACP function from Windows API.
This function will return the value:
874 Thai
932 Japan
936 Chinese (PRC, Singapore)
949 Korean
950 Chinese (Taiwan, Hong Kong)
1200 Unicode (BMP of ISO 10646)
1250 Windows 3.1 Eastern European
1251 Windows 3.1 Cyrillic
1252 Windows 3.1 Latin 1 (US, Western Europe)
1253 Windows 3.1 Greek
1254 Windows 3.1 Turkish
1255 Hebrew
1256 Arabic
1257 Baltic
If you needs to read the code page of "DOS" sessions, you must call
the GetOEMCP function from Windows API. This function will return the
value:
437 MS-DOS United States
708 Arabic (ASMO 708)
709 Arabic (ASMO 449+, BCON V4)
710 Arabic (Transparent Arabic)
720 Arabic (Transparent ASMO)
737 Greek (formerly 437G)
775 Baltic
850 MS-DOS Multilingual (Latin I)
852 MS-DOS Slavic (Latin II)
855 IBM Cyrillic (primarily Russian)
857 IBM Turkish
860 MS-DOS Portuguese
861 MS-DOS Icelandic
862 Hebrew
863 MS-DOS Canadian-French
864 Arabic
865 MS-DOS Nordic
866 MS-DOS Russian (former USSR)
869 IBM Modern Greek
874 Thai
932 Japan
936 Chinese (PRC, Singapore)
949 Korean
950 Chinese (Taiwan, Hong Kong)
1361 Korean (Johab)
Also you can check the valids of code page. For example,
if IsValidCodePage(866) then
ShowMessage('Correct MS-DOS russian code page')
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:47:05 星期天 说道:
------------------------------------------------------------------------
--------
Exists a few ways to store the some icons in external files and load
them in run-time. For example, the next code shows how you can load
the icons from dll/exe file:
procedure TyourForm.btnFillIconsClick(Sender: TObject);
var
i: Integer;
pcDLLName: PChar;
begin
pcDLLName := 'MORICONS.DLL';
for i := 0 to ExtractIcon(Handle, pcDLLName, Cardinal(-1)) - 1 do
ImageList_AddIcon(yourImageList.Handle, ExtractIcon(Handle,
pcDLLName, i));
end;
This method is useful when you want to load the some system icons or
from own dynamic library in which you placed the collection of icons.
If you needs to load the icons in run-time but you don't want to use the
external file, you can place the glyph collection into resource file
and link it in own exe-file. How to do it I'll show in the next tip.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:47:29 星期天 说道:
------------------------------------------------------------------------
--------
In the next example will be registered the file extention (.newext) -
files of this type will open using MyApp.Exe application. Also will be
registered the one default action and two additional items in context
menu, assigned
with this file extention.
Example:
uses
Registry;
procedure TForm1.Button1Click(Sender: TObject);
begin
with TRegIniFile.Create('') do
try
RootKey := HKEY_CLASSES_ROOT;
WriteString('.newext', '', 'NewExt');
WriteString('NewExt', '', 'Your description of NewExt files');
WriteString('NewExt\DefaultIcon', '', 'C:\MyApp.Exe,0');
WriteString('NewExt\Shell', '', 'This_Is_Our_Default_Action');
WriteString('NewExt\Shell\First_Action', '','This is our first
action');
WriteString('NewExt\Shell\First_Action\command', '', 'C:\MyApp.Exe
/LotsOfParamaters %1');
WriteString('NewExt\Shell\This_Is_Our_Default_Action', '', 'This
is our default action');
WriteString('NewExt\Shell\This_Is_Our_Default_Action\command', '',
'C:\MyApp.Exe %1');
WriteString('NewExt\Shell\Second_Action', '', 'This is our
second action');
WriteString('NewExt\Shell\Second_Action\command', '', 'C:\MyApp.
Exe /TonsOfParameters %1');
finally
Free;
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:48:00 星期天 说道:
------------------------------------------------------------------------
--------
If you develops the dll, in some tasks you must know the full path of
this\par dll but not the path of application from which was ran this
library.
For this task you must use the GetModuleFileName function. View a
sample:
var
DLLFileName: PChar;
begin
GetMem(DLLFileName, MAX_PATH+1);
if (DLLFileName <> nil) then
GetModuleFileName(hInstance, DLLFileName, MAX_PATH);
...
end;
So in pDLLFileName variable you'll have the full path value.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:48:09 星期天 说道:
------------------------------------------------------------------------
--------
Yesterday I answered on this question in delphi programming mailing
list. I want to post this answer as tip because I sure that this
question can ask a lot of developers but to find an answer is not easy
task.
So if you need refresh a desktop in run-time, you can execute a next
procedure:
SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, NULL, NULL);
This code will refresh a desktop image and re-read the icons for files
with registered extentions.
PS: you can do a same if you press a right mouse button on desktop and
select Update item.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:48:22 星期天 说道:
------------------------------------------------------------------------
--------
Just now in delphi-programming I posted a code which allows to recieve a
path to some system folder (StartUp, Recent Files etc). As you know,
the path can be different on other computers (depends from operationg
system, localization, user profile and user settings).
This code allows to read a current value:
uses ShlObj, ActiveX;
function GetSystemPath(Folder: Integer): string;
var
PIDL: PItemIDList;
Path: LPSTR;
AMalloc: IMalloc;
begin
Path := StrAlloc(MAX_PATH);
SHGetSpecialFolderLocation(Application.Handle, Folder, PIDL);
if SHGetPathFromIDList(PIDL, Path) then
Result := Path;
SHGetMalloc(AMalloc);
AMalloc.Free(PIDL);
StrDispose(Path);
end;
Now you can call this function with different parameters. For example:
CSIDL_DESKTOP for WINDOWS\Desktop
CSIDL_DESKTOPDIRECTORY for WINDOWS\Desktop
CSIDL_FONTS for WINDOWS\FONTS
CSIDL_NETHOOD for WINDOWS\NetHood
CSIDL_PERSONAL for X:\My Documents
CSIDL_PROGRAMS for WINDOWS\StartMenu\Programs
CSIDL_RECENT for WINDOWS\Recent
CSIDL_SENDTO for WINDOWS\SendTo
CSIDL_STARTMENU for WINDOWS\Start Menu
CSIDL_STARTUP for WINDOWS\Start Menu\Programs\StartUp
CSIDL_TEMPLATES for WINDOWS\ShellNew
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:48:44 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes you need press a left and/or right mouse button from code
without any user activity. For example, as part of demo program which
demonstrates the possibilities of your application. You can use the next
procedures which simulates a mouse activity:
procedure PressMouseDown(IsLeftButton: Boolean);
begin
if IsLeftButton then
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
else
mouse_event(MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0);
end;
procedure PressMouseUp(IsLeftButton: Boolean);
begin
if IsLeftButton then
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
else
mouse_event(MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0);
end;
procedure ClickMouseButton(IsLeftButton: Boolean);
begin
PressMouseDown(IsLeftButton);
PressMouseUp(IsLeftButton);
end;
So if you need "click" on mouse button, call the ClickMouseButton
procedure.
But if you need "press" on button, do a something and release a button,
then call a PressMouseDown, execute the some own code and call the
PressMouseUp.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:49:09 星期天 说道:
------------------------------------------------------------------------
--------
Today I want to show a few samples how you can use the extended
dialogs from MS Windows (Find Files, Find Computer, Select Icon etc)
in own code.
Usually the MessageDlg is most used from standard dialogs but inside
of Windows you'll find a lot of other useful dialogs too.
The any such dialog is declared in the Shell32.dll library and you can
use it so:
1. Select an icon
this dialog is a same which you'll see when you'll edit an icon of any
lnk-file (icon on desktop, for example)
Declaration:
function PickIconDlgA(OwnerWnd: HWND; lpstrFile: PAnsiChar; var
nMaxFile: LongInt; var lpdwIconIndex: LongInt): LongBool; stdcall;
external 'SHELL32.DLL' index 62;
Example (icon of current application will be changed!):
procedure TForm1.Button4Click(Sender: TObject);
var
FileName: array[0..MAX_PATH - 1] of Char;
Size, Index: LongInt;
begin
Size := MAX_PATH;
FileName := 'c:\windows\system\shell32.dll';
if PickIconDlgA(0, FileName, Size, Index) then
begin
if (Index <> -1) then
Application.Icon.Handle := ExtractIcon(hInstance, FileName,
Index);
end;
end;
Of course, you can define any other file and in the dialog you'll see
available icons of this executable file.
2. Find Computer
Declaration:
function SHFindComputer(pidlRoot: PItemIDList; pidlSavedSearch:
PItemIDList): Boolean; stdcall; external 'Shell32.dll' index 91;
Example:
begin
SHFindComputer(nil, nil);
end;
3. Find Files
Declaration:
function SHFindFiles(pidlRoot: PItemIDList; pidlSavedSearch:
PItemIDList): Boolean; stdcall; external 'Shell32.dll' index 90;
Example:
begin
SHFindFiles(nil,nil);
end;
Here the first parameter is a folder where you want to begin a search
(nil is a Desktop). The second parameter allow to define a previous
saved state of search process.
IMPORTANT:
Note that SHFindFiles and SHFindComputer are not modal dialogs (these
dialogs will be started in separated thread) so the result of function
will be True if dialog is created succesfully.
4. Shutdown dialog
Declaration:
procedure ExitWindowsDialog(ParentWnd: HWND); stdcall; external
'Shell32.dll' index 60;
Example:
begin
ExitWindowsDialog(0)
end;
5. RestartDialog
this dialog allow to ask end-user about Windows restarting and is used
when changes are made to system that require a shutdown/restart before
they will take effect.
Declaration:
function RestartDialog(ParentWnd: HWND; Reason: PAnsiChar; Flags:
LongInt): LongInt; stdcall; external 'Shell32.dll' index 59;
Example:
begin
if RestartDialog(0, 'I want to call a RestartDialog ',
EW_RESTARTWINDOWS)
= IDYES then
ShowMessage('succesfully started')
end;
You can define any reason of restarting (second parameter - additionally
to default text or nil for default only) and use the another flag
(one from the next available):
EWX_LOGOFF
EWX_SHUTDOWN
EWX_REBOOT
EW_RESTARTWINDOWS
EW_REBOOTSYSTEM
EW_EXITANDEXECAPP
This dialog is very useful for application which have embedded install
procedure.
6. OutOfSpace
Will display a notification dialog about "Out Of Space" for some defined
drive.
Declaration:
procedure SHHandleDiskFull(Owner: HWND; Drive: UINT); stdcall;
external 'Shell32.dll' index 185;
Example:
begin
SHHandleDiskFull(0, 2);
end;
Note that second parameter is Drive number where 0 is A:, 1 is B:, 2
is C: etc
Of course, in the Shell32.dll you'll find other dialogs too (Object
Properties, Map Network Drive, Browse For Folder etc) and you can use
these dialogs without any problems.
IMPORTANT:
Don't forget to add ShlObj and ShellAPI units into uses-clause.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:49:20 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in application we want to show a text with description of
current used locale.
For example, "english", "russian", "ukrainian", "chinese" etc
For this task you can use VerLanguageName function from Windows API:
var
ID: LangID;
LanguageName: array[0..255] of Char;
begin
{read current system locale}
ID := GetSystemDefaultLangID;
{convert an ID into text}
VerLanguageName(ID, LanguageName, SizeOf(LanguageName));
ShowMessage(LanguageName);
end;
Of course, you can expand this code and to translate a locale as
parameter
For example, if ID is $419, you'll receive a "russian". For $$0A - the
"Spanish (Traditional Sort)", for $0C0C - the "French (Canadian)", for
$407 - "German (Standard)" etc
Especially it is usefully when you'll retrieve an information from
file (see GetFileVersionInfo/VerQueryValue functions or my freeware
TSMVersionInfo component) or in some install tools.
Important
if ID is incorrect, you'll receive an "Language Neutral" as result
text in result will be translated in the current language. I mean that
text will be not in English if you have localized version of MS
Windows
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:49:30 星期天 说道:
------------------------------------------------------------------------
--------
Standard TProgressbar component from Win32 palette doesn't allow to
change a color of progress using properties but control from MS
Windows allow to do it (TProgressbar is not pure VCL component - this is
a wrapper for Windows control, the same as TEdit, TStaticText,
TButton etc)
This feature can be easy added in run-time - just call the next
procedure and define parameters - your Progressbar and desired color:
procedure ChangeProgressColor(pb: TProgressbar; cl: TColor);
const
PBM_SETBARCOLOR = WM_USER+9;
begin
inherited;
SendMessage(pb.Handle, PBM_SETBARCOLOR, 0, cl);
end;
For example:
ChangeProgressColor(pbStatus, clRed);
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:49:40 星期天 说道:
------------------------------------------------------------------------
--------
In MS Windows you can define any custom icon for desired folder
instead default icon (yellow folder picture). Also you can define own
string description which will be displayed in Explorer application.
To do it is very easy task:
1. you must create a desktop.ini file with special structure:
[.ShellClassInfo]
IconFile=yourFileWithIcon.ico
IconIndex=0
InfoTip=your description text
2. you must set a System flag to attributes of your folder
A first part is solved in Delphi in a few lines of code:
with TINIFile.Create(yourFolderName + '\desktop.ini') do
try
WriteString('.ShellClassInfo', 'IconFile', 'yourFileWithIco.ico');
WriteString('.ShellClassInfo', 'IconIndex', '0'); //icon index
WriteString('.ShellClassInfo', 'InfoTip', 'your description text');
{flush a buffered INI-file to disk}
UpdateFile;
finally
Free
end;
A second (to set a system attribute) is not hard too:
SetFileAttributes(PChar(yourFolderName), FILE_ATTRIBUTE_SYSTEM);
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:49:49 星期天 说道:
------------------------------------------------------------------------
--------
Today I want to publish a method for show/hide of clocks in traybar of
MS Windows. This code will work with any version of Windows.
To hide clocks:
ShowWindow(FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0, 'TrayNotifyWnd', nil), 0, 'TrayClockWClass', nil), SW_HIDE);
To show clocks:
ShowWindow(FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0, 'TrayNotifyWnd', nil), 0, 'TrayClockWClass', nil), SW_SHOW);
Don't know why you need it but just for fun:-)
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:50:22 星期天 说道:
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:51:04 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in run-time you need play with colors. For example, you have
the some color value and you want to make it more dark or light. The
next two function were written for it.
function Dark(Col: TColor; Percent: Byte): TColor;
var R, G, B: Byte;
begin
R := GetRValue(Col);
G := GetGValue(Col);
B := GetBValue(Col);
R := Round(R*Percent/100);
G := Round(G*Percent/100);
B := Round(B*Percent/100);
Result := RGB(R, G, B);
end;
function Light(Col: TColor; Percent: Byte): TColor;
var R, G, B: Byte;
begin
R := GetRValue(Col);
G := GetGValue(Col);
B := GetBValue(Col);
R := Round(R*Percent/100) + Round(255 - Percent/100*255);
G := Round(G*Percent/100) + Round(255 - Percent/100*255);
B := Round(B*Percent/100) + Round(255 - Percent/100*255);
Result := RGB(R, G, B);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:51:26 星期天 说道:
------------------------------------------------------------------------
--------
If you want to draw a something in the title bar of the form, you must
handle the WM_NCPAINT message. For example in the next code I show how
you can output the form caption with italic font style:
type
TForm1 = class(TForm)
private
procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
end;
var Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var ACanvas: TCanvas;
intLeftShift, intTopShift: Integer;
begin
inherited;
ACanvas := TCanvas.Create;
try
{to retrieve the device context for the Form1 window}
ACanvas.Handle := GetWindowDC(Form1.Handle);
with ACanvas do
begin
Brush.Color := clActiveCaption;
Font.Style := [fsItalic];
{calculate the left coordinate for caption drawing}
intLeftShift := GetSystemMetrics(SM_CYMENU) +
GetSystemMetrics(SM_CXBORDER);
{calculate the top coordinate for caption drawing}
intTopShift := (GetSystemMetrics(SM_CYCAPTION) - Abs(Font.Height))
div 2 + 1;
{output the caption string}
TextOut(intLeftShift, intTopShift, Caption)
end;
finally
{to release the device context}
ReleaseDC(Form1.Handle, ACanvas.Handle);
ACanvas.Free
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:51:36 星期天 说道:
------------------------------------------------------------------------
--------
If you need retrieve the value of the vertical refresh rate of the
your monitor, you can call the GetDeviceCaps API's function with
VREFRESH parameter.
This feature are available on Windows NT platform only, so before
using you must check the Windows version. For example,
var ov: TOSVersionInfo;
vr: Integer;
begin
ov.dwOSVersionInfoSize := SizeOf(ov);
GetVersionEx(ov);
if OV.dwPlatformID = VER_PLATFORM_WIN32_NT then
begin
vr := GetDeviceCaps(Form1.Canvas.Handle, VREFRESH);
Label.Caption := 'Frequence: ' + IntToStr(vr) + ' Hz';
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:51:47 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes you need draw the chart on the own canvas. For example, you
want to print a chart or include the chart in own bitmap. You can make
it so:
1. yourChart.DrawToMetaCanvas(ACanvas, ARect);
or
2.
var intChartWidth, intChartHeight: Integer;
Meta: TMetaFile;
begin
Meta := yourChart.TeeCreateMetafile(False, Rect(0, 0, intChartWidth,
intChartHeight));
try
ACanvas.StretchDraw(ARect, Meta);
finally
Meta.Free;
end;
end;
, where
- yourChart is a "source" chart component
- ARect is a rect in which you want to place a chart image,
- ACanvas is a "target" canvas
In the SMReport Designer I used the first procedure for chart
outputing on the report band.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:52:01 星期天 说道:
------------------------------------------------------------------------
--------
In some applications you must draw the line where each pixel is some
shape. The MS Windows allows to draw line of such type - you must use
the LineDDA funtion. This function needs a callback function that is
called for each pixel drawing. Of course, in this callback function
you can realize the any drawing routines.
For example, the next code allows to draw the ellipse every 10 pixels:
var
i: Integer;
procedure DrawEllipse(X, Y: Integer; lpData: LParam); stdcall;
implementation
procedure DrawEllipse(X, Y: Integer; lpData: LParam);
begin
with TObject(lpData) as TForm do
begin
if (i mod 10 = 0) then
Canvas.Ellipse(x-5, y-5, x+5, y+5);
Inc(i);
end;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
i := 0;
LineDDA(0, 0, Width, Height, @DrawEllipse, Integer(yourForm));
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:52:09 星期天 说道:
------------------------------------------------------------------------
--------
Today I found a nice tip about changing the captions in standard dialogs
(TOpenDialog or TSaveDialog).
By default the TOpenDialog have the two buttons: Open and Cancel. You
can change this default value:
procedure TForm1.OpenDialog1Show(Sender: TObject);
begin
SetDlgItemText(GetParent(OpenDialog1.Handle), IDOK, PChar('New
&Open'));
SetDlgItemText(GetParent(OpenDialog1.Handle), IDCANCEL, PChar('New
&Cancel'));
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:52:17 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in development you must to detect the current position of
mouse. You can use the GetCursorPos function.
In the next example I shows how to popup the some TPopupMenu component
in point, where user click a mouse button:
var
P: TPoint;
begin
GetCursorPos(P);
yourPopupMenu.Popup(P.X, P.Y);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:52:34 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes in development you must use the some values (for example,
integer or strings) as data to each item in list (TStrings).
For example, you have the listbox with country name but you want to link
a code value for each item. Or other example: you have a combobox
with colors and you needs to link a color value to each colored line.
These tasks can be easy solved - the TStrings type have:
- the Items property: the string items which will be displayed in
combobox or listbox
- the Objects property: the data which can be linked to each visible
item.
Each Objects[i] is the pointer to some external data.
In this tip I want to explain how you can use this Objects property
for storing of some additional info.
1. to store the integer values:
with qryGroups do
begin
First;
while not Eof do
begin
cbGroups.Items.AddObject(FieldByName('Name').AsString,
TObject(FieldByName('ID').AsInteger));
Next;
end;
end;
to read the integer value from selected item:
strID := LongInt(cbGroups.Items.Objects[cbGroups.ItemIndex]);
Comments: in this example, I used the type convertion - each pointer
is address. But address is an integer value so we can place to item data
the "virtual" address.
2. to store the string values:
with qryGroups do
begin
First;
while not Eof do
begin
cbGroups.Items.AddObject(FieldByName('Name').AsString,
TObject(LongInt(NewStr(FieldByName('ID').
AsString))));
Next;
end;
end;
to read a value from selected item:
strID := PString(cbGroups.Items.Objects[cbGroups.ItemIndex])^;
Comments: in this example I used the address on string which I created
(see a help topic on NewStr).
Also don't forget that you must destroy the objects data which you
created in this example. For exampe, you can do it in OnDestroy event:
for i := 0 to cbGroups.Items.Count-1 do
DisposeStr(PString(cbGroups.Items.Objects[i]));
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:53:02 星期天 说道:
------------------------------------------------------------------------
--------
If you needs to hide the own application from Windows Taskbar, you can
use the next procedure:
procedure TForm1.FormCreate(Sender: TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
SetWindowLong(Application.Handle, GWL_EXSTYLE,
GetWindowLong(Application.Handle, GWL_EXSTYLE) or
WS_EX_TOOLWINDOW);
ShowWindow(Application.Handle, SW_SHOW);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:53:10 星期天 说道:
------------------------------------------------------------------------
--------
If you needs to hide/show the Start button from Windows Taskbar, you can
use the next procedure:
procedure HideShowStartButton(boolVisible: Boolean);
var
Tray, Child: hWnd;
C: array[0..127] of Char;
S: string;
begin
Tray := FindWindow('Shell_TrayWnd', nil);
Child := GetWindow(Tray, GW_CHILD);
while Child <> 0 do
begin
if GetClassName(Child, C, SizeOf(C)) > 0 then
begin
S := StrPas(C);
if UpperCase(S) = 'BUTTON' then
begin
startbutton_handle := child;
ShowWindow(Child, Integer(boolVisible))
end;
end;
Child := GetWindow(Child, GW_HWNDNEXT);
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:53:27 星期天 说道:
------------------------------------------------------------------------
--------
Today I found a good example how we can add a some control in standard
MessageDialog.
For example, we have a some dialog for confirmation but user can check a
checkbox (Don't show this message again) and in the next time this
dialog will not show.
The idea of realization in the next:
1. we must create a dialog using CreateMessageDialog
2. this function will return a form object with dialog
3. in this object we can add a checkbox
4. show diallog using ShowModal
5. to check a result and process a state of our checkbox
6. to destroy a created checkbox and dialog object
View a source:
procedure TForm1.Button1Click(Sender: TObject);
var
AMsgDialog: TForm;
ACheckBox: TCheckBox;
begin
AMsgDialog := CreateMessageDialog('This is a test message.',
mtWarning,
[mbYes, mbNo]);
ACheckBox := TCheckBox.Create(AMsgDialog);
with AMsgDialog do
try
Caption := 'Dialog Title' ;
Height := 169;
with ACheckBox do
begin
Parent := AMsgDialog;
Caption := 'Don''t show me again.';
Top := 121;
Left := 8;
end;
if (ShowModal = ID_YES) then
begin
if ACheckBox.Checked then
begin
//...
end;
//... some additional processing
end;
finally
ACheckBox.Free;
Free;
end;
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:53:41 星期天 说道:
--------
If you uses the TTreeView and/or TListView from Win32 page of default
component palette, then you must know that if you have the large
amount nodes, you have a very bad performance...
Of course, at same moment you'll try to find a some other third-party
component that allow to work with your very large data but I want to
give you the few hints which allows to increase a performance without
any third-party components. Only using of optimized code.
Tip1:
if you need add a lot of nodes in same time (for example, after button
click to load the 10000 nodes in tree from some source) then you must
call:
yourTreeView.Items.BeginUpdate;
<your code for append of nodes>
yourTreeView.Items.EndUpdate;
This constuction will disable a repainting when you append the nodes -
it's save a lot of time!
Tip2:
if you uses the some navigation by nodes, you must use the GetFirst
and GetNext methods instead Items[i] using!
For example,
for i := 0 to yourTreeView.Items.Count-1 do
begin
node := yourTreeView.Items[i];
<process a node>
end;
For example, in own warehouse system I have a treeview with 5000 nodes
which I load from Oracle8i resultset. After applying of these tips,
the time of execution of procedure with append was decreased from 4-5
minutes to 15-20 seconds! Trust me:-)
I don't sure but I think that it's a bad work of Borland when team
developed the envelope for Win's treeview/listview. But maybe I'm
wrong.
PS: of course, if you have a very-very large data with few billions of
nodes or after applying of tips above all the same you have a bad
performance, you must use the virtual mode of control or really select
the other third-party control. But I suggest to change the your inteface
logic - to navigate thru few billions of nodes in same time is very
hard task for user! Not only for you:-)
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:53:54 星期天 说道:
------------------------------------------------------------------------
--------
Today I want to describe a method of dll-using. Of course, for some
advanced users this tip is not useful but I hope that somebody will find
it as interested.
In Delphi you have two mechanism of dll-loading: static and dynamic.
- the static method is when your application will be failed when dll
is not present. Inside of application you'll define a function as
external and in any code you'll use a function from dll as usual
"native" function.
- the dynamic method allow to have a control under dll-load. For
example, you can check an dll-existing and show a warning if dll is
not exist (or try to load another dll, for example). Also to call a some
function from such
> loaded dll, is more difficult in coding.
Small example.
Imagine that you have a dll with ExecScript procedure which have two
parameters (UserID and ScriptName).
In static method you must declare a function as:
procedure ExecScript(UserID: Integer; ScriptName: PChar); stdcall; far;
external 'yourDLLName.DLL';
and in the code you can call it as:
ExecScript(5, 'LogToSystem');
and it's all.
For dynamic mechanism you must:
{define a procedure type with required parameters of your procedure
in the DLL}
type
TDLLFunc = procedure(param1: Integer; param2: PChar);
{assign a nil - not loaded function}
const
DLLFunc: TDLLFunc = nil;
{handle of loaded dll}
var
DLLHandle: THandle;
{ load a library }
DLLHandle := LoadLibrary(DLLName);
if (DLLHandle < HINSTANCE_ERROR) then
raise Exception.Create(DLLName + ' library can not be loaded or not
found. ' + SysErrorMessage(GetLastError));
try
{ load an address of required procedure}
@DLLFunc := GetProcAddress(DLLHandle, 'ExecScript');
{if procedure is found in the dll}
if Assigned(DLLFunc) then
DLLFunc(5, 'LogToSystem');
finally
{unload a library}
FreeLibrary(DLLHandle);
end;
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:54:10 星期天 说道:
------------------------------------------------------------------------
--------
Sometimes from code you want to find out if MS Windows is operating in
saylight saving time. For example, I used this code in own GroupMail
because in message header you must include a timestamp.
The code below allow to solve this task:
uses Windows;
const
TIME_ZONE_ID_UNKNOWN = 0;
TIME_ZONE_ID_STANDARD = 1;
TIME_ZONE_ID_DAYLIGHT = 2;
var
tz : TTimeZoneInformation;
begin
case GetTimeZoneInformation(tz) of
TIME_ZONE_ID_STANDARD: ShowMessage(tz.StandardName);
TIME_ZONE_ID_DAYLIGHT: ShowMessage(tz.DaylightName);
else
ShowMessage('Unknown state');
end;
end;
Also I want to say that similar code you can use for BIAS reading
(offset to UTC/GMT in minutes of local time zone):
function GetTimeZoneBias: Integer;
var
tz: TTimeZoneInformation;
begin
case GetTimeZoneInformation(tz) of
TIME_ZONE_ID_STANDARD: Result := -(tz.StandardBias + tz.Bias) div
(24*60);
TIME_ZONE_ID_DAYLIGHT: Result := -(tz.DaylightBias + tz.Bias) div
(24*60);
else
Result := 0;
end;
end;
If the result is 0 then time is a GMT. Else you'll receive a
difference as positive or negative value.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日17:54:25 星期天 说道:
------------------------------------------------------------------------
--------
Every developer during programming solved such task: you have some
longtime data processing when user must see a progress but can do
nothing.
By default (without any additional steps) during data processing your
application will be frozen. The easiest way to solve it is to send
Application.ProcessMessages from own loop but in this case the user
could click some controls (by mouse or keyboard).
The method below will show how you can disable any mouse/keyboard
actions:
you may assign a handler to Application.OnMessage:
Application.OnMessage := yourOnMessageHandler
where
procedure TForm1.yourOnMessageHandler(var Msg: TMsg; var Handled:
Boolean);
begin
case Msg.Message of
WM_KEYFIRST..WM_KEYLAST, WM_MOUSEFIRST, WM_MOUSELAST:
Handled := True
end;
end;
Very important: you must remove a handler when your data processing is
completed (or in OnDestroy event of main form)
A basic scheme of data processing:
begin
Application.OnMessage := yourOnMessageHandler;
<your long calculation>
while <...> do
begin
<your calculations>
<update a progressbar/statistic>;
Application.ProcessMessages
end;
Application.OnMessage := nil;
end;
Of course, you can filter a mouse and/or keyboard by some own conditions
- just expand a body of yourOnMessageHandler procedure...
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日20:03:57 星期天 说道:
------------------------------------------------------------------------
--------
1. Never create a separated function for checking of registration.
Always place the checking code in some important procedure that is
required for your program. If cracker will disable this procedure, you
program will not work correctly.
2. Never give a meaningful name for procedure that contains a checking
(like IsValidSerialNumber, IsTrialExpired or IsValidUser). Change a F2CA
name and don't forget about rule#1.
3. If your code returned a message that is not valid serial number or
username, then don't try in same moment to show a warning dialog. Save
this information somewhere and show it later (better after few days).
4. Have a few different algorithms of validation. I mean that you can
generate an activation code using two-three-: algorithms. It allows
validating your code in few procedures. If cracker will find a
validation procedure then he'll find an one part of validation only. You
can check a different part of serial number in other days of month or
better to activate this validation after few days after first validation
receipt. In this case cracker will "find" a code and publish it but
your program will works a few days only. To trace all code of program or
spend a lot of time on your program is hard task for any cracker.
5. If you used a some encrypt method for generation of serial number
from username, then include a pause in few seconds after username
entry before processing. If cracker will use a brute force cracking,
this task will take a lot of additional time and in pair with good
encrypt method the task of cracking will be unreal.
6. Don't use short keys. Of course, it depends from crypt algorithm
but your key must be long. Better to generate a few Kb of key (don't
forget to send instruction about key entering) than use a
key-generator for 10 characters with standard literal symbols.
7. Don't store algorithm of key generation in your code. It is bad
technology when user will type the name and serial number and after that
you will run own algorithm for calculation of serial from user name
(for next compare). Better to compare some hash and magic structure.
Other the cracker will create the own key-generator without any patch of
your original exe-file.
8. Store the serial numbers or check sums in different places. Also
don't forget that these places must be hidden or with hard access. For
example, date/time of file creation, additional invisible line of pixels
in bitmap, first letters of records in database etc. Also don't
forget about unique algorithms for encryption of these secure codes -
don't use the one algorithm for any hidden places.
9. Don't use the trivial crypt algorithms. The XOR is not good choice.
Better to use MD5, RSA, BlowFish, GOST etc
10. If your trial software must be available in 30 days only, then don't
try to use a system date-time. Better to use a date-time of some system
files (SYSTEM.DAT or DA0, BOOTLOG.TXT, AUTOEXEC.BAT etc). Also don't
forget that additionally you can create the some own hidden file
during installation and use a date-time of this file.
11. Encrypt the all string resources that will show that program is
evaluation or time is expired. You must decrypt it in run-time and/or
build dynamically.
12. To lead cracker up the path garden: add the some dummy code with
strange external calls in validation procedure. It will increase time of
cracking because cracker must found a gold mine in the rubbish.
13. If you're expert in development, try to encrypt the some parts of
code in exe/dll-file and decrypt it in run-time. Use a different methods
of code checking - checksums, own labels...
14. As I wrote in rule#2 try to use a non-readable names of procedures
(D1FA12, B123 etc) or use a names like system functions - GetWindow,
MOUSE_EVENT_A, KeyboardLayoutW etc. Also you can use the names of some
procedures which are popular in your programming language (of course, if
this language support the one name for few different procedures in
different units/modules).
15. If your programming language supports it, then use the run-time
assigning of events. For example, in Borland Delphi/C++Builder you can
write a validation code in procedure which will be assigned to OnClick
event of some button. It's bad because name of this procedure will be
stored in resources and can be removed in any resource editor. Better to
assign a procedure to event in run-time.
16. If you can, don't disable the some extended features in trial
version. Better to remove it and after registration customer will
receive the other full program (protected, of course).
17. Frequently release a new versions or updates. Of course, don't
forget to change the validation method (at least one) in each release.
You must understand that any software can be cracked. And any software
will be cracked if your program is good and cost of cracking time is
less than your license fee.
If you found that your software cracked, don't panic. In any situation
you must find the good news for you. In this situation you must
understand that your software is best on market but cracker which
broke you protection are better then you now. It is like game - you
released a new protection, he must crack it. The next step is your:
you must change a protection and add a some hidden surprise for your
opponent - new crypt algorithm, new hidden places etc. It's a life.
Additionally
Also I want to say the next: the protection is very important part of
development process but don't spend a lot of time on it. If you'll
concentrate on protection but you'll forget about program possibilities,
your software will be not cracked forever. But reason is not a good
protectionJ Your software must worth a time that you spent on
protection.
The end-user need a good solution of own problem with good support and
new features and your protection must be in background. Exist a lot of
protections on hardware keys or new method of confirmation via
Internet but these methods will disturb your customers. In this case you
can lose them - they will select the other program without any choice
for your.
And don't forget about privacy of your customer - you can't select the
some personalized data without permissions. No matter that you need it
for own protection.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日21:47:03 星期天 说道:
This Delphi Tip checks to see if there is a disk in the disk drive,
first this function sets the errors off so that we don't receive an
error like: "Disk not ready.". Then the function checks the size of
the disk, if this is -1 then the function will result false, and the
disk is not ready.
Code:
function DiskInDrive(Drive: Char): Boolean;
var
ErrorMode: word;
begin
{ make it upper case }
if Drive in ['a'..'z'] then Dec(Drive, $20);
{ make sure it's a letter }
if not (Drive in ['A'..'Z']) then
raise EConvertError.Create('Not a valid drive ID');
{ turn off critical errors }
ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
try
{ drive 1 = a, 2 = b, 3 = c, etc. }
if DiskSize(Ord(Drive) - $40) = -1 then
Result := False
else
Result := True;
finally
{ restore old error mode }
SetErrorMode(ErrorMode);
end;
end;
This source code is written by Robert Jones.
────────────────────────────────────────
CF (随风漂) 于 2002年12月29日22:06:43 星期天 说道:
? How to navigate the taskbar without a mouse (Windows tip)
Want to know if the Windows taskbar's auto hide feature is enabled?
Here's a simple function to check this written in C Language / C++ and
Delphi.
Delphi CODE
uses ShellAPI;
(*
Returns TRUE if taskbar auto hide is on.
if(IsTaskBarautoHideOn)then
begin
// auto hide is ON
end;
*)
function IsTaskbarAutoHideOn : boolean;
var
ABData : TAppBarData;
begin
ABData.cbSize := sizeof(ABData);
Result :=
(SHAppBarMessage(ABM_GETSTATE, ABData)
and ABS_AUTOHIDE) > 0;
end;
Listing #1 : Delphi code. Right click tbah_pas.pas to download.
C Language / C++ CODE
#include<shellapi.h>
//
// Returns >0 if taskbar auto hide is on.
//
int IsTaskbarAutoHideOn()
{
APPBARDATA ABData;
ABData.cbSize = sizeof(ABData);
return
SHAppBarMessage(ABM_GETSTATE, &ABData)
& ABS_AUTOHIDE;
}
────────────────────────────────────────