Как работать со сканером?
Как работать со сканером?
////////////////////////////////////////////////////////////////////////
////
// Delphi Scanner Support Framework //
// //
// Copyright (C) 1999 by Uli Tessel //
// //
////////////////////////////////////////////////////////////////////////
// //
// Modified and rewritten as a Delphi component by: //
// //
// M. de Haan //
// //
// June 2002 //
// //
////////////////////////////////////////////////////////////////////////
unit
TWAIN;
interface
uses
SysUtils, // Exceptions
Forms, // TMessageEvent
Windows, // HMODULE
Graphics, // TBitmap
IniFiles, // Inifile
Controls, // TCursor
Classes; // Class
const
// Messages
MSG_GET = $0001; // Get one or more values
MSG_GETCURRENT = $0002; // Get current value
MSG_GETDEFAULT = $0003; // Get default (e.g. power up) value
MSG_GETFIRST = $0004; // Get first of a series of items,
// e.g. Data Sources
MSG_GETNEXT = $0005; // Iterate through a series of items
MSG_SET = $0006; // Set one or more values
MSG_RESET = $0007; // Set current value to default value
MSG_QUERYSUPPORT = $0008; // Get supported operations on the
// capacities
// Messages used with DAT_NULL
// ---------------------------
MSG_XFERREADY = $0101; // The data source has data ready
MSG_CLOSEDSREQ = $0102; // Request for the application to close
// the Data Source
MSG_CLOSEDSOK = $0103; // Tell the application to save the
// state
MSG_DEVICEEVENT = $0104; // Some event has taken place
// Messages used with a pointer to a DAT_STATUS structure
// ------------------------------------------------------
MSG_CHECKSTATUS = $0201; // Get status information
// Messages used with a pointer to DAT_PARENT data
// -----------------------------------------------
MSG_OPENDSM = $0301; // Open the Data Source Manager
MSG_CLOSEDSM = $0302; // Close the Data Source Manager
// Messages used with a pointer to a DAT_IDENTITY structure
// --------------------------------------------------------
MSG_OPENDS = $0401; // Open a Data Source
MSG_CLOSEDS = $0402; // Close a Data Source
MSG_USERSELECT = $0403; // Put up a dialog of all Data Sources
// The user can select a Data Source
// Messages used with a pointer to a DAT_USERINTERFACE structure
// -------------------------------------------------------------
MSG_DISABLEDS = $0501; // Disable data transfer in the Data
// Source
MSG_ENABLEDS = $0502; // Enable data transfer in the Data
// Source
MSG_ENABLEDSUIONLY = $0503; // Enable for saving Data Source state
// only
// Messages used with a pointer to a DAT_EVENT structure
// -----------------------------------------------------
MSG_PROCESSEVENT = $0601;
// Messages used with a pointer to a DAT_PENDINGXFERS structure
// ------------------------------------------------------------
MSG_ENDXFER = $0701;
MSG_STOPFEEDER = $0702;
// Messages used with a pointer to a DAT_FILESYSTEM structure
// ----------------------------------------------------------
MSG_CHANGEDIRECTORY = $0801;
MSG_CREATEDIRECTORY = $0802;
MSG_DELETE = $0803;
MSG_FORMATMEDIA = $0804;
MSG_GETCLOSE = $0805;
MSG_GETFIRSTFILE = $0806;
MSG_GETINFO = $0807;
MSG_GETNEXTFILE = $0808;
MSG_RENAME = $0809;
MSG_COPY = $080A;
MSG_AUTOMATICCAPTUREDIRECTORY = $080B;
// Messages used with a pointer to a DAT_PASSTHRU structure
// --------------------------------------------------------
MSG_PASSTHRU = $0901;
const
DG_CONTROL = $0001; // data pertaining to control
DG_IMAGE = $0002; // data pertaining to raster images
const
// Data Argument Types for the DG_CONTROL Data Group.
DAT_CAPABILITY = $0001; // TW_CAPABILITY
DAT_EVENT = $0002; // TW_EVENT
DAT_IDENTITY = $0003; // TW_IDENTITY
DAT_PARENT = $0004; // TW_HANDLE,
// application win handle in Windows
DAT_PENDINGXFERS = $0005; // TW_PENDINGXFERS
DAT_SETUPMEMXFER = $0006; // TW_SETUPMEMXFER
DAT_SETUPFILEXFER = $0007; // TW_SETUPFILEXFER
DAT_STATUS = $0008; // TW_STATUS
DAT_USERINTERFACE = $0009; // TW_USERINTERFACE
DAT_XFERGROUP = $000A; // TW_UINT32
DAT_IMAGEMEMXFER = $0103; // TW_IMAGEMEMXFER
DAT_IMAGENATIVEXFER = $0104; // TW_UINT32, loword is hDIB, PICHandle
DAT_IMAGEFILEXFER = $0105; // Null data
const
// Condition Codes: Application gets these by doing DG_CONTROL
// DAT_STATUS MSG_GET.
TWCC_CUSTOMBASE = $8000;
TWCC_SUCCESS = 00; // It worked!
TWCC_BUMMER = 01; // Failure due to unknown causes
TWCC_LOWMEMORY = 02; // Not enough memory to perform operation
TWCC_NODS = 03; // No Data Source
TWCC_MAXCONNECTIONS = 04; // Data Source is connected to maximum
// number of possible applications
TWCC_OPERATIONERROR = 05; // Data Source or Data Source Manager
// reported error, application
// shouldn't report an error
TWCC_BADCAP = 06; // Unknown capability
TWCC_BADPROTOCOL = 09; // Unrecognized MSG DG DAT combination
TWCC_BADVALUE = 10; // Data parameter out of range
TWCC_SEQERROR = 11; // DG DAT MSG out of expected sequence
TWCC_BADDEST = 12; // Unknown destination Application /
// Source in DSM_Entry
TWCC_CAPUNSUPPORTED = 13; // Capability not supported by source
TWCC_CAPBADOPERATION = 14; // Operation not supported by
// capability
TWCC_CAPSEQERROR = 15; // Capability has dependancy on other
// capability
TWCC_DENIED = 16; // File System operation is denied
// (file is protected)
TWCC_FILEEXISTS = 17; // Operation failed because file
// already exists
TWCC_FILENOTFOUND = 18; // File not found
TWCC_NOTEMPTY = 19; // Operation failed because directory
// is not empty
TWCC_PAPERJAM = 20; // The feeder is jammed
TWCC_PAPERDOUBLEFEED = 21; // The feeder detected multiple pages
TWCC_FILEWRITEERROR = 22; // Error writing the file (meant for
// things like disk full conditions)
TWCC_CHECKDEVICEONLINE = 23; // The device went offline prior to or
// during this operation
const
// Flags used in TW_MEMORY structure
TWMF_APPOWNS = $01;
TWMF_DSMOWNS = $02;
TWMF_DSOWNS = $04;
TWMF_POINTER = $08;
TWMF_HANDLE = $10;
const
// Flags for country, which seems to be equal to their telephone
// number
TWCY_AFGHANISTAN = 1001;
TWCY_ALGERIA = 0213;
TWCY_AMERICANSAMOA = 0684;
TWCY_ANDORRA = 0033;
TWCY_ANGOLA = 1002;
TWCY_ANGUILLA = 8090;
TWCY_ANTIGUA = 8091;
TWCY_ARGENTINA = 0054;
TWCY_ARUBA = 0297;
TWCY_ASCENSIONI = 0247;
TWCY_AUSTRALIA = 0061;
TWCY_AUSTRIA = 0043;
TWCY_BAHAMAS = 8092;
TWCY_BAHRAIN = 0973;
TWCY_BANGLADESH = 0880;
TWCY_BARBADOS = 8093;
TWCY_BELGIUM = 0032;
TWCY_BELIZE = 0501;
TWCY_BENIN = 0229;
TWCY_BERMUDA = 8094;
TWCY_BHUTAN = 1003;
TWCY_BOLIVIA = 0591;
TWCY_BOTSWANA = 0267;
TWCY_BRITAIN = 0006;
TWCY_BRITVIRGINIS = 8095;
TWCY_BRAZIL = 0055;
TWCY_BRUNEI = 0673;
TWCY_BULGARIA = 0359;
TWCY_BURKINAFASO = 1004;
TWCY_BURMA = 1005;
TWCY_BURUNDI = 1006;
TWCY_CAMAROON = 0237;
TWCY_CANADA = 0002;
TWCY_CAPEVERDEIS = 0238;
TWCY_CAYMANIS = 8096;
TWCY_CENTRALAFREP = 1007;
TWCY_CHAD = 1008;
TWCY_CHILE = 0056;
TWCY_CHINA = 0086;
TWCY_CHRISTMASIS = 1009;
TWCY_COCOSIS = 1009;
TWCY_COLOMBIA = 0057;
TWCY_COMOROS = 1010;
TWCY_CONGO = 1011;
TWCY_COOKIS = 1012;
TWCY_COSTARICA = 0506;
TWCY_CUBA = 0005;
TWCY_CYPRUS = 0357;
TWCY_CZECHOSLOVAKIA = 0042;
TWCY_DENMARK = 0045;
TWCY_DJIBOUTI = 1013;
TWCY_DOMINICA = 8097;
TWCY_DOMINCANREP = 8098;
TWCY_EASTERIS = 1014;
TWCY_ECUADOR = 0593;
TWCY_EGYPT = 0020;
TWCY_ELSALVADOR = 0503;
TWCY_EQGUINEA = 1015;
TWCY_ETHIOPIA = 0251;
TWCY_FALKLANDIS = 1016;
TWCY_FAEROEIS = 0298;
TWCY_FIJIISLANDS = 0679;
TWCY_FINLAND = 0358;
TWCY_FRANCE = 0033;
TWCY_FRANTILLES = 0596;
TWCY_FRGUIANA = 0594;
TWCY_FRPOLYNEISA = 0689;
TWCY_FUTANAIS = 1043;
TWCY_GABON = 0241;
TWCY_GAMBIA = 0220;
TWCY_GERMANY = 0049;
TWCY_GHANA = 0233;
TWCY_GIBRALTER = 0350;
TWCY_GREECE = 0030;
TWCY_GREENLAND = 0299;
TWCY_GRENADA = 8099;
TWCY_GRENEDINES = 8015;
TWCY_GUADELOUPE = 0590;
TWCY_GUAM = 0671;
TWCY_GUANTANAMOBAY = 5399;
TWCY_GUATEMALA = 0502;
TWCY_GUINEA = 0224;
TWCY_GUINEABISSAU = 1017;
TWCY_GUYANA = 0592;
TWCY_HAITI = 0509;
TWCY_HONDURAS = 0504;
TWCY_HONGKONG = 0852;
TWCY_HUNGARY = 0036;
TWCY_ICELAND = 0354;
TWCY_INDIA = 0091;
TWCY_INDONESIA = 0062;
TWCY_IRAN = 0098;
TWCY_IRAQ = 0964;
TWCY_IRELAND = 0353;
TWCY_ISRAEL = 0972;
TWCY_ITALY = 0039;
TWCY_IVORYCOAST = 0225;
TWCY_JAMAICA = 8010;
TWCY_JAPAN = 0081;
TWCY_JORDAN = 0962;
TWCY_KENYA = 0254;
TWCY_KIRIBATI = 1018;
TWCY_KOREA = 0082;
TWCY_KUWAIT = 0965;
TWCY_LAOS = 1019;
TWCY_LEBANON = 1020;
TWCY_LIBERIA = 0231;
TWCY_LIBYA = 0218;
TWCY_LIECHTENSTEIN = 0041;
TWCY_LUXENBOURG = 0352;
TWCY_MACAO = 0853;
TWCY_MADAGASCAR = 1021;
TWCY_MALAWI = 0265;
TWCY_MALAYSIA = 0060;
TWCY_MALDIVES = 0960;
TWCY_MALI = 1022;
TWCY_MALTA = 0356;
TWCY_MARSHALLIS = 0692;
TWCY_MAURITANIA = 1023;
TWCY_MAURITIUS = 0230;
TWCY_MEXICO = 0003;
TWCY_MICRONESIA = 0691;
TWCY_MIQUELON = 0508;
TWCY_MONACO = 0033;
TWCY_MONGOLIA = 1024;
TWCY_MONTSERRAT = 8011;
TWCY_MOROCCO = 0212;
TWCY_MOZAMBIQUE = 1025;
TWCY_NAMIBIA = 0264;
TWCY_NAURU = 1026;
TWCY_NEPAL = 0977;
TWCY_NETHERLANDS = 0031;
TWCY_NETHANTILLES = 0599;
TWCY_NEVIS = 8012;
TWCY_NEWCALEDONIA = 0687;
TWCY_NEWZEALAND = 0064;
TWCY_NICARAGUA = 0505;
TWCY_NIGER = 0227;
TWCY_NIGERIA = 0234;
TWCY_NIUE = 1027;
TWCY_NORFOLKI = 1028;
TWCY_NORWAY = 0047;
TWCY_OMAN = 0968;
TWCY_PAKISTAN = 0092;
TWCY_PALAU = 1029;
TWCY_PANAMA = 0507;
TWCY_PARAGUAY = 0595;
TWCY_PERU = 0051;
TWCY_PHILLIPPINES = 0063;
TWCY_PITCAIRNIS = 1030;
TWCY_PNEWGUINEA = 0675;
TWCY_POLAND = 0048;
TWCY_PORTUGAL = 0351;
TWCY_QATAR = 0974;
TWCY_REUNIONI = 1031;
TWCY_ROMANIA = 0040;
TWCY_RWANDA = 0250;
TWCY_SAIPAN = 0670;
TWCY_SANMARINO = 0039;
TWCY_SAOTOME = 1033;
TWCY_SAUDIARABIA = 0966;
TWCY_SENEGAL = 0221;
TWCY_SEYCHELLESIS = 1034;
TWCY_SIERRALEONE = 1035;
TWCY_SINGAPORE = 0065;
TWCY_SOLOMONIS = 1036;
TWCY_SOMALI = 1037;
TWCY_SOUTHAFRICA = 0027;
TWCY_SPAIN = 0034;
TWCY_SRILANKA = 0094;
TWCY_STHELENA = 1032;
TWCY_STKITTS = 8013;
TWCY_STLUCIA = 8014;
TWCY_STPIERRE = 0508;
TWCY_STVINCENT = 8015;
TWCY_SUDAN = 1038;
TWCY_SURINAME = 0597;
TWCY_SWAZILAND = 0268;
TWCY_SWEDEN = 0046;
TWCY_SWITZERLAND = 0041;
TWCY_SYRIA = 1039;
TWCY_TAIWAN = 0886;
TWCY_TANZANIA = 0255;
TWCY_THAILAND = 0066;
TWCY_TOBAGO = 8016;
TWCY_TOGO = 0228;
TWCY_TONGAIS = 0676;
TWCY_TRINIDAD = 8016;
TWCY_TUNISIA = 0216;
TWCY_TURKEY = 0090;
TWCY_TURKSCAICOS = 8017;
TWCY_TUVALU = 1040;
TWCY_UGANDA = 0256;
TWCY_USSR = 0007;
TWCY_UAEMIRATES = 0971;
TWCY_UNITEDKINGDOM = 0044;
TWCY_USA = 0001;
TWCY_URUGUAY = 0598;
TWCY_VANUATU = 1041;
TWCY_VATICANCITY = 0039;
TWCY_VENEZUELA = 0058;
TWCY_WAKE = 1042;
TWCY_WALLISIS = 1043;
TWCY_WESTERNSAHARA = 1044;
TWCY_WESTERNSAMOA = 1045;
TWCY_YEMEN = 1046;
TWCY_YUGOSLAVIA = 0038;
TWCY_ZAIRE = 0243;
TWCY_ZAMBIA = 0260;
TWCY_ZIMBABWE = 0263;
TWCY_ALBANIA = 0355;
TWCY_ARMENIA = 0374;
TWCY_AZERBAIJAN = 0994;
TWCY_BELARUS = 0375;
TWCY_BOSNIAHERZGO = 0387;
TWCY_CAMBODIA = 0855;
TWCY_CROATIA = 0385;
TWCY_CZECHREPUBLIC = 0420;
TWCY_DIEGOGARCIA = 0246;
TWCY_ERITREA = 0291;
TWCY_ESTONIA = 0372;
TWCY_GEORGIA = 0995;
TWCY_LATVIA = 0371;
TWCY_LESOTHO = 0266;
TWCY_LITHUANIA = 0370;
TWCY_MACEDONIA = 0389;
TWCY_MAYOTTEIS = 0269;
TWCY_MOLDOVA = 0373;
TWCY_MYANMAR = 0095;
TWCY_NORTHKOREA = 0850;
TWCY_PUERTORICO = 0787;
TWCY_RUSSIA = 0007;
TWCY_SERBIA = 0381;
TWCY_SLOVAKIA = 0421;
TWCY_SLOVENIA = 0386;
TWCY_SOUTHKOREA = 0082;
TWCY_UKRAINE = 0380;
TWCY_USVIRGINIS = 0340;
TWCY_VIETNAM = 0084;
const
// Flags for languages
TWLG_DAN = 000; // Danish
TWLG_DUT = 001; // Dutch
TWLG_ENG = 002; // English
TWLG_FCF = 003; // French Canadian
TWLG_FIN = 004; // Finnish
TWLG_FRN = 005; // French
TWLG_GER = 006; // German
TWLG_ICE = 007; // Icelandic
TWLG_ITN = 008; // Italian
TWLG_NOR = 009; // Norwegian
TWLG_POR = 010; // Portuguese
TWLG_SPA = 011; // Spannish
TWLG_SWE = 012; // Swedish
TWLG_USA = 013;
TWLG_AFRIKAANS = 014;
TWLG_ALBANIA = 015;
TWLG_ARABIC = 016;
TWLG_ARABIC_ALGERIA = 017;
TWLG_ARABIC_BAHRAIN = 018;
TWLG_ARABIC_EGYPT = 019;
TWLG_ARABIC_IRAQ = 020;
TWLG_ARABIC_JORDAN = 021;
TWLG_ARABIC_KUWAIT = 022;
TWLG_ARABIC_LEBANON = 023;
TWLG_ARABIC_LIBYA = 024;
TWLG_ARABIC_MOROCCO = 025;
TWLG_ARABIC_OMAN = 026;
TWLG_ARABIC_QATAR = 027;
TWLG_ARABIC_SAUDIARABIA = 028;
TWLG_ARABIC_SYRIA = 029;
TWLG_ARABIC_TUNISIA = 030;
TWLG_ARABIC_UAE = 031; // United Arabic Emirates
TWLG_ARABIC_YEMEN = 032;
TWLG_BASQUE = 033;
TWLG_BYELORUSSIAN = 034;
TWLG_BULGARIAN = 035;
TWLG_CATALAN = 036;
TWLG_CHINESE = 037;
TWLG_CHINESE_HONGKONG = 038;
TWLG_CHINESE_PRC = 039; // People's Republic of China
TWLG_CHINESE_SINGAPORE = 040;
TWLG_CHINESE_SIMPLIFIED = 041;
TWLG_CHINESE_TAIWAN = 042;
TWLG_CHINESE_TRADITIONAL = 043;
TWLG_CROATIA = 044;
TWLG_CZECH = 045;
TWLG_DANISH = TWLG_DAN;
TWLG_DUTCH = TWLG_DUT;
TWLG_DUTCH_BELGIAN = 046;
TWLG_ENGLISH = TWLG_ENG;
TWLG_ENGLISH_AUSTRALIAN = 047;
TWLG_ENGLISH_CANADIAN = 048;
TWLG_ENGLISH_IRELAND = 049;
TWLG_ENGLISH_NEWZEALAND = 050;
TWLG_ENGLISH_SOUTHAFRICA = 051;
TWLG_ENGLISH_UK = 052;
TWLG_ENGLISH_USA = TWLG_USA;
TWLG_ESTONIAN = 053;
TWLG_FAEROESE = 054;
TWLG_FARSI = 055;
TWLG_FINNISH = TWLG_FIN;
TWLG_FRENCH = TWLG_FRN;
TWLG_FRENCH_BELGIAN = 056;
TWLG_FRENCH_CANADIAN = TWLG_FCF;
TWLG_FRENCH_LUXEMBOURG = 057;
TWLG_FRENCH_SWISS = 058;
TWLG_GERMAN = TWLG_GER;
TWLG_GERMAN_AUSTRIAN = 059;
TWLG_GERMAN_LUXEMBOURG = 060;
TWLG_GERMAN_LIECHTENSTEIN = 061;
TWLG_GERMAN_SWISS = 062;
TWLG_GREEK = 063;
TWLG_HEBREW = 064;
TWLG_HUNGARIAN = 065;
TWLG_ICELANDIC = TWLG_ICE;
TWLG_INDONESIAN = 066;
TWLG_ITALIAN = TWLG_ITN;
TWLG_ITALIAN_SWISS = 067;
TWLG_JAPANESE = 068;
TWLG_KOREAN = 069;
TWLG_KOREAN_JOHAB = 070;
TWLG_LATVIAN = 071;
TWLG_LITHUANIAN = 072;
TWLG_NORWEGIAN = TWLG_NOR;
TWLG_NORWEGIAN_BOKMAL = 073;
TWLG_NORWEGIAN_NYNORSK = 074;
TWLG_POLISH = 075;
TWLG_PORTUGUESE = TWLG_POR;
TWLG_PORTUGUESE_BRAZIL = 076;
TWLG_ROMANIAN = 077;
TWLG_RUSSIAN = 078;
TWLG_SERBIAN_LATIN = 079;
TWLG_SLOVAK = 080;
TWLG_SLOVENIAN = 081;
TWLG_SPANISH = TWLG_SPA;
TWLG_SPANISH_MEXICAN = 082;
TWLG_SPANISH_MODERN = 083;
TWLG_SWEDISH = TWLG_SWE;
TWLG_THAI = 084;
TWLG_TURKISH = 085;
TWLG_UKRANIAN = 086;
TWLG_ASSAMESE = 087;
TWLG_BENGALI = 088;
TWLG_BIHARI = 089;
TWLG_BODO = 090;
TWLG_DOGRI = 091;
TWLG_GUJARATI = 092;
TWLG_HARYANVI = 093;
TWLG_HINDI = 094;
TWLG_KANNADA = 095;
TWLG_KASHMIRI = 096;
TWLG_MALAYALAM = 097;
TWLG_MARATHI = 098;
TWLG_MARWARI = 099;
TWLG_MEGHALAYAN = 100;
TWLG_MIZO = 101;
TWLG_NAGA = 102;
TWLG_ORISSI = 103;
TWLG_PUNJABI = 104;
TWLG_PUSHTU = 105;
TWLG_SERBIAN_CYRILLIC = 106;
TWLG_SIKKIMI = 107;
TWLG_SWEDISH_FINLAND = 108;
TWLG_TAMIL = 109;
TWLG_TELUGU = 110;
TWLG_TRIPURI = 111;
TWLG_URDU = 112;
TWLG_VIETNAMESE = 113;
const
TWRC_SUCCESS = 0;
TWRC_FAILURE = 1; // Application may get TW_STATUS for
// info on failure
TWRC_CHECKSTATUS = 2; // tried hard to get the status
TWRC_CANCEL = 3;
TWRC_DSEVENT = 4;
TWRC_NOTDSEVENT = 5;
TWRC_XFERDONE = 6;
TWRC_ENDOFLIST = 7; // After MSG_GETNEXT if nothing left
TWRC_INFONOTSUPPORTED = 8;
TWRC_DATANOTAVAILABLE = 9;
const
TWON_ONEVALUE = $05; // indicates TW_ONEVALUE container
TWON_DONTCARE8 = $FF;
const
ICAP_XFERMECH = $0103;
const
TWTY_UINT16 = $0004; // Means: item is a TW_UINT16
const
// ICAP_XFERMECH values (SX_ means Setup XFer)
TWSX_NATIVE = 0;
TWSX_FILE = 1;
TWSX_MEMORY = 2;
TWSX_FILE2 = 3;
type
TW_UINT16 = WORD; // unsigned short TW_UINT16
pTW_UINT16 = ^TW_UINT16;
TTWUInt16 = TW_UINT16;
PTWUInt16 = pTW_UINT16;
type
TW_BOOL = WORDBOOL; // unsigned short TW_BOOL
pTW_BOOL = ^TW_BOOL;
TTWBool = TW_BOOL;
PTWBool = pTW_BOOL;
type
TW_STR32 = array[0..33] of Char; // char TW_STR32[34]
pTW_STR32 = ^TW_STR32;
TTWStr32 = TW_STR32;
PTWStr32 = pTW_STR32;
type
TW_STR255 = array[0..255] of Char; // char TW_STR255[256]
pTW_STR255 = ^TW_STR255;
TTWStr255 = TW_STR255;
PTWStr255 = pTW_STR255;
type
TW_INT16 = SmallInt; // short TW_INT16
pTW_INT16 = ^TW_INT16;
TTWInt16 = TW_INT16;
PTWInt16 = pTW_INT16;
type
TW_UINT32 = ULONG; // unsigned long TW_UINT32
pTW_UINT32 = ^TW_UINT32;
TTWUInt32 = TW_UINT32;
PTWUInt32 = pTW_UINT32;
type
TW_HANDLE = THandle;
TTWHandle = TW_HANDLE;
TW_MEMREF = Pointer;
TTWMemRef = TW_MEMREF;
type
// DAT_PENDINGXFERS. Used with MSG_ENDXFER to indicate additional
// data
TW_PENDINGXFERS = packed record
Count: TW_UINT16;
case Boolean of
False: (EOJ: TW_UINT32);
True: (Reserved: TW_UINT32);
end;
pTW_PENDINGXFERS = ^TW_PENDINGXFERS;
TTWPendingXFERS = TW_PENDINGXFERS;
PTWPendingXFERS = pTW_PENDINGXFERS;
type
// DAT_EVENT. For passing events down from the application to the DS
TW_EVENT = packed record
pEvent: TW_MEMREF; // Windows pMSG or Mac pEvent.
TWMessage: TW_UINT16; // TW msg from data source, e.g.
// MSG_XFERREADY
end;
pTW_EVENT = ^TW_EVENT;
TTWEvent = TW_EVENT;
PTWEvent = pTW_EVENT;
type
// TWON_ONEVALUE. Container for one value
TW_ONEVALUE = packed record
ItemType: TW_UINT16;
Item: TW_UINT32;
end;
pTW_ONEVALUE = ^TW_ONEVALUE;
TTWOneValue = TW_ONEVALUE;
PTWOneValue = pTW_ONEVALUE;
type
// DAT_CAPABILITY. Used by application to get/set capability from/in
// a data source.
TW_CAPABILITY = packed record
Cap: TW_UINT16; // id of capability to set or get, e.g.
// CAP_BRIGHTNESS
ConType: TW_UINT16; // TWON_ONEVALUE, _RANGE, _ENUMERATION or
// _ARRAY
hContainer: TW_HANDLE; // Handle to container of type Dat
end;
pTW_CAPABILITY = ^TW_CAPABILITY;
TTWCapability = TW_CAPABILITY;
PTWCapability = pTW_CAPABILITY;
type
// DAT_STATUS. Application gets detailed status info from a data
// source with this
TW_STATUS = packed record
ConditionCode: TW_UINT16; // Any TWCC_xxx constant
Reserved: TW_UINT16; // Future expansion space
end;
pTW_STATUS = ^TW_STATUS;
TTWStatus = TW_STATUS;
PTWStatus = pTW_STATUS;
type
// No DAT needed. Used to manage memory buffers
TW_MEMORY = packed record
Flags: TW_UINT32; // Any combination of the TWMF_ constants
Length: TW_UINT32; // Number of bytes stored in buffer TheMem
TheMem: TW_MEMREF; // Pointer or handle to the allocated memory
// buffer
end;
pTW_MEMORY = ^TW_MEMORY;
TTWMemory = TW_MEMORY;
PTWMemory = pTW_MEMORY;
const
// ICAP_IMAGEFILEFORMAT values (FF_means File Format
TWFF_TIFF = 0; // Tagged Image File Format
TWFF_PICT = 1; // Macintosh PICT
TWFF_BMP = 2; // Windows Bitmap
TWFF_XBM = 3; // X-Windows Bitmap
TWFF_JFIF = 4; // JPEG File Interchange Format
TWFF_FPX = 5; // Flash Pix
TWFF_TIFFMULTI = 6; // Multi-page tiff file
TWFF_PNG = 7; // Portable Network Graphic
TWFF_SPIFF = 8;
TWFF_EXIF = 9;
type
// DAT_SETUPFILEXFER. Sets up DS to application data transfer via a
// file
TW_SETUPFILEXFER = packed record
FileName: TW_STR255;
Format: TW_UINT16; // Any TWFF_xxx constant
VRefNum: TW_INT16; // Used for Mac only
end;
pTW_SETUPFILEXFER = ^TW_SETUPFILEXFER;
TTWSetupFileXFER = TW_SETUPFILEXFER;
PTWSetupFileXFER = pTW_SETUPFILEXFER;
type
// DAT_SETUPFILEXFER2. Sets up DS to application data transfer via a
// file. }
TW_SETUPFILEXFER2 = packed record
FileName: TW_MEMREF; // Pointer to file name text
FileNameType: TW_UINT16; // TWTY_STR1024 or TWTY_UNI512
Format: TW_UINT16; // Any TWFF_xxx constant
VRefNum: TW_INT16; // Used for Mac only
parID: TW_UINT32; // Used for Mac only
end;
pTW_SETUPFILEXFER2 = ^TW_SETUPFILEXFER2;
TTWSetupFileXFER2 = TW_SETUPFILEXFER2;
PTWSetupFileXFER2 = pTW_SETUPFILEXFER2;
type
// DAT_SETUPMEMXFER. Sets up Data Source to application data
// transfer via a memory buffer
TW_SETUPMEMXFER = packed record
MinBufSize: TW_UINT32;
MaxBufSize: TW_UINT32;
Preferred: TW_UINT32;
end;
pTW_SETUPMEMXFER = ^TW_SETUPMEMXFER;
TTWSetupMemXFER = TW_SETUPMEMXFER;
PTWSetupMemXFER = pTW_SETUPMEMXFER;
type
TW_VERSION = packed record
MajorNum: TW_UINT16; // Major revision number of the software.
MinorNum: TW_UINT16; // Incremental revision number of the
// software
Language: TW_UINT16; // e.g. TWLG_SWISSFRENCH
Country: TW_UINT16; // e.g. TWCY_SWITZERLAND
Info: TW_STR32; // e.g. "1.0b3 Beta release"
end;
pTW_VERSION = ^TW_VERSION;
PTWVersion = pTW_VERSION;
TTWVersion = TW_VERSION;
type
TW_IDENTITY = packed record
Id: TW_UINT32; // Unique number. In Windows,
// application hWnd
Version: TW_VERSION; // Identifies the piece of code
ProtocolMajor: TW_UINT16; // Application and DS must set to
// TWON_PROTOCOLMAJOR
ProtocolMinor: TW_UINT16; // Application and DS must set to
// TWON_PROTOCOLMINOR
SupportedGroups: TW_UINT32; // Bit field OR combination of DG_
// constants
Manufacturer: TW_STR32; // Manufacturer name, e.g.
// "Hewlett-Packard"
ProductFamily: TW_STR32; // Product family name, e.g.
// "ScanJet"
ProductName: TW_STR32; // Product name, e.g. "ScanJet Plus"
end;
pTW_IDENTITY = ^TW_IDENTITY;
type
// DAT_USERINTERFACE. Coordinates UI between application and data
// source
TW_USERINTERFACE = packed record
ShowUI: TW_BOOL; // TRUE if DS should bring up its UI
ModalUI: TW_BOOL; // For Mac only - true if the DS's UI is modal
hParent: TW_HANDLE; // For Windows only - Application handle
end;
pTW_USERINTERFACE = ^TW_USERINTERFACE;
TTWUserInterface = TW_USERINTERFACE;
PTWUserInterface = pTW_USERINTERFACE;
////////////////////////////////////////////////////////////////////////
// //
// END OF TWAIN TYPES AND CONSTANTS //
// //
////////////////////////////////////////////////////////////////////////
const
TWAIN_DLL_Name = 'TWAIN_32.DLL';
DSM_Entry_Name = 'DSM_Entry';
Ini_File_Name = 'WIN.INI';
CrLf = #13 + #10;
resourcestring // Errorstrings:
ERR_DSM_ENTRY_NOT_FOUND = 'Unable to find the entry of the Data ' +
'Source Manager in: TWAIN_32.DLL';
ERR_TWAIN_NOT_LOADED = 'Unable to load or find: TWAIN_32.DLL';
ERR_DSM_CALL_FAILED = 'A call to the Data Source Manager failed ' +
'in module %s';
ERR_UNKNOWN = 'A call to the Data Source Manager failed ' +
'in module %s: Code %.04x';
ERR_DSM_OPEN = 'Unable to close the Data Source Manager. ' +
'Maybe a source is still in use';
ERR_STATUS = 'Unable to get the status';
ERR_DSM = 'Data Source Manager error in module %s:' +
CrLf + '%s';
ERR_DS = 'Data Source error in module %s:' +
CrLf + '%s';
type
ETwainError = class(Exception);
TImageType = (ffTIFF, ffPICT, ffBMP, ffXBM, ffJFIF, ffFPX,
ffTIFFMULTI, ffPNG, ffSPIFF, ffEXIF, ffUNKNOWN);
TTransferType = (xfNative, xfMemory, xfFile);
TLanguageType = (lgDutch, lgEnglish,
lgFrench, lgGerman,
lgAmerican, lgItalian,
lgSpanish, lgNorwegian,
lgFinnish, lgDanish,
lgRussian, lgPortuguese,
lgSwedish, lgPolish,
lgGreek, lgTurkish);
TCountryType = (ctNetherlands, ctEngland,
ctFrance, ctGermany,
ctUSA, ctSpain,
ctItaly, ctDenmark,
ctFinland, ctNorway,
ctRussia, ctPortugal,
ctSweden, ctPoland,
ctGreece, ctTurkey);
TTWAIN = class(TComponent)
private
// Private declarations
fBitmap: TBitmap; // the actual bmp used for
// scanning, must be
// removed
HDSMDLL: HMODULE; // = 0, the library handle:
// will stay global
appId: TW_IDENTITY; // our (Application) ID.
// (may stay global)
dsId: TW_IDENTITY; // Data Source ID (will
// become member of DS
// class)
fhWnd: HWND; // = 0, maybe will be
// removed, use
// application.handle
// instead
fXfer: TTransferType; // = xfNative;
bDataSourceManagerOpen: Boolean; // = False, flag, may stay
// global
bDataSourceOpen: Boolean; // = False, will become
// member of DS class
bDataSourceEnabled: Boolean; // = False, will become
// member of DS class
fScanReady: TNotifyEvent; // notifies that the scan
// is ready
sDefaultSource: string; // remember old data source
fOldOnMessageHandler: TMessageEvent; // Save old OnMessage event
fShowUI: Boolean; // Show User Interface
fSetupFileXfer: TW_SETUPFILEXFER; // Not used yet
fSetupMemoryXfer: TW_SETUPMEMXFER; // Not used yet
fMemory: TW_MEMORY; // Not used yet
function fLoadTwain: Boolean;
procedure fUnloadTwain;
function fNativeXfer: Boolean;
function fMemoryXfer: Boolean; // Not used yet
function fFileXfer: Boolean; // Not used yet
function fGetDestination: TTransferType;
procedure fSetDestination(dest: TTransferType);
function Condition2String(ConditionCode: TW_UINT16): string;
procedure RaiseLastDataSourceManagerCondition(module: string);
procedure RaiseLastDataSourceCondition(module: string);
procedure TwainCheckDataSourceManager(res: TW_UINT16;
module: string);
procedure TwainCheckDataSource(res: TW_UINT16;
module: string);
function CallDataSourceManager(pOrigin: pTW_IDENTITY;
DG: TW_UINT32;
DAT: TW_UINT16;
MSG: TW_UINT16;
pData: TW_MEMREF): TW_UINT16;
function CallDataSource(DG: TW_UINT32;
DAT: TW_UINT16;
MSG: TW_UINT16;
pData: TW_MEMREF): TW_UINT16;
procedure XferMech;
procedure fSetProductname(pn: string);
function fGetProductname: string;
procedure fSetManufacturer(mf: string);
function fGetManufacturer: string;
procedure fSetProductFamily(pf: string);
function fGetProductFamily: string;
procedure fSetLanguage(lg: TLanguageType);
function fGetLanguage: TLanguageType;
procedure fSetCountry(ct: TCountryType);
function fGetCountry: TCountryType;
procedure SaveDefaultSourceEntry;
procedure RestoreDefaultSourceEntry;
procedure fSetCursor(cr: TCursor);
function fGetCursor: TCursor;
procedure fSetImageType(it: TImageType);
function fGetImageType: TImageType;
procedure fSetFilename(fn: string);
function fGetFilename: string;
procedure fSetVersionInfo(vi: string);
function fGetVersionInfo: string;
procedure fSetVersionMajor(vmaj: WORD);
procedure fSetVersionMinor(vmin: WORD);
function fGetVersionMajor: WORD;
function fGetVersionMinor: WORD;
protected
procedure ScanReady; dynamic; // Notifies when image transfer is
// ready
procedure fNewOnMessageHandler(var Msg: TMsg;
var Handled: Boolean); virtual;
public
// Public declarations
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Acquire(aBmp: TBitmap);
procedure OpenDataSource;
procedure CloseDataSource;
procedure InitTWAIN;
procedure OpenDataSourceManager;
procedure CloseDataSourceManager;
function IsDataSourceManagerOpen: Boolean;
procedure EnableDataSource;
// Procedure TWEnableDSUIOnly(ShowUI : Boolean);
procedure DisableDataSource;
function IsDataSourceOpen: Boolean;
function IsDataSourceEnabled: Boolean;
procedure SelectDataSource;
function IsTwainDriverAvailable: Boolean;
function ProcessSourceMessage(var Msg: TMsg): Boolean;
published
// Published declarations
// Properties, methods
property Destination: TTransferType
read fGetDestination write fSetDestination;
property TwainDriverFound: Boolean
read IsTwainDriverAvailable;
property Productname: string
read fGetProductname write fSetProductname;
property Manufacturer: string
read fGetManufacturer write fSetManufacturer;
property ProductFamily: string
read fGetProductFamily write fSetProductFamily;
property Language: TLanguageType
read fGetLanguage write fSetLanguage;
property Country: TCountryType
read fGetCountry write fSetCountry;
property ShowUI: Boolean
read fShowUI write fShowUI;
property Cursor: TCursor
read fGetCursor write fSetCursor;
property FileFormat: TImageType
read fGetImageType write fSetImageType;
property Filename: string
read fGetFilename write fSetFilename;
property VersionInfo: string
read fGetVersionInfo write fSetVersionInfo;
property VersionMajor: WORD
read fGetVersionMajor write fSetVersionMajor;
property VersionMinor: WORD
read fGetVersionMinor write fSetVersionMinor;
// Events
property OnScanReady: TNotifyEvent
read fScanReady write fScanReady;
end;
procedure Register;
type
DSMENTRYPROC = function(pOrigin: pTW_IDENTITY;
pDest: pTW_IDENTITY;
DG: TW_UINT32;
DAT: TW_UINT16;
MSG: TW_UINT16;
pData: TW_MEMREF): TW_UINT16; stdcall;
TDSMEntryProc = DSMENTRYPROC;
type
DSENTRYPROC = function(pOrigin: pTW_IDENTITY;
DG: TW_UINT32;
DAT: TW_UINT16;
MSG: TW_UINT16;
pData: TW_MEMREF): TW_UINT16; stdcall;
TDSEntryProc = DSENTRYPROC;
var
DS_Entry: TDSEntryProc = nil; // Initialize
DSM_Entry: TDSMEntryProc = nil; // Initialize
implementation
//---------------------------------------------------------------------
constructor TTWAIN.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// Initialize variables
appID.Version.Info := 'Twain component';
appID.Version.Country := TWCY_USA;
appID.Version.Language := TWLG_USA;
appID.Productname := 'SimpelSoft TWAIN module'; // This is the one that you are
// going to see in the UI
appID.ManuFacturer := 'SimpelSoft';
appID.ProductFamily := 'SimpelSoft components';
appID.Version.MajorNum := 1;
appID.Version.MinorNum := 0;
// appID.ID := Application.Handle;
fSetFilename('C:\TWAIN.BMP');
// fSetupFileXfer.FileName := 'C:\TWAIN.TMP':
fSetImageType(ffBMP);
// fSetupFileXfer.Format := TWFF_BMP;
// fSetupFileXfer.VRefNum := xx; // For Mac
// fSetupMemoryXfer.MinBufSize := xx;
// fSetupMemoryXfer.MaxBufSize := yy;
// fSetupMemoryXfer.Preferred := zz;
fMemory.Flags := TWFF_BMP;
// fMemory.Length := SizeOf(Mem);
// fMemory.TheMem := @Mem;
// fhWnd := Application.Handle;
fShowUI := True;
HDSMDLL := 0;
sDefaultSource := '';
fXfer := xfNative;
bDataSourceManagerOpen := False;
bDataSourceOpen := False;
bDataSourceEnabled := False;
end;
//---------------------------------------------------------------------
destructor TTWAIN.Destroy;
begin
if bDataSourceEnabled then
DisableDataSource;
if bDataSourceOpen then
CloseDataSource;
if bDataSourceManagerOpen then
CloseDataSourceManager;
fUnLoadTwain; // Loose the TWAIN_32.DLL
if sDefaultSource <> '' then
RestoreDefaultSourceEntry; // Write old entry back in WIN.INI
Application.OnMessage := fOldOnMessageHandler; // Restore old OnMessage
// handler
inherited Destroy;
end;
//---------------------------------------------------------------------
function TTWAIN.fGetVersionMajor: WORD;
begin
Result := appID.Version.MajorNum;
end;
//---------------------------------------------------------------------
function TTWAIN.fGetVersionMinor: WORD;
begin
Result := appID.Version.MinorNum;
end;
//---------------------------------------------------------------------
procedure TTWAIN.fSetVersionMajor(vmaj: WORD);
begin
appID.Version.MajorNum := vmaj;
end;
//---------------------------------------------------------------------
procedure TTWAIN.fSetVersionMinor(vmin: WORD);
begin
appID.Version.MinorNum := vmin;
end;
//---------------------------------------------------------------------
procedure TTWAIN.fSetVersionInfo(vi: string);
var
I, L: Integer;
begin
FillChar(appID.Version.Info, SizeOf(appID.Version.Info), #0);
L := Length(vi);
if L = 0 then
Exit;
if L > 32 then
L := 32;
for I := 1 to L do
appID.Version.Info[I - 1] := vi[I];
end;
//---------------------------------------------------------------------
function TTWAIN.fGetVersionInfo: string;
var
I: Integer;
begin
Result := '';
I := 0;
if appID.Version.Info[I] <> #0 then
repeat
Result := Result + appID.Version.Info[I];
Inc(I);
until appID.Version.Info[I] = #0;
end;
//---------------------------------------------------------------------
procedure TTWAIN.fSetImageType(it: TImageType);
begin
fSetupFileXfer.Format := TWFF_BMP; // Initialize
fMemory.Flags := TWFF_BMP; // Initialize
case it of
ffTIFF:
begin
fSetupFileXfer.Format := TWFF_TIFF;
fMemory.Flags := TWFF_TIFF;
end;
ffPICT:
begin
fSetupFileXfer.Format := TWFF_PICT;
fMemory.Flags := TWFF_PICT;
end;
ffBMP:
begin
fSetupFileXfer.Format := TWFF_BMP;
fMemory.Flags := TWFF_BMP;
end;
ffXBM:
begin
fSetupFileXfer.Format := TWFF_XBM;
fMemory.Flags := TWFF_XBM;
end;
ffJFIF:
begin
fSetupFileXfer.Format := TWFF_JFIF;
fMemory.Flags := TWFF_JFIF;
end;
ffFPX:
begin
fSetupFileXfer.Format := TWFF_FPX;
fMemory.Flags := TWFF_FPX;
end;
ffTIFFMULTI:
begin
fSetupFileXfer.Format := TWFF_TIFFMULTI;
fMemory.Flags := TWFF_TIFFMULTI;
end;
ffPNG:
begin
fSetupFileXfer.Format := TWFF_PNG;
fMemory.Flags := TWFF_PNG;
end;
ffSPIFF:
begin
fSetupFileXfer.Format := TWFF_SPIFF;
fMemory.Flags := TWFF_SPIFF;
end;
ffEXIF:
begin
fSetupFileXfer.Format := TWFF_EXIF;
fMemory.Flags := TWFF_EXIF;
end;
end;
end;
//---------------------------------------------------------------------
procedure TTWAIN.fSetFilename(fn: string);
var
L, I: Integer;
begin
FillChar(fSetupFileXfer.FileName, SizeOf(fSetupFileXfer.Filename), #0);
L := Length(fn);
if L > 0 then
for I := 1 to L do
fSetupFileXfer.Filename[I - 1] := fn[I];
end;
//---------------------------------------------------------------------
function TTWAIN.fGetFilename: string;
var
I: Integer;
begin
Result := '';
I := 0;
if fSetupFileXfer.Filename[I] <> #0 then
repeat
Result := Result + fSetupFileXfer.Filename[I];
Inc(I);
until fSetupFileXfer.Filename[I] = #0;
end;
//---------------------------------------------------------------------
function TTWAIN.fGetImageType: TImageType;
begin
Result := ffUNKNOWN; // Initialize
case fSetupFileXfer.Format of
TWFF_TIFF: Result := ffTIFF;
TWFF_PICT: Result := ffPICT;
TWFF_BMP: Result := ffBMP;
TWFF_XBM: Result := ffXBM;
TWFF_JFIF: Result := ffJFIF;
TWFF_FPX: Result := ffFPX;
TWFF_TIFFMULTI: Result := ffTIFFMULTI;
TWFF_PNG: Result := ffPNG;
TWFF_SPIFF: Result := ffSPIFF;
TWFF_EXIF: Result := ffEXIF;
end;
end;
//---------------------------------------------------------------------
procedure TTWAIN.fSetCursor(cr: TCursor);
begin
Screen.Cursor := cr;
end;
//---------------------------------------------------------------------
function TTWAIN.fGetCursor: TCursor;
begin
Result := Screen.Cursor;
end;
//---------------------------------------------------------------------
procedure TTWAIN.fSetCountry(ct: TCountryType);
begin
case ct of
ctDenmark: appID.Version.Country := TWCY_DENMARK;
ctNetherlands: appID.Version.Country := TWCY_NETHERLANDS;
ctEngland: appID.Version.Country := TWCY_BRITAIN;
ctFinland: appID.Version.Country := TWCY_FINLAND;
ctFrance: appID.Version.Country := TWCY_FRANCE;
ctGermany: appID.Version.Country := TWCY_GERMANY;
ctItaly: appID.Version.Country := TWCY_ITALY;
ctNorWay: appID.Version.Country := TWCY_NORWAY;
ctSpain: appID.Version.Country := TWCY_SPAIN;
ctUSA: appID.Version.Country := TWCY_USA;
ctRussia: appID.Version.Country := TWCY_RUSSIA;
ctPortugal: appID.Version.Country := TWCY_PORTUGAL;
ctSweden: appID.Version.Country := TWCY_SWEDEN;
ctPoland: appID.Version.Country := TWCY_POLAND;
ctGreece: appID.Version.Country := TWCY_GREECE;
ctTurkey: appID.Version.Country := TWCY_TURKEY;
end;
end;
//---------------------------------------------------------------------
function TTWAIN.fGetCountry: TCountryType;
begin
Result := ctNetherlands; // Initialize
case appID.Version.Country of
TWCY_NETHERLANDS: Result := ctNetherlands;
TWCY_DENMARK: Result := ctDenmark;
TWCY_BRITAIN: Result := ctEngland;
TWCY_FINLAND: Result := ctFinland;
TWCY_FRANCE: Result := ctFrance;
TWCY_GERMANY: Result := ctGermany;
TWCY_NORWAY: Result := ctNorway;
TWCY_ITALY: Result := ctItaly;
TWCY_SPAIN: Result := ctSpain;
TWCY_USA: Result := ctUSA;
TWCY_RUSSIA: Result := ctRussia;
TWCY_PORTUGAL: Result := ctPortugal;
TWCY_SWEDEN: Result := ctSweden;
TWCY_TURKEY: Result := ctTurkey;
TWCY_GREECE: Result := ctGreece;
TWCY_POLAND: Result := ctPoland;
end;
end;
//---------------------------------------------------------------------
procedure TTWAIN.fSetLanguage(lg: TLanguageType);
begin
case lg of
lgDanish: appID.Version.Language := TWLG_DAN;
lgDutch: appID.Version.Language := TWLG_DUT;
lgEnglish: appID.Version.Language := TWLG_ENG;
lgFinnish: appID.Version.Language := TWLG_FIN;
lgFrench: appID.Version.Language := TWLG_FRN;
lgGerman: appID.Version.Language := TWLG_GER;
lgNorwegian: appID.Version.Language := TWLG_NOR;
lgItalian: appID.Version.Language := TWLG_ITN;
lgSpanish: appID.Version.Language := TWLG_SPA;
lgAmerican: appID.Version.Language := TWLG_USA;
lgRussian: appID.Version.Language := TWLG_RUSSIAN;
lgPortuguese: appID.Version.Language := TWLG_POR;
lgSwedish: appID.Version.Language := TWLG_SWE;
lgPolish: appID.Version.Language := TWLG_POLISH;
lgGreek: appID.Version.Language := TWLG_GREEK;
lgTurkish: appID.Version.Language := TWLG_TURKISH;
end;
end;
//---------------------------------------------------------------------
function TTWAIN.fGetLanguage: TLanguageType;
begin
Result := lgDutch; // Initialize
case appID.Version.Language of
TWLG_DAN: Result := lgDanish;
TWLG_DUT: Result := lgDutch;
TWLG_ENG: Result := lgEnglish;
TWLG_FIN: Result := lgFinnish;
TWLG_FRN: Result := lgFrench;
TWLG_GER: Result := lgGerman;
TWLG_ITN: Result := lgItalian;
TWLG_NOR: Result := lgNorwegian;
TWLG_SPA: Result := lgSpanish;
TWLG_USA: Result := lgAmerican;
TWLG_RUSSIAN: Result := lgRussian;
TWLG_POR: Result := lgPortuguese;
TWLG_SWE: Result := lgSwedish;
TWLG_POLISH: Result := lgPolish;
TWLG_GREEK: Result := lgGreek;
TWLG_TURKISH: Result := lgTurkish;
end;
end;
//---------------------------------------------------------------------
procedure TTWAIN.fSetManufacturer(mf: string);
var
I, L: Integer;
begin
FillChar(appID.Manufacturer, SizeOf(appID.Manufacturer), #0);
L := Length(mf);
if L = 0 then
Exit;
if L > 32 then
L := 32;
for I := 1 to L do
appID.Manufacturer[I - 1] := mf[I];
end;
//---------------------------------------------------------------------
function TTWAIN.fGetManufacturer: string;
var
I: Integer;
begin
Result := '';
I := 0;
if appID.Manufacturer[I] <> #0 then
repeat
Result := Result + appID.Manufacturer[I];
Inc(I);
until appID.Manufacturer[I] = #0;
end;
//---------------------------------------------------------------------
procedure TTWAIN.fSetProductname(pn: string);
var
I, L: Integer;
begin
FillChar(appID.Productname, SizeOf(appID.Productname), #0);
L := Length(pn);
if L = 0 then
Exit;
if L > 32 then
L := 32;
for I := 1 to L do
appID.Productname[I - 1] := pn[I];
end;
//---------------------------------------------------------------------
function TTWAIN.fGetProductName: string;
var
I: Integer;
begin
Result := '';
I := 0;
if appID.ProductName[I] <> #0 then
repeat
Result := Result + appID.ProductName[I];
Inc(I);
until appID.ProductName[I] = #0;
end;
//---------------------------------------------------------------------
procedure TTWAIN.fSetProductFamily(pf: string);
var
I, L: Integer;
begin
FillChar(appID.ProductFamily, SizeOf(appID.ProductFamily), #0);
L := Length(pf);
if L = 0 then
Exit;
if L > 32 then
L := 32;
for I := 1 to L do
appID.ProductFamily[I - 1] := pf[I];
end;
//---------------------------------------------------------------------
function TTWAIN.fGetProductFamily: string;
var
I: Integer;
begin
Result := '';
I := 0;
if appID.ProductFamily[I] <> #0 then
repeat
Result := Result + appID.ProductFamily[I];
Inc(I);
until appID.ProductFamily[I] = #0;
end;
//---------------------------------------------------------------------
procedure TTWAIN.ScanReady;
begin
if Assigned(fScanReady) then
fScanReady(Self);
end;
//---------------------------------------------------------------------
procedure TTWAIN.fSetDestination(dest: TTransferType);
begin
fXfer := dest;
end;
//---------------------------------------------------------------------
function TTWAIN.fGetDestination: TTransferType;
begin
Result := fXfer;
end;
//----------------------------------------------------------------------
function UpCaseStr(const s: string): string;
var
I, L: Integer;
begin
Result := s;
L := Length(Result);
if L > 0 then
begin
for I := 1 to L do
Result[I] := UpCase(Result[I]);
end;
// Result := s; // Minor bug, changed 23/05/03
end;
//----------------------------------------------------------------------
// Internal routine
//----------------------------------------------------------------------
function GetWinDir: string;
var
WD: array[0..MAX_PATH] of Char;
L: WORD;
begin
WD := #0;
GetWindowsDirectory(WD, MAX_PATH);
Result := StrPas(WD);
L := Length(Result);
// Remove the "\" if any
if L > 0 then
if Result[L] = '\' then
Result := Copy(Result, 1, L - 1);
end;
//----------------------------------------------------------------------
// Internal routine
//----------------------------------------------------------------------
procedure FileFindSubDir(const ffsPath: string;
var ffsBo: Boolean);
var
sr: TSearchRec;
begin
if FindFirst(ffsPath + '\*.*', faAnyFile, sr) = 0 then
repeat
if sr.Name <> '.' then
if sr.Name <> '..' then
if sr.Attr and faDirectory = faDirectory then
begin
FileFindSubDir(ffsPath + '\' + sr.name, ffsBo);
end
else
begin
if UpCaseStr(ExtractFileExt(sr.Name)) = '.DS' then
if UpCaseStr(sr.Name) <> 'WIATWAIN.DS' then
ffsBo := True;
end;
until FindNext(sr) <> 0;
// Error if SysUtils is not added in front of FindClose!
SysUtils.FindClose(sr);
end;
//----------------------------------------------------------------------
function TTWAIN.IsTwainDriverAvailable: Boolean;
var
sr: TSearchRec;
s: string;
Bo: Boolean;
begin
// This routine might not be failsafe!
// Under circumstances the twain drivers found in the directory
// %WINDOWS%\TWAIN_32\*.ds and below could be not properly installed!
Bo := False;
s := GetWinDir + '\TWAIN_32';
FileFindSubDir(s, Bo);
Result := Bo;
end;
//---------------------------------------------------------------------
procedure TTWAIN.SaveDefaultSourceEntry;
var
WinIni: TIniFile;
begin
if sDefaultSource <> '' then
Exit;
WinIni := TIniFile.Create(Ini_File_Name);
sDefaultSource := WinIni.ReadString('TWAIN', 'DEFAULT SOURCE', '');
WinIni.Free;
end;
//---------------------------------------------------------------------
procedure TTWAIN.RestoreDefaultSourceEntry;
var
WinIni: TIniFile;
begin
if sDefaultSource = '' then
Exit; // It is not changed by this component or it is not there...
WinIni := TIniFile.Create(Ini_File_Name);
WinIni.WriteString('TWAIN', 'DEFAULT SOURCE', sDefaultSource);
WinIni.Free;
sDefaultSource := '';
end;
//---------------------------------------------------------------------
procedure TTWAIN.InitTWAIN;
begin
appID.ID := Application.Handle;
fHwnd := Application.Handle;
fLoadTwain; // Load TWAIN_32.DLL
fOldOnMessageHandler := Application.OnMessage; // Save old pointer
Application.OnMessage := fNewOnMessageHandler; // Set to our handler
OpenDataSourceManager; // Open DS
end;
//---------------------------------------------------------------------
function TTWAIN.fLoadTwain: Boolean;
begin
if HDSMDLL = 0 then
begin
HDSMDLL := LoadLibrary(TWAIN_DLL_Name);
DSM_Entry := GetProcAddress(HDSMDLL, DSM_Entry_Name);
// if @DSM_Entry = nil then
// raise ETwainError.Create(SErrDSMEntryNotFound);
end;
Result := (HDSMDLL <> 0);
end;
//---------------------------------------------------------------------
procedure TTWAIN.fUnloadTwain;
begin
if HDSMDLL <> 0 then
begin
DSM_Entry := nil;
FreeLibrary(HDSMDLL);
HDSMDLL := 0;
end;
end;
//---------------------------------------------------------------------
function TTWAIN.Condition2String(ConditionCode: TW_UINT16): string;
begin
// Texts copied from PDF Documentation: Rework needed
case ConditionCode of
TWCC_BADCAP: Result :=
'Capability not supported by source or operation (get,' + CrLf +
'set) is not supported on capability, or capability had' + CrLf +
'dependencies on other capabilities and cannot be' + CrLf +
'operated upon at this time';
TWCC_BADDEST: Result := 'Unknown destination in DSM_Entry.';
TWCC_BADPROTOCOL: Result := 'Unrecognized operation triplet.';
TWCC_BADVALUE: Result :=
'Data parameter out of supported range.';
TWCC_BUMMER: Result :=
'General failure. Unload Source immediately.';
TWCC_CAPUNSUPPORTED: Result := 'Capability not supported by ' +
'Data Source.';
TWCC_CAPBADOPERATION: Result := 'Operation not supported on ' +
'capability.';
TWCC_CAPSEQERROR: Result :=
'Capability has dependencies on other capabilities and ' + CrLf +
'cannot be operated upon at this time.';
TWCC_DENIED: Result :=
'File System operation is denied (file is protected).';
TWCC_PAPERDOUBLEFEED,
TWCC_PAPERJAM: Result :=
'Transfer failed because of a feeder error';
TWCC_FILEEXISTS: Result :=
'Operation failed because file already exists.';
TWCC_FILENOTFOUND: Result := 'File not found.';
TWCC_LOWMEMORY: Result :=
'Not enough memory to complete the operation.';
TWCC_MAXCONNECTIONS: Result :=
'Data Source is connected to maximum supported number of ' +
CrLf + 'applications.';
TWCC_NODS: Result :=
'Data Source Manager was unable to find the specified Data ' +
'Source.';
TWCC_NOTEMPTY: Result :=
'Operation failed because directory is not empty.';
TWCC_OPERATIONERROR: Result :=
'Data Source or Data Source Manager reported an error to the' +
CrLf + 'user and handled the error. No application action ' +
'required.';
TWCC_SEQERROR: Result :=
'Illegal operation for current Data Source Manager' + CrLf +
'and Data Source state.';
TWCC_SUCCESS: Result := 'Operation was succesful.';
else
Result := Format('Unknown condition %.04x', [ConditionCode]);
end;
end;
///////////////////////////////////////////////////////////////////////
// RaiseLastDSMCondition (idea: like RaiseLastWin32Error) //
// Tries to get the status from the DSM and raises an exception //
// with it. //
///////////////////////////////////////////////////////////////////////
procedure TTWAIN.RaiseLastDataSourceManagerCondition(module: string);
var
status: TW_STATUS;
begin
Assert(@DSM_Entry <> nil);
if DSM_Entry(@appId, nil, DG_CONTROL, DAT_STATUS, MSG_GET, @status) <>
TWRC_SUCCESS then
raise ETwainError.Create(ERR_STATUS)
else
raise ETwainError.CreateFmt(ERR_DSM, [module,
Condition2String(status.ConditionCode)]);
end;
///////////////////////////////////////////////////////////////////////
// RaiseLastDSCondition //
// same again, but for the actual DS //
// (should be a method of DS) //
///////////////////////////////////////////////////////////////////////
procedure TTWAIN.RaiseLastDataSourceCondition(module: string);
var
status: TW_STATUS;
begin
Assert(@DSM_Entry <> nil);
if DSM_Entry(@appId, @dsID, DG_CONTROL, DAT_STATUS, MSG_GET, @status) <>
TWRC_SUCCESS then
raise ETwainError.Create(ERR_STATUS)
else
raise ETwainError.CreateFmt(ERR_DSM, [module,
Condition2String(status.ConditionCode)]);
end;
///////////////////////////////////////////////////////////////////////
// TwainCheckDSM (idea: like Win32Check or GDICheck in Graphics.pas) //
///////////////////////////////////////////////////////////////////////
procedure TTWAIN.TwainCheckDataSourceManager(res: TW_UINT16;
module: string);
begin
if res <> TWRC_SUCCESS then
begin
if res = TWRC_FAILURE then
RaiseLastDataSourceManagerCondition(module)
else
raise ETwainError.CreateFmt(ERR_UNKNOWN, [module, res]);
end;
end;
///////////////////////////////////////////////////////////////////////
// TwainCheckDS //
// same again, but for the actual DS //
// (should be a method of DS) //
///////////////////////////////////////////////////////////////////////
procedure TTWAIN.TwainCheckDataSource(res: TW_UINT16;
module: string);
begin
if res <> TWRC_SUCCESS then
begin
if res = TWRC_FAILURE then
RaiseLastDataSourceCondition(module)
else
raise ETwainError.CreateFmt(ERR_UNKNOWN, [module, res]);
end;
end;
///////////////////////////////////////////////////////////////////////
// CallDSMEntry: //
// Short form for DSM Calls: appId is not needed as parameter //
///////////////////////////////////////////////////////////////////////
function TTWAIN.CallDataSourceManager(pOrigin: pTW_IDENTITY;
DG: TW_UINT32;
DAT: TW_UINT16;
MSG: TW_UINT16;
pData: TW_MEMREF): TW_UINT16;
begin
Assert(@DSM_Entry <> nil);
Result := DSM_Entry(@appID,
pOrigin,
DG,
DAT,
MSG,
pData);
if (Result <> TWRC_SUCCESS) and (DAT <> DAT_EVENT) then
begin
end;
end;
///////////////////////////////////////////////////////////////////////
// Short form for (actual) DS Calls. appId and dsID are not needed //
// (this should be a DS class method) //
///////////////////////////////////////////////////////////////////////
function TTWAIN.CallDataSource(DG: TW_UINT32;
DAT: TW_UINT16;
MSG: TW_UINT16;
pData: TW_MEMREF): TW_UINT16;
begin
Assert(@DSM_Entry <> nil);
Result := DSM_Entry(@appID,
@dsID,
DG,
DAT,
MSG,
pData);
end;
///////////////////////////////////////////////////////////////////////
// A lot of the following code is a conversion from the //
// twain example program (and some comments are copied, too) //
// (The error handling is done differently) //
// Most functions should be moved to a DSM or DS class //
///////////////////////////////////////////////////////////////////////
procedure TTWAIN.OpenDataSourceManager;
begin
if not bDataSourceManagerOpen then
begin
Assert(appID.ID <> 0);
if not fLoadTwain then
raise ETwainError.Create(ERR_TWAIN_NOT_LOADED);
// appID.Id := fhWnd;
// appID.Version.MajorNum := 1;
// appID.Version.MinorNum := 0;
// appID.Version.Language := TWLG_USA;
// appID.Version.Country := TWCY_USA;
// appID.Version.Info := 'Twain Component';
appID.ProtocolMajor := 1; // TWON_PROTOCOLMAJOR;
appID.ProtocolMinor := 7; // TWON_PROTOCOLMINOR;
appID.SupportedGroups := DG_IMAGE or DG_CONTROL;
// appID.Productname := 'HP ScanJet 5p';
// appId.ProductFamily := 'ScanJet';
// appId.Manufacturer := 'Hewlett-Packard';
TwainCheckDataSourceManager(CallDataSourceManager(nil,
DG_CONTROL,
DAT_PARENT,
MSG_OPENDSM,
@fhWnd),
'OpenDataSourceManager');
bDataSourceManagerOpen := True;
end;
end;
//---------------------------------------------------------------------
procedure TTWAIN.CloseDataSourceManager;
begin
if bDataSourceOpen then
raise ETwainError.Create(ERR_DSM_OPEN);
if bDataSourceManagerOpen then
begin
// This call performs one important function:
// - tells the SM which application, appID.id, is requesting SM to
// close
// - be sure to test return code, failure indicates SM did not
// close !!
TwainCheckDataSourceManager(CallDataSourceManager(nil,
DG_CONTROL,
DAT_PARENT,
MSG_CLOSEDSM,
@fhWnd),
'CloseDataSourceManager');
bDataSourceManagerOpen := False;
end;
fUnLoadTwain; // Loose the DLL
if sDefaultSource <> '' then
RestoreDefaultSourceEntry;
end;
//---------------------------------------------------------------------
function TTWAIN.IsDataSourceManagerOpen: Boolean;
begin
Result := bDataSourceManagerOpen;
end;
//---------------------------------------------------------------------
procedure TTWAIN.OpenDataSource;
begin
Assert(bDataSourceManagerOpen, 'Data Source Manager must be open');
if not bDataSourceOpen then
begin
TwainCheckDataSourceManager(CallDataSourceManager(nil,
DG_CONTROL,
DAT_IDENTITY,
MSG_OPENDS,
@dsID),
'OpenDataSource');
bDataSourceOpen := True;
end;
end;
//---------------------------------------------------------------------
procedure TTWAIN.CloseDataSource;
begin
Assert(bDataSourceManagerOpen, 'Data Source Manager must be open');
if bDataSourceOpen then
begin
TwainCheckDataSourceManager(CallDataSourceManager(nil,
DG_CONTROL,
DAT_IDENTITY,
MSG_CLOSEDS,
@dsID),
'CloseDataSource');
bDataSourceOpen := False;
end;
end;
//---------------------------------------------------------------------
procedure TTWAIN.EnableDataSource;
var
twUI: TW_USERINTERFACE;
begin
Assert(bDataSourceOpen, 'Data Source must be open');
if not bDataSourceEnabled then
begin
FillChar(twUI, SizeOf(twUI), #0);
twUI.hParent := fhWnd;
twUI.ShowUI := fShowUI;
twUI.ModalUI := True;
TwainCheckDataSourceManager(CallDataSourceManager(@dsID,
DG_CONTROL,
DAT_USERINTERFACE,
MSG_ENABLEDS,
@twUI),
'EnableDataSource');
bDataSourceEnabled := True;
end;
end;
//---------------------------------------------------------------------
procedure TTWAIN.DisableDataSource;
var
twUI: TW_USERINTERFACE;
begin
Assert(bDataSourceOpen, 'Data Source must be open');
if bDataSourceEnabled then
begin
twUI.hParent := fhWnd;
twUI.ShowUI := TW_BOOL(TWON_DONTCARE8); (*!!!!*)
TwainCheckDataSourceManager(CallDataSourceManager(@dsID,
DG_CONTROL,
DAT_USERINTERFACE,
MSG_DISABLEDS,
@twUI),
'DisableDataSource');
bDataSourceEnabled := False;
end;
end;
//---------------------------------------------------------------------
function TTWAIN.IsDataSourceOpen: Boolean;
begin
Result := bDataSourceOpen;
end;
//---------------------------------------------------------------------
function TTWAIN.IsDataSourceEnabled: Boolean;
begin
Result := bDataSourceEnabled;
end;
//---------------------------------------------------------------------
procedure TTWAIN.SelectDataSource;
var
NewDSIdentity: TW_IDENTITY;
twRC: TW_UINT16;
begin
SaveDefaultSourceEntry;
Assert(not bDataSourceOpen, 'Data Source must be closed');
TwainCheckDataSourceManager(CallDataSourceManager(nil,
DG_CONTROL,
DAT_IDENTITY,
MSG_GETDEFAULT,
@NewDSIdentity),
'SelectDataSource1');
twRC := CallDataSourceManager(nil,
DG_CONTROL,
DAT_IDENTITY,
MSG_USERSELECT,
@NewDSIdentity);
case twRC of
TWRC_SUCCESS: dsID := NewDSIdentity; // log in new Source
TWRC_CANCEL: ; // keep the current Source
else
TwainCheckDataSourceManager(twRC, 'SelectDataSource2');
end;
end;
(*******************************************************************
Functions from CAPTEST.C
*******************************************************************)
procedure TTWAIN.XferMech;
var
cap: TW_CAPABILITY;
pVal: pTW_ONEVALUE;
begin
fXfer := xfNative; // Override
cap.Cap := ICAP_XFERMECH;
cap.ConType := TWON_ONEVALUE;
cap.hContainer := GlobalAlloc(GHND, SizeOf(TW_ONEVALUE));
Assert(cap.hContainer <> 0);
try
pval := pTW_ONEVALUE(GlobalLock(cap.hContainer));
Assert(pval <> nil);
try
pval.ItemType := TWTY_UINT16;
case fXfer of
xfMemory: pval.Item := TWSX_MEMORY;
xfFile: pval.Item := TWSX_FILE;
xfNative: pval.Item := TWSX_NATIVE;
end;
finally
GlobalUnlock(cap.hContainer);
end;
TwainCheckDataSource(CallDataSource(DG_CONTROL,
DAT_CAPABILITY,
MSG_SET,
@cap),
'XferMech');
finally
GlobalFree(cap.hContainer);
end;
end;
///////////////////////////////////////////////////////////////////////
function TTWAIN.ProcessSourceMessage(var Msg: TMsg): Boolean;
var
twRC: TW_UINT16;
event: TW_EVENT;
pending: TW_PENDINGXFERS;
begin
Result := False;
if bDataSourceManagerOpen and bDataSourceOpen then
begin
event.pEvent := @Msg;
event.TWMessage := 0;
twRC := CallDataSource(DG_CONTROL,
DAT_EVENT,
MSG_PROCESSEVENT,
@event);
case event.TWMessage of
MSG_XFERREADY:
begin
case fXfer of
xfNative: fNativeXfer;
xfMemory: fMemoryXfer;
xfFile: fFileXfer;
end;
TwainCheckDataSource(CallDataSource(DG_CONTROL,
DAT_PENDINGXFERS,
MSG_ENDXFER,
@pending),
'Check for Pending Transfers');
if pending.Count > 0 then
TwainCheckDataSource(CallDataSource(
DG_CONTROL,
DAT_PENDINGXFERS,
MSG_RESET,
@pending),
'Abort Pending Transfers');
DisableDataSource;
CloseDataSource;
ScanReady; // Event
end;
MSG_CLOSEDSOK,
MSG_CLOSEDSREQ:
begin
DisableDataSource;
CloseDataSource;
ScanReady // Event
end;
end;
Result := not (twRC = TWRC_NOTDSEVENT);
end;
end;
//---------------------------------------------------------------------
procedure TTWAIN.Acquire(aBmp: TBitmap);
begin
// fOldOnMessageHandler := Application.OnMessage; // Save old pointer
// Application.OnMessage := fNewOnMessageHandler; // Set to our handler
// OpenDataSourceManager; // Open DS
fBitmap := aBmp;
OpenDataSourceManager;
OpenDataSource;
XferMech; // Must be written for xfMemory and xfFile
EnableDataSource;
end;
//---------------------------------------------------------------------
// Must be written!
function TTWAIN.fMemoryXfer: Boolean;
var
twRC: TW_UINT16;
begin
Result := False;
twRC := CallDataSource(DG_IMAGE,
DAT_IMAGEMEMXFER,
MSG_GET,
nil);
case twRC of
TWRC_XFERDONE: Result := True;
TWRC_CANCEL: ;
TWRC_FAILURE: ;
end;
end;
//---------------------------------------------------------------------
// Must be written!
function TTWAIN.fFileXfer: Boolean;
var
twRC: TW_UINT16;
begin
// Not yet implemented!
Result := False;
twRC := CallDataSource(DG_IMAGE,
DAT_IMAGEFILEXFER,
MSG_GET,
nil);
case twRC of
TWRC_XFERDONE: Result := True;
TWRC_CANCEL: ;
TWRC_FAILURE: ;
end;
end;
//---------------------------------------------------------------------
function TTWAIN.fNativeXfer: Boolean;
// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
function DibNumColors(dib: Pointer): Integer;
var
lpbi: PBITMAPINFOHEADER;
lpbc: PBITMAPCOREHEADER;
bits: Integer;
begin
lpbi := dib;
lpbc := dib;
if lpbi.biSize <> SizeOf(BITMAPCOREHEADER) then
begin
if lpbi.biClrUsed <> 0 then
begin
Result := lpbi.biClrUsed;
Exit;
end;
bits := lpbi.biBitCount;
end
else
bits := lpbc.bcBitCount;
case bits of
1: Result := 2;
4: Result := 16; // 4?
8: Result := 256; // 8?
else
Result := 0;
end;
end;
// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
var
twRC: TW_UINT16;
hDIB: TW_UINT32;
hBmp: HBITMAP;
lpDib: ^TBITMAPINFO;
lpBits: PChar;
ColorTableSize: Integer;
dc: HDC;
begin
Result := False;
twRC := CallDataSource(DG_IMAGE, DAT_IMAGENATIVEXFER, MSG_GET, @hDIB);
case twRC of
TWRC_XFERDONE:
begin
lpDib := GlobalLock(hDIB);
try
ColorTableSize := (DibNumColors(lpDib) *
SizeOf(RGBQUAD));
lpBits := PChar(lpDib);
Inc(lpBits, lpDib.bmiHeader.biSize);
Inc(lpBits, ColorTableSize);
dc := GetDC(0);
try
hBMP := CreateDIBitmap(dc, lpdib.bmiHeader,
CBM_INIT, lpBits, lpDib^, DIB_RGB_COLORS);
fBitmap.Handle := hBMP;
Result := True;
finally
ReleaseDC(0, dc);
end;
finally
GlobalUnlock(hDIB);
GlobalFree(hDIB);
end;
end;
TWRC_CANCEL: ;
TWRC_FAILURE: RaiseLastDataSourceManagerCondition('Native Transfer');
end;
end;
//---------------------------------------------------------------------
procedure TTWAIN.fNewOnMessageHandler(var Msg: TMsg;
var Handled: Boolean);
begin
Handled := ProcessSourceMessage(Msg);
if Assigned(fOldOnMessageHandler) then
fOldOnMessageHandler(Msg, Handled)
end;
Взято с
Delphi Knowledge BaseКак работать со всеми фреймами, отображёнными в данный момент в WebBrowser?
Как работать со всеми фреймами, отображёнными в данный момент в WebBrowser?
Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm
Данный пример показывает как определить в каких фреймах разрешена команда 'copy':
procedure TForm1.Button1Click(Sender: TObject);
var
i: integer;
begin
for i := 0 to (WebBrowser1.OleObject.Document.frames.Length - 1) do
if WebBrowser1.OleObject.Document.frames.item(i).document.queryCommandEnabled('Copy') then
ShowMessage('copy command is enabled for frame no.' + IntToStr(i));
end;
Автор: Peter Friese
Как работать со всеми ячейками < TABLE> ?
Как работать со всеми ячейками < TABLE> ?
Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm
Пример показывает как добавить содержимое каждой ячейки в TMemo:
procedure TForm1.Button1Click(Sender: TObject);
var
i, j: integer;
ovTable: OleVariant;
begin
// Я использовал первую таблицу на странице в ка?естве примера
ovTable := WebBrowser1.OleObject.Document.all.tags('TABLE').item(0); for i := 0 to (ovTable.Rows.Length - 1) do
begin
for j := 0 to (ovTable.Rows.Item(i).Cells.Length - 1) do
begin
Memo1.Lines.Add(ovTable.Rows.Item(i).Cells.Item(j).InnerText;
end;
end;
end;
Как распечатать bitmap?
Как распечатать bitmap?
procedureStretchPrint(R: TRect; ABitmap: Graphics.TBitmap);
var
dc: HDC;
isDcPalDevice: Bool;
hDibHeader: THandle;
pDibHeader: pointer;
hBits: THandle;
pBits: pointer;
ppal: PLOGPALETTE;
pal: hPalette;
Oldpal: hPalette;
i: integer;
begin
pal := 0;
OldPal := 0;
{Get the screen dc}
dc := GetDc(0);
{Allocate memory for a DIB structure}
hDibHeader := GlobalAlloc(GHND, sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256));
{get a pointer to the alloced memory}
pDibHeader := GlobalLock(hDibHeader);
{fill in the dib structure with info on the way we want the DIB}
FillChar(pDibHeader^, sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256), #0);
PBITMAPINFOHEADER(pDibHeader)^.biSize := sizeof(TBITMAPINFOHEADER);
PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
PBITMAPINFOHEADER(pDibHeader)^.biWidth := ABitmap.width;
PBITMAPINFOHEADER(pDibHeader)^.biHeight := ABitmap.height;
PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
{find out how much memory for the bits}
GetDIBits(dc, ABitmap.Handle, 0, ABitmap.height, nil, TBitmapInfo(pDibHeader^),
DIB_RGB_COLORS);
{Alloc memory for the bits}
hBits := GlobalAlloc(GHND, PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
{Get a pointer to the bits}
pBits := GlobalLock(hBits);
{Call fn again, but this time give us the bits!}
GetDIBits(dc, ABitmap.Handle, 0, ABitmap.height, pBits, PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS);
{Release the screen dc}
ReleaseDc(0, dc);
{Just incase the printer drver is a palette device}
isDcPalDevice := false;
if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and RC_PALETTE = RC_PALETTE then
begin
{Create palette from dib}
GetMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
FillChar(pPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
pPal^.palVersion := $300;
pPal^.palNumEntries := 256;
for i := 0 to (pPal^.PalNumEntries - 1) do
begin
pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
pPal^.palPalEntry[i].peGreen := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
end;
pal := CreatePalette(pPal^);
FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
oldPal := SelectPalette(Printer.Canvas.Handle, Pal, false);
isDcPalDevice := true
end;
{send the bits to the printer}
StretchDiBits(Printer.Canvas.Handle, R.Left, R.Top, R.Right - R.Left,
R.Bottom - R.Top, 0, 0, ABitmap.Width, ABitmap.Height, pBits,
PBitmapInfo(pDibHeader)^, DIB_RGB_COLORS, SRCCOPY);
{Just incase you printer drver is a palette device}
if isDcPalDevice = true then
begin
SelectPalette(Printer.Canvas.Handle, oldPal, false);
DeleteObject(Pal);
end;
{Clean up allocated memory}
GlobalUnlock(hBits);
GlobalFree(hBits);
GlobalUnlock(hDibHeader);
GlobalFree(hDibHeader);
end;
Взято с
Delphi Knowledge BaseКак распечатать Excel файл?
Как распечатать Excel файл?
{
This is a simple example how to print an Excel file using OLE.
}
uses
ComObj;
procedure TForm1.Button1Click(Sender: TObject);
var
ExcelApp: OLEVariant;
begin
// Create an Excel instance
// Excel Instanz erzeugen
ExcelApp := CreateOleObject('Excel.Application');
try
ExcelApp.Workbooks.Open('C:\test\xyz.xls');
// you can also modify some settings from PageSetup
// Man kann auch noch einige Einstellungen von "Seite Einrichten" anpassen
ExcelApp.ActiveSheet.PageSetup.Orientation := xlLandscape;
// Print it out
// Ausdrucken
ExcelApp.Worksheets.PrintOut;
finally
// Close Excel
// Excel wieder schliessen
if not VarIsEmpty(ExcelApp) then
begin
ExcelApp.Quit;
ExcelApp := Unassigned;
end;
end;
end;
Взято с сайта
Как распечатать PRN file?
Как распечатать PRN file?
uses
Printers, Winspool;
function SpoolFile(const FileName, PrinterName: string): Integer;
var
Buffer: record
JobInfo: record // ADDJOB_INFO_1
Path: PChar;
JobID: DWORD;
end;
PathBuffer: array[0..255] of Char;
end;
SizeNeeded: DWORD;
Handle: THandle;
PrtName: string;
ok: Boolean;
begin
// Flush job to printer
PrtName := PrinterName;
if PrtName = '' then
PrtName := Printer.Printers[Printer.PrinterIndex]; // Default printer name
ok := False;
if OpenPrinter(PChar(PrtName), Handle, nil) then
if AddJob(Handle, 1, @Buffer, SizeOf(Buffer), SizeNeeded) then
if CopyFile(PChar(FileName), Buffer.JobInfo.Path, True) then
if ScheduleJob(Handle, Buffer.JobInfo.JobID) then
ok := True;
if not ok then Result := GetLastError
else
Result := 0;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if SpoolFile('c:\test.prn', Printer.Printers[0]) = 0 then
ShowMessage('No error...');
end;
Взято с сайта
Как распечатать TImage?
Как распечатать TImage?
uses
Printers;
procedure TForm1.Button1Click(Sender: TObject);
var
ScaleX, ScaleY: Integer;
RR: TRect;
begin
with Printer do
begin
BeginDoc;
// Mit BeginDoc wird ein Druckauftrag initiiert.
// The StartDoc function starts a print job.
try
ScaleX := GetDeviceCaps(Handle, logPixelsX) div PixelsPerInch;
ScaleY := GetDeviceCaps(Handle, logPixelsY) div PixelsPerInch;
// Informationen uber die Auflosung
// Retrieves information about the Pixels per Inch of the Printer.
RR := Rect(0, 0, Image1.picture.Width * scaleX, Image1.Picture.Height * ScaleY);
Canvas.StretchDraw(RR, Image1.Picture.Graphic);
// An die Auflosung anpassen
// Stretch to fit
finally
EndDoc; //Methode EndDoc beendet den aktuellen Druckauftrag und schlie?t die
// Textdatei-Variable.
// Steht in finally - um auch bei Abbruch des Druckauftrages Papierausgabe
// sicherzustellen
end;
end;
end;
// Based on posting to borland.public.delphi.winapi by Rodney E Geraghty, 8/8/97.
procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap);
var
BitmapHeader: pBitmapInfo;
BitmapImage: Pointer;
HeaderSize: DWORD;
ImageSize: DWORD;
begin
GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize);
GetMem(BitmapHeader, HeaderSize);
GetMem(BitmapImage, ImageSize);
try
GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^);
StretchDIBits(Canvas.Handle,
DestRect.Left, DestRect.Top, // Destination Origin
DestRect.Right - DestRect.Left, // Destination Width
DestRect.Bottom - DestRect.Top, // Destination Height
0, 0, // Source Origin
Bitmap.Width, Bitmap.Height, // Source Width & Height
BitmapImage,
TBitmapInfo(BitmapHeader^),
DIB_RGB_COLORS,
SRCCOPY)
finally
FreeMem(BitmapHeader);
FreeMem(BitmapImage)
end
end {PrintBitmap};
// from www.experts-exchange.com
uses
printers;
procedure DrawImage(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);
var
Header, Bits: Pointer;
HeaderSize: DWORD;
BitsSize: DWORD;
begin
GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);
Header := AllocMem(HeaderSize);
Bits := AllocMem(BitsSize);
try
GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);
StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top,
DestRect.Right, DestRect.Bottom,
0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^),
DIB_RGB_COLORS, SRCCOPY);
finally
FreeMem(Header, HeaderSize);
FreeMem(Bits, BitsSize);
end;
end;
procedure PrintImage(Image: TImage; ZoomPercent: Integer);
// if ZoomPercent=100, Image will be printed across the whole page
var
relHeight, relWidth: integer;
begin
Screen.Cursor := crHourglass;
Printer.BeginDoc;
with Image.Picture.Bitmap do
begin
if ((Width / Height) > (Printer.PageWidth / Printer.PageHeight)) then
begin
// Stretch Bitmap to width of PrinterPage
relWidth := Printer.PageWidth;
relHeight := MulDiv(Height, Printer.PageWidth, Width);
end
else
begin
// Stretch Bitmap to height of PrinterPage
relWidth := MulDiv(Width, Printer.PageHeight, Height);
relHeight := Printer.PageHeight;
end;
relWidth := Round(relWidth * ZoomPercent / 100);
relHeight := Round(relHeight * ZoomPercent / 100);
DrawImage(Printer.Canvas, Rect(0, 0, relWidth, relHeight), Image.Picture.Bitmap);
end;
Printer.EndDoc;
Screen.cursor := crDefault;
end;
// Example Call:
procedure TForm1.Button1Click(Sender: TObject);
begin
// Print image at 40% zoom:
PrintImage(Image1, 40);
end;
Взято с сайта
Как распечатать TStringGrid?
Как распечатать TStringGrid?
uses
Printers;
procedure PrintGrid(sGrid: TStringGrid; sTitle: string);
var
X1, X2: Integer;
Y1, Y2: Integer;
TmpI: Integer;
F: Integer;
TR: TRect;
begin
Printer.Title := sTitle;
Printer.BeginDoc;
Printer.Canvas.Pen.Color := 0;
Printer.Canvas.Font.Name := 'Times New Roman';
Printer.Canvas.Font.Size := 12;
Printer.Canvas.Font.Style := [fsBold, fsUnderline];
Printer.Canvas.TextOut(0, 100, Printer.Title);
for F := 1 to sGrid.ColCount - 1 do
begin
X1 := 0;
for TmpI := 1 to (F - 1) do
X1 := X1 + 5 * (sGrid.ColWidths[TmpI]);
Y1 := 300;
X2 := 0;
for TmpI := 1 to F do
X2 := X2 + 5 * (sGrid.ColWidths[TmpI]);
Y2 := 450;
TR := Rect(X1, Y1, X2 - 30, Y2);
Printer.Canvas.Font.Style := [fsBold];
Printer.Canvas.Font.Size := 7;
Printer.Canvas.TextRect(TR, X1 + 50, 350, sGrid.Cells[F, 0]);
Printer.Canvas.Font.Style := [];
for TmpI := 1 to sGrid.RowCount - 1 do
begin
Y1 := 150 * TmpI + 300;
Y2 := 150 * (TmpI + 1) + 300;
TR := Rect(X1, Y1, X2 - 30, Y2);
Printer.Canvas.TextRect(TR, X1 + 50, Y1 + 50, sGrid.Cells[F, TmpI]);
end;
end;
Printer.EndDoc;
end;
//Examplem, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
PrintGrid(StringGrid1, 'Print Stringgrid');
end;
Взято с сайта
Как распечатать WEB страничку при помощи HTML контрола?
Как распечатать WEB страничку при помощи HTML контрола?
Можно использовать два метода HTML контрола: AutoPrint или PrintPage.
Пример использования AutoPrint:
--------------------------------------------------------------------------------
Как распечатать WEB страничку при помощи HTML контрола
Можно использовать два метода HTML контрола: AutoPrint или PrintPage.
Пример использования AutoPrint:
uses Printers;
procedure TForm1.Button1Click(Sender: TObject);
var
OldCur: TCursor;
begin
OldCur := Screen.Cursor;
with Printer do begin
BeginDoc;
HTML1.AutoPrint(handle);
Title := HTML1.URL;
EndDoc;
end;
Screen.Cursor := OldCur;
end;
Взято с Исходников.ru
Как расшарить диск?
Как расшарить диск?
Автор: Repairman
Это модуль для Share любого диска или папки как на локальном, так и на удаленном компьютере (если, конечно у Вас права администратора и на компе разрешено удаленное администрирование, для локальной машины это не обязательно... ;-))
Следует отметить, что под NT некоторые процедуры находятся в других DLL...
Функция SetShareOnDisk - ставит шару, RemoveShareFromDisk - снимает ее.
unit Share;
//(c)2002 <Repairman> repairman@uzel.ru
interface
type
TPassw = string[8];
TNetName = string[12];
function SetShareOnDisk(HostName: string; //имя компьютера
LocalPath: string; //папка которую надо открыть для доступа
NetName: TNetName; //имя расшаренной папки в сети
Remark: string; //комментарий, видимый в сети
Access: word; //доступ
RO_Passw: TPassw; //пароль на чтение
RW_Passw: TPassw //пароль на полный доступ
): boolean;
function RemoveShareFromDisk(HostName: string; //имя компьютера
NetName: string; //сетевое имя папки которую надо закрыть
LocalPath: string //локальный путь папки
): boolean;
var
ShareResult: word;
//-------------------------------------------------------------------------------------------
implementation
uses SysUtils, Windows, ShlObj;
function NetShareAdd(ServerName: PChar; //указатель на имя компьютера, например '\\Server'#0, если свой, то можно nil
Level: Word; //уровень структуры Share_info, здесь 50
PShareInfo: PChar; //указатель на структуру Share_Info
ParmErr: DWord) //указатель на ???
: dword; stdcall; external 'svrapi.dll'; //svrapi для Win9X, NetApi32 для NT
function NetShareDel(ServerName: PChar;
NetName: PChar;
Reserved: DWord): dword; stdcall; external 'svrapi.dll';
type
_share_info_50 = record //структура Share уровня 50
NetName: array[1..13] of char; //Как будет называться диск в сети
SType: byte; //тип =0 (STYPE_DISKTREE) - шарить диски
Flags: word; //флаги $0191,$0192,$0193....(доступ из сети)
Remark: PChar; //указатель на комментарий, видимый из сети
Path: PChar; //указатель на имя ресурса, например 'c:\'#0
RW_Password: array[1..9] of char; //пароль для полного доступа, если не нужен =#0
RO_Password: array[1..9] of char; //пароль для доступа на чтение, если не нужен =#0
end;
//----------------------------
function SetShareOnDisk(HostName, LocalPath: string; NetName: TNetName; Remark: string;
Access: word; RO_Passw, RW_Passw: TPassw): boolean;
var ShareInfo: _Share_Info_50;
begin
Result := false;
StrPCopy(@ShareInfo.NetName, NetName);
ShareInfo.SType := 0;
ShareInfo.Flags := Access;
ShareInfo.Remark := PChar(Remark);
ShareInfo.Path := PChar(LocalPath);
StrPCopy(@ShareInfo.RO_Password, RO_Passw);
StrPCopy(@ShareInfo.RW_Password, RW_Passw);
ShareResult := NetShareAdd(PChar(HostName), 50, @ShareInfo, $0000002A); //вызываем Share
if ShareResult <> 0 then Exit; //расшарить неудалось
SHChangeNotify(SHCNE_NETSHARE, SHCNF_PATH, PChar(LocalPath), nil); //сказать шеллу об изменениях
Result := true;
end;
//----------------------------
function RemoveShareFromDisk(HostName, NetName, LocalPath: string): boolean;
begin
Result := false;
ShareResult := NetShareDel(PChar(HostName), PChar(NetName), 0); //удалить шару
if ShareResult <> 0 then Exit;
SHChangeNotify(SHCNE_NETUNSHARE, SHCNF_PATH, PChar(LocalPath), nil); //сказать шеллу об изменениях
Result := true;
end;
//----------------------------
end.
Взято с Исходников.ru
Как разбить "цвет" на составляющие и наоборот?
Как разбить "цвет" на составляющие и наоборот?
GetRValue
GetBValue
GetGValue
В обратную сторону RGB()
Автор Vit
Взято с Vingrad.ru
Как разделить обработку OnClick
Как разделить обработку OnClick и OnDblClick? Ведь OnClick будет вызываться всегда, и перед DblClick.
Именно так и происходит в Windows - посылаются оба сообщения. Для того чтобы обработать только какое-то одно событие необходимо чуть "задержать" выполнение OnClick. Сделать это можно следующим способом:
procedure TForm1.ListBox1Click(Sender: TObject);
var
Msg: TMsg;
TargetTime: Longint;
begin
{ get the maximum time to wait for a double-click message }
TargetTime := GetTickCount + GetDoubleClickTime;
{ cycle until DblClick received or wait time run out }
while GetTickCount < TargetTime do
if PeekMessage(Msg, ListBox1.Handle, WM_LBUTTONDBLCLK, WM_LBUTTONDBLCLK, WM_NOREMOVE)
then Exit; { Double click }
MessageDlg('Single clicked', mtInformation, [mbOK], 0);
end;
Как разделить строку на элементы, Аналог VB функции Split
Как разделить строку на элементы, Аналог VB функции Split
Вариант 1.
В Дельфи есть специальный класс для хранения массивов строк - TStringList - очень рекомендую. Вот как вашу строку превратить в TStringList:
Объявление переменной
var t:TStringList;
begin
t:=TStringList.create; //создаём класс
t.text:=stringReplace('Ваша строка для разделения',' ',#13#10,[rfReplaceAll]);//мы заменяем все пробелы на символы конца строки
//теперь можно убедится что у вас строка разбина на элементы:
showmessage(t[0]);
showmessage(t[1]);
showmessage(t[2]);
showmessage(t[3]);
...
//после работы надо уничтожить класс
t.free;
Автор Vit
Взято с Vingrad.ru
Вариант 2. Используем стандартные массивы:
var a:array of string;//наш массив
s:string;//строка которую мы будем разбивать
begin
s:='Windows Messages SysUtils Variants Classes Graphics Controls Forms';
Repeat //мы постепенно заполняем массив на каждом шаге цикла по 1 элементу
setlength(a,length(a)+1);//увеличиваем размер массива на 1
if pos(' ',s)>0 then //если есть пробел то надо взять слово до пробела
begin
a[length(a)-1]:=copy(s,1, pos(' ',s));//присвоение последнему элементу массива первого слова
s:=copy(s,pos(' ',s)+1, length(s));//удаляем из строки первое слово
end
else//в строке осталось только одно слово
begin
a[length(a)-1]:=s;// присвоим последнее слово
break;//выход из цикла
end;
Until False;//цикл бесконечный, выход изнутри
//теперь проверяем что получили
showmessage(a[0]);
showmessage(a[1]);
showmessage(a[2]);
После использования массива не забудте освободить память a:=nil или setlength(a,0)
Автор Vit
Взято с Vingrad.ru
procedure SplitOnWords(const s:string; Delimiters:set of char; Strings:TStrings);
var
p,sp:PChar;
str:string;
begin
include(Delimiters,#0); //чтоб уж наверняк
p:=pointer(s);
while true do
begin
//пропускаем все разделители в начале
while p^ in Delimiters do
if p^=#0 then
exit
else
inc(p);
sp:=p;
//пока не кончилось слово.
while not (p^ in Delimiters) do inc(p);
//запоминаем слово
SetLength(str,cardinal(p)-cardinal(sp));
Move(sp^,pointer(str)^,cardinal(p)-cardinal(sp));
Strings.Add(str);
end;
end;
Автор Fantasist
Взято с Vingrad.ru
См. также
Как различаются между собой Paint-события: Invalidate, Update и Refresh?
Как различаются между собой Paint-события: Invalidate, Update и Refresh?
Invalidate весь объект перерисовывается заново; обычно перерисовывается только часть бывшая перед этим закрытой
Update незамедлительная перерисовка
Refresh Invalidate + Update
Как разместить прозрачную надпись на TBitmap?
Как разместить прозрачную надпись на TBitmap?
var
OldBkMode : integer;
begin
Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,TRANSPARENT);
Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,OldBkMode);
end;
Взято из
DELPHI VCL FAQ
Перевод с английского Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для
Как разрешить / запретить переключение между задачами?
Как разрешить / запретить переключение между задачами?
(только для ALT+TAB и CTRL+ESC)
Это не совсем профессиональный способ, но он работает! Мы просто эмулируем запуск и остановку скринсейвера.
Procedure TaskSwitchingStatus( State : Boolean );
Var
OldSysParam : LongInt;
Begin
SystemParametersInfo( SPI_SCREENSAVERRUNNING, Word( State ), @OldSysParam, 0 );
End;
Взято с Исходников.ru
Как разрезать wav файл?
Как разрезать wav файл?
type
TWaveHeader = record
ident1: array[0..3] of Char; // Must be "RIFF"
len: DWORD; // remaining length after this header
ident2: array[0..3] of Char; // Must be "WAVE"
ident3: array[0..3] of Char; // Must be "fmt "
reserv: DWORD; // Reserved Size
wFormatTag: Word; // format type
nChannels: Word; // number of channels (i.e. mono, stereo, etc.)
nSamplesPerSec: DWORD; //sample rate
nAvgBytesPerSec: DWORD; //for buffer estimation
nBlockAlign: Word; //block size of data
wBitsPerSample: Word; //number of bits per sample of mono data
cbSize: Word; //the count in bytes of the size of
ident4: array[0..3] of Char; //Must be "data"
end;
You can load the file header with this function:
function GetWaveHeader(FileName: TFilename): TWaveHeader;
const
riff = 'RIFF';
wave = 'WAVE';
var
f: TFileStream;
w: TWaveHeader;
begin
if not FileExists(Filename) then
exit;
try
f := TFileStream.create(Filename, fmOpenRead);
f.Read(w, Sizeof(w));
if w.ident1 <> riff then
begin
Showmessage('This is not a RIFF File');
exit;
end;
if w.ident2 <> wave then
begin
Showmessage('This is not a valid wave file');
exit;
end;
finally
f.free;
end;
Result := w;
end;
Now we have all for creating the code for spliting the wave file:
function SplitWave(Source, Dest1, Dest2: TFileName; Pos: Integer): Boolean;
var
f1, f2, f3: TfileStream;
w: TWaveHeader;
p: Integer;
begin
Result:=False
if not FileExists(Source) then
exit;
try
w := GetWaveHeader(Source);
p := Pos - Sizeof(TWaveHeader);
f1 := TFileStream.create(Source, fmOpenRead);
f2 := TFileStream.create(Dest1, fmCreate);
f3 := TFileStream.create(Dest2, fmCreate);
{++++++++++Create file 1 ++++++++++++++++}
w.len := p;
f2.Write(w, Sizeof(w));
f1.position := Sizeof(w);
f2.CopyFrom(f1, p);
{++++++++++++++++++++++++++++++++++++++++}
{+++++++++++Create file 2 +++++++++++++++}
w.len := f1.size - Pos;
f3.write(w, Sizeof(w));
f1.position := Pos;
f3.CopyFrom(f1, f1.size - pos);
{++++++++++++++++++++++++++++++++++++++++}
finally
f1.free;
f2.free;
f3.free;
end;
Result:=True;
end;
Взято с
Delphi Knowledge BaseКак реализовать обработку информации одновременно несколькими потоками
Как реализовать обработку информации одновременно несколькими потоками
Автор: Садыков Алексей Николаевич
Запускайте Delphi. Итак, наша программа будет представлять из себя форму с двумя edit'ами и кнопкой. Добавьте их на форму.
При нажатии на кнопку будут осуществляться некоторые долгие вычисления. Если бы мы не использовали потоки, то, пока эти вычисления не закончатся, делать мы ничего бы не смогли. Надо было бы ждать. Но, так как потоки у нас будут, то во время долгих вычислений можно будет что-нибудь вводить во второй edit (он, собственно, только для этого и существует). В первый же edit наш поток будет выводить некоторые промежуточные результаты своей работы.
Добавьте в программу еще один модуль (меню File, New, Unit).
Внесите в окно кода нового модуля следующий код:
unit Unit2;
interface
uses
Classes;
type
TMyThread = class(TThread) //Новый класс
private
answer: Integer;
protected
procedure ShowResult;
procedure Execute; override;
end;
implementation
uses
SysUtils, Unit1;
//Процедура для вывода информации из потока
procedure TMyThread.ShowResult;
begin
Form1.Edit1.Text := IntToStr(answer);
end;
//Длинная процедура
procedure TMyThread.Execute;
var
i: Integer;
begin
for i := 1 to 10000 do
begin
answer := answer + 1;
Synchronize(ShowResult);
end;
end;
end.
Немного комментария по коду. В нашем модуле мы вводим новый класс TMyThread как «потомок» TThread. В экземпляре нашего класса и будет выполнятся отдельный поток программы. В классе есть процедура ShowResult для вывода информации из работающего потока в основной поток (форму) нашей программы. Кроме того, в классе есть наша версия метода Execute из родительского класса TThread. Обратите внимание, что в нашей реализации Execute мы пишем
Synchronize(ShowResult);
Тем самым наш поток что-то отправляет в основной поток программы (в данном случае, значение переменной answer). Делаем мы это посредством вызова Synchronize, в котором в качестве параметра указываем имя нужной процедуры.
Теперь переходим к нашему основному модулю Unit1. Во-первых, добавьте в секцию uses ссылку на Unit2:
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Unit2;
Во-вторых, напишите обработчик для нажатия кнопки:
procedure TForm1.Button1Click(Sender: TObject);
var
MyThread: TMyThread;
begin
MyThread := TMyThread.Create(False);
end;
Тут мы создаем второй поток для нашего приложения. Параметр False означает, что метод Execute для нашего потока вызовется немедленно.
Запускайте программу. Нажимайте на кнопку. В первом edit'е замелькают промежуточные результаты работы второго потока. Во время его работы вы можете вводить информацию во второй edit ? т.е. работа одного потока не мешает работе другого.
Взято с
Как реализовать сверхточный таймер?
Как реализовать сверхточный таймер?
Windows is not a real time operating system so it is not really able to reliably achieve high accuracy timing without using a device driver. The best I have been able to get is a few nanoseconds using QueryPerformanceCounter. This is the procedure I use:
var
WaitCal: Int64;
procedure Wait(ns: Integer);
var
Counter, Freq, WaitUntil: Int64;
begin
if QueryPerformanceCounter(Counter) then
begin
QueryPerformanceFrequency(Freq);
WaitUntil := Counter + WaitCal + (ns * (Freq div 1000000));
while Counter < WaitUntil do
QueryPerformanceCounter(Counter);
end
else
Sleep(ns div 1000);
end;
To get improved accuracy do this a little while before using Wait()
var
Start, Finish: Int64;
Application.ProcessMessages;
Sleep(10);
QueryPerformanceCounter(Start);
Wait(0);
QueryPerformanceCounter(Finish);
WaitCal := Start - Finish;
A trick I have found to increase the reliability of this on my computer is to call Wait like this:
Application.ProcessMessages;
Sleep(0);
DoSomething;
Wait(10);
DoSomethingElse;
Взято из
Как редактировать таблицы виртуальных и динамических методов?
Как редактировать таблицы виртуальных и динамических методов?
unitEditorVMTandDMTTables;
interface
// функция служит для выяснения существования VMT у класса
// возвращает True, если класс имеет VMT и False - если нет
function IsVMTExist(Cls: TClass): Boolean;
// процедура служит для замены адреса метода в VMT класса со смещением
// Offset(должно быть кратно 4) новым адресом, хранящимся в NewMet
// примечание: перед вызовом этой процедуры проверяйте существование
// VMT у класса функцией IsVMTExist
procedure VirtMethodReplace(Cls: TClass; Offset: LongWord; NewMet: Pointer); overload;
// процедура служит для замены адреса метода, хранящегося в OldMet,
// в VMT класса новым адресом, хранящимся в NewMet
// примечание: перед вызовом этой процедуры проверяйте существование
// VMT у класса функцией IsVMTExist
procedure VirtMethodReplace(Cls: TClass; OldMet, NewMet: Pointer); overload;
// функция служит для замены адреса динамического метода класса с индексом,
// хранящимся в Index, новым адресом, хранящимся в NewMet
// возвращает True, если метод с данным индексом найден и False - если нет
function DynMethodReplace(Cls: TClass; Index: Word; NewMet: Pointer): Boolean; overload;
// функция служит для замены адреса динамического метода класса, хранящегося
// в OldMet, новым адресом, хранящимся в NewMet
// возвращает True, если метод с данным адресом найден и False - если нет
function DynMethodReplace(Cls: TClass; OldMet, NewMet: Pointer): Boolean; overload;
implementation
// функция служит для получения указателя на байт, следующий за адресом
// последнего метода в VMT класса
// возвращает nil в случае, если у класса нет VMT
// функция является "внутренней" в модуле
// (используется другими подпрограммами и не объявлена в секции interface)
// , поэтому используйте её только если
// Вы полностью уверены в своих действиях(она изменяет "рабочие" регистры
// ECX и EDX)
function GetVMTEnd(Cls: TClass): Pointer;
asm
// Вход: Cls --> EAX
// Выход: Result --> EAX
PUSH EBX
MOV ECX, 8
MOV EBX, -1
MOV EDX, vmtSelfPtr
@@cycle:
ADD EDX, 4
CMP [EAX + EDX], EAX
JE @@vmt_not_found
JB @@continue
CMP [EAX + EDX], EBX
JAE @@continue
MOV EBX, [EAX + EDX]
@@continue:
DEC ECX
JNZ @@cycle
MOV EAX, EBX
JMP @@exit
@@vmt_not_found:
XOR EAX, EAX
@@exit:
POP EBX
end;
function IsVMTExist(Cls: TClass): Boolean;
asm
// Вход: Cls --> EAX
// Выход: Result --> AL
CALL GetVMTEnd
TEST EAX, EAX
JZ @@vmt_not_found
MOV AL, 1
@@vmt_not_found:
end;
procedure VirtMethodReplace(Cls: TClass; Offset: LongWord; NewMet: Pointer); overload;
asm
// Вход: Cls --> EAX, Offset --> EDX, NewMet --> ECX
MOV [EAX + EDX], ECX
end;
procedure VirtMethodReplace(Cls: TClass; OldMet, NewMet: Pointer); overload;
asm
// Вход: Cls --> EAX, OldMet --> EDX, NewMet --> ECX
PUSH EDI
MOV EDI, EAX
PUSH ECX
PUSH EDX
PUSH EAX
CALL GetVMTEnd
POP EDX
SUB EAX, EDX
SHR EAX, 2
POP EDX
POP ECX
PUSH ECX
MOV ECX, EAX
MOV EAX, EDX
POP EDX
REPNE SCASD
JNE @@OldMet_not_found
MOV [EDI - 4], EDX
@@OldMet_not_found:
POP EDI
end;
function DynMethodReplace(Cls: TClass; Index: Word; NewMet: Pointer): Boolean; overload;
asm
// Вход: Cls --> EAX, Index --> DX, NewMet --> ECX
// Выход: Result --> AL
PUSH EDI
PUSH ESI
MOV ESI, ECX
XOR EAX, EDX
XOR EDX, EAX
XOR EAX, EDX
JMP @@start
@@cycle:
MOV EDX, [EDX]
@@start:
MOV EDI, [EDX].vmtDynamicTable
TEST EDI, EDI
JZ @@get_parent_dmt
MOVZX ECX, WORD PTR [EDI]
PUSH ECX
ADD EDI, 2
REPNE SCASW
JE @@Index_found
POP ECX
@@get_parent_dmt:
MOV EDX, [EDX].vmtParent
TEST EDX, EDX
JNZ @@cycle
JMP @@Index_not_found
@@Index_found:
POP EAX
SHL EAX, 1
SUB EAX, ECX
MOV [EDI + EAX * 2 - 4], ESI
MOV AL, 1
JMP @@exit
@@Index_not_found:
XOR AL, AL
@@exit:
POP ESI
POP EDI
end;
function DynMethodReplace(Cls: TClass; OldMet, NewMet: Pointer): Boolean; overload;
asm
// Вход: Cls --> EAX, OldMet --> EDX, NewMet --> ECX
// Выход: Result --> AL
PUSH EDI
PUSH ESI
MOV ESI, ECX
XOR EAX, EDX
XOR EDX, EAX
XOR EAX, EDX
JMP @@start
@@cycle:
MOV EDX, [EDX]
@@start:
MOV EDI, [EDX].vmtDynamicTable
TEST EDI, EDI
JZ @@get_parent_dmt
MOVZX ECX, WORD PTR [EDI]
LEA EDI, EDI + 2 * ECX + 2
REPNE SCASD
JE @@OldMet_found
@@get_parent_dmt:
MOV EDX, [EDX].vmtParent
TEST EDX, EDX
JNZ @@cycle
JMP @@OldMet_not_found
@@OldMet_found:
MOV [EDI - 4], ESI
MOV AL, 1
JMP @@exit
@@OldMet_not_found:
XOR AL, AL
@@exit:
POP ESI
POP EDI
end;
end.
Автор
___ALex___ Форум:Как результат Query сделать в виде постоянной таблицы?
Как результат Query сделать в виде постоянной таблицы?
Traditionally, to write the results of a query to disk, you use a TBatchMove and a TTable in addition to your query. But you can short-circuit this process by making a couple of simple, direct calls to the BDE.
Make sure you have BDE declared in your uses section
procedureMakePermTable(Qry: TQuery; PermTableName: string);
var
h: HDBICur;
ph: PHDBICur;
begin
Qry.Prepare;
Check(dbiQExec(Qry.StmtHandle, ph));
h := ph^;
Check(DbiMakePermanent(h, PChar(PermTableName), True));
end;
Взято с
Delphi Knowledge BaseКак рисовать картинки в пунктах меню?
Как рисовать картинки в пунктах меню?
unitDN_Win;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Menus, StdCtrls,
type
TDNForm = class(TForm)
MainMenu1: TMainMenu;
cm_MainExit: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure cm_MainExitClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
BM:TBitmap;
Procedure WMDrawItem(var Msg:TWMDrawItem); message wm_DrawItem;
Procedure WMMeasureItem(var Msg:TWMMeasureItem); message
wm_MeasureItem;
end;
var
DNForm : TDNForm;
implementation
{$R *.DFM}
var
Comm,yMenu : word;
procedure TDNForm.FormCreate(Sender: TObject);
begin
yMenu:=GetSystemMetrics(SM_CYMENU);
comm:=cm_MainExit.Command;
ModifyMenu(MainMenu1.Handle,0,mf_ByPosition or mf_OwnerDraw,comm,'Go');
end;{TDNForm.FormCreate}
procedure TDNForm.cm_MainExitClick(Sender: TObject);
begin
DNForm.Close;
end;{TDNForm.cmExitClick}
Procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem);
Begin
with Msg.MeasureItemStruct^ do
if ItemID=comm then begin ItemWidth:=yMenu; Itemheight:=yMenu; end;
End;{WMMeasureItem}
Procedure TDNForm.WMDrawItem(var Msg:TWMDrawItem);
var
MemDC:hDC;
BM:hBitMap;
mtd:longint;
Begin
with Msg.DrawItemStruct^ do
begin
if ItemID=comm then
begin
BM:=LoadBitMap(hInstance,'dver');
MemDC:=CreateCompatibleDC(hDC);{hDC ? TDrawItemStruct}
SelectObject(MemDC,BM); {rcItem ? TDrawItemStruct}
if ItemState=ods_Selected then mtd:=NotSrcCopy else mtd:=SrcCopy;
StretchBlt(hDC,rcItem.left,rcItem.top,yMenu,yMenu,MemDC,0,0,24,23,mtd);
DeleteDC(MemDC);
DeleteObject(BM);
end;
end{with}
End;{TDNForm.WMDrawItem}
end.
Eugeny Sverchkov
es906@kolnpp.elektra.ru
(2:5031/12.23)
Автор:
StayAtHomeВзято из
Как рисовать линии (или ещё что-нибудь) на экране (TDesktopCanvas)
Как рисовать линии (или ещё что-нибудь) на экране (TDesktopCanvas)
{
Пример рисует две горизонтальные линии на экране используя TDesktopCanvas.
}
program TrinitronTraining;
uses
Messages, Windows, Graphics, Forms;
type
TDesktopCanvas = class(TCanvas)
private
DC : hDC;
function GetWidth:Integer;
function GetHeight:Integer;
public
constructor Create;
destructor Destroy; override;
published
property Width: Integer read GetWidth;
property Height: Integer read GetHeight;
end;
{ Объект TDesktopCanvas }
function TDesktopCanvas.GetWidth:Integer;
begin
Result:=GetDeviceCaps(Handle,HORZRES);
end;
function TDesktopCanvas.GetHeight:Integer;
begin
Result:=GetDeviceCaps(Handle,VERTRES);
end;
constructor TDesktopCanvas.Create;
begin
inherited Create;
DC := GetDC(0);
Handle := DC;
end;
destructor TDesktopCanvas.Destroy;
begin
Handle := 0;
ReleaseDC(0, DC);
inherited Destroy;
end;
Const
YCount = 2;
Var
desktop : TDesktopCanvas;
dx,dy : Integer;
i : Integer;
F : Array[1..YCount] of TForm;
function CreateLine(Y : Integer) : TForm;
begin
Result := TForm.Create(Application);
with Result do begin
Left := 0;
Top := y;
Width := dx;
Height := 1;
BorderStyle := bsNone;
FormStyle := fsStayOnTop;
Visible := True;
end;
end;
procedure ProcessMessage;
var
Msg : TMsg;
begin
if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
if Msg.Message = WM_QUIT then Application.Terminate;
end;
begin
desktop := TDesktopCanvas.Create;
try
dx := desktop.Width;
dy := desktop.Height div (YCount+1);
finally
desktop.free;
end;
for i:=1 to YCount do F[i]:=CreateLine(i*dy);
Application.NormalizeTopMosts;
ShowWindow(Application.Handle, SW_Hide);
for i:=1 to YCount do
SetWindowPos(F[i].Handle, HWND_TOPMOST, 0,0,0,0, SWP_NOACTIVATE+SWP_NOMOVE+SWP_NOSIZE);
{ следующие строки используются для того, чтобы не останавливаться
repeat
ProcessMessage;
until false;
{}
Sleep(15000);
for i:=1 to YCount do F[i].Free;
end.
Взято с Исходников.ru
Как рисовать на компоненте, если свойство Canvas недоступно?
Как рисовать на компоненте, если свойство Canvas недоступно?
У всех компонентов, порожденных от TCustomControl, имеется свойство Canvas типа TCanvas.
Если свойство Canvas недоступно, Вы можете достучаться до него созданием потомка и переносом этого свойства в раздел Public.
{ Example. We recommend You to create this component through Component Wizard.
In Delphi 1 it can be found as 'File|New Component...', and can be found
as 'Component|New Component...' in Delphi 2 or above. }
type
TcPanel = class(TPanel)
public
property Canvas;
end;
Akzhan Abdulin
(2:5040/55)
Если у объекта нет свойства Canvas (у TDBEdit, вpоде-бы нет), по кpайней меpе в D3 можно использовать класс TControlCanvas. Пpимеpное использование:
var cc: TControlCanvas;
...
cc := TControlCanvas.Create;
cc.Control := youControl;
...
и далее как обычно можно использовать методы Canvas.
Andrew Velikoredchanin
(2:5026/29.3)
Как рисовать в чужом окне или по всему экрану
Как рисовать в чужом окне или по всему экрану
procedure DrawOnScreen;
var
ScreenDC: hDC;
begin
ScreenDC := GetDC(0); {получить контекст экрана}
Ellipse(ScreenDC, 0, 0, 200, 200); {нарисовать}
ReleaseDC(0, ScreenDC); {освободить контекст}
end;
Взято с Исходников.ru
Как рисовать за пределами формы
Как рисовать за пределами формы
Создайте обработчик сообщения для WM_NCPAINT. Следующий пример рисует красную расмку вокруг формы шириной в один пиксель.
type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
dc : hDc;
Pen : hPen;
OldPen : hPen;
OldBrush : hBrush;
begin
inherited;
dc := GetWindowDC(Handle);
msg.Result := 1;
Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));
OldPen := SelectObject(dc, Pen);
OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
Rectangle(dc, 0,0, Form1.Width, Form1.Height);
SelectObject(dc, OldBrush);
SelectObject(dc, OldPen);
DeleteObject(Pen);
ReleaseDC(Handle, Canvas.Handle);
end;
Взято с Исходников.ru
Как с помощью API поместить Label на Form?
Как с помощью API поместить Label на Form?
var
hLabel : HWND ;
...
hLabel := CreateWindow ( 'STATIC', 'test', WS_CHILD or WS_VISIBLE, 0, 0, 200, 40, hWnd, NULL, hInstance, NULL );
Автор ответа: Baa
Примечание: Vit
Скорее всего последний параметр не "NULL", а "Nil" (NULL в паскале - варианта для обозначения пустого поля в базе данных)
Взято с Vingrad.ru
program Project1;
uses
Windows,
Messages;
const
myClassName= 'myWindow';
var
handleWnd, Label1 : THandle;
WndClass: TWndClass;
Msg: TMsg;
function WindowProc(Window: HWnd; AMessage, WParam,
LParam: Longint): Longint; stdcall;
begin
WindowProc:= DefWindowProc(Window, AMessage, WParam, LParam);
case AMessage of
{WM_COMMAND: if lParam = Button1 then
MessageBox( 0, 'Вы нажали кнопку!', 'Информация',
MB_OK or MB_ICONINFORMATION); }
WM_DESTROY: Halt;
end;
end;
begin
with WndClass do
begin
hInstance := hInstance;
lpszClassName:= myClassName;
style := cs_hRedraw or cs_vRedraw;
hbrBackground:= color_btnface +1;
lpfnWndProc := @WindowProc;
hCursor := LoadCursor(0, idc_Arrow);
hIcon := LoadIcon(0, IDI_EXCLAMATION);
lpszMenuName := NIL;
cbWndExtra := 0;
cbClsExtra := 0;
end;
RegisterClass( WndClass );
handleWnd:= CreateWindow(myClassName, 'Hажми кнопку', ws_OverlappedWindow,
400, 300, 200, 100, 0, 0, hInstance , NIL);
if handleWnd = 0 then
begin
MessageBox( 0, 'Error', NIL, MB_OK );
Exit;
end;
Label1:= CreateWindow( 'Label', 'Text',
WS_VISIBLE or WS_CHILD or WM_SETTEXT,
20, 10, 60, 23, handleWnd, 0, hInstance, nil);
ShowWindow(handleWnd, SW_SHOW);
UpdateWindow(handleWnd);
while GetMessage(Msg, handleWnd, 0, 0) do
begin
TranslateMessage(Msg) ;
DispatchMessage(Msg) ;
end;
end.
Автор ответа: alex-co
Взято с Vingrad.ru
Как считать сигнал с микрофона?
Как считать сигнал с микрофона?
В Windows нет разделения каналов записи по источникам.
CD-ROM ----------|
| |--- Динамики
Микрофон --------| |
|-- Windows --|--- Записывающие программы
Линейный вход ---| |
| |--- Линейный выход
MIDI ------------|
Все поступающие в систему звуки смешиваются, и лишь после этого их получает программа.
Для получения звукового сигнала нужно воспользоваться WinAPI.
WaveInOpen открывает доступ к микрофону.
Одновременно только одна программа может работать с микрофоном.
Заодно Вы указываете, какая нужна частота, сколько бит на значение и размер буфера.
От последнего зависит, как часто и в каком объеме информация будет поступать в программу.
Далее нужно выделить память для буфера и вызвать функцию WaveInAddBuffer,
которая передаст Windows пустой буфер.
После вызова WaveInStart Windows начнет заполнять буфер,
и, после его заполнения, пошлет сообщение MM_WIM_DATA.
В нем нужно обработать полученную информацию и вновь вызвать WaveInAddBuffer,
тем самым указав, что буфер пуст.
Функции WaveInReset и WaveInClose прекратят поступление информации в программу и закроют доступ к микрофону.
Эта программа считывает сигнал с микрофона и выводит его на экран.
Частота сигнала - 22050 Гц. Количество бит определяется флажком, размер буфера TrackBar-ом.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ComCtrls, MMSystem;
type
TData8 = array [0..127] of byte;
PData8 = ^TData8;
TData16 = array [0..127] of smallint;
PData16 = ^TData16;
TPointArr = array [0..127] of TPoint;
PPointArr = ^TPointArr;
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
PaintBox1: TPaintBox;
TrackBar1: TTrackBar;
CheckBox1: TCheckBox;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure CheckBox1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
procedure OnWaveIn(var Msg: TMessage); message MM_WIM_DATA;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
var
WaveIn: hWaveIn;
hBuf: THandle;
BufHead: TWaveHdr;
bufsize: integer;
Bits16: boolean;
p: PPointArr;
stop: boolean = false;
procedure TForm1.Button1Click(Sender: TObject);
var
header: TWaveFormatEx;
BufLen: word;
buf: pointer;
begin
BufSize := TrackBar1.Position * 500 + 100; { Размер буфера }
Bits16 := CheckBox1.Checked;
with header do begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := 1; { количество каналов }
nSamplesPerSec := 22050; { частота }
wBitsPerSample := integer(Bits16) * 8 + 8; { 8 / 16 бит }
nBlockAlign := nChannels * (wBitsPerSample div 8);
nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
cbSize := 0;
end;
WaveInOpen(Addr(WaveIn), WAVE_MAPPER, addr(header),
Form1.Handle, 0, CALLBACK_WINDOW);
BufLen := header.nBlockAlign * BufSize;
hBuf := GlobalAlloc(GMEM_MOVEABLE and GMEM_SHARE, BufLen);
Buf := GlobalLock(hBuf);
with BufHead do begin
lpData := Buf;
dwBufferLength := BufLen;
dwFlags := WHDR_BEGINLOOP;
end;
WaveInPrepareHeader(WaveIn, Addr(BufHead), sizeof(BufHead));
WaveInAddBuffer(WaveIn, addr(BufHead), sizeof(BufHead));
GetMem(p, BufSize * sizeof(TPoint));
stop := true;
WaveInStart(WaveIn);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if stop = false then Exit;
stop := false;
while not stop do Application.ProcessMessages;
stop := false;
WaveInReset(WaveIn);
WaveInUnPrepareHeader(WaveIn, addr(BufHead), sizeof(BufHead));
WaveInClose(WaveIn);
GlobalUnlock(hBuf);
GlobalFree(hBuf);
FreeMem(p, BufSize * sizeof(TPoint));
end;
procedure TForm1.OnWaveIn;
var
i: integer;
data8: PData8;
data16: PData16;
h: integer;
XScale, YScale: single;
begin
h := PaintBox1.Height;
XScale := PaintBox1.Width / BufSize;
if Bits16 then begin
data16 := PData16(PWaveHdr(Msg.lParam)^.lpData);
YScale := h / (1 shl 16);
for i := 0 to BufSize - 1 do
p^[i] := Point(round(i * XScale),
round(h / 2 - data16^[i] * YScale));
end else begin
Data8 := PData8(PWaveHdr(Msg.lParam)^.lpData);
YScale := h / (1 shl 8);
for i := 0 to BufSize - 1 do
p^[i] := Point(round(i * XScale),
round(h - data8^[i] * YScale));
end;
with PaintBox1.Canvas do begin
Brush.Color := clWhite;
FillRect(ClipRect);
Polyline(Slice(p^, BufSize));
end;
if stop
then WaveInAddBuffer(WaveIn, PWaveHdr(Msg.lParam),
SizeOf(TWaveHdr))
else stop := true;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Button2.Click;
end;
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
if stop then begin
Button2.Click;
Button1.Click;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
TrackBar1.OnChange := CheckBox1Click;
Button1.Caption := 'Start';
Button2.Caption := 'Stop';
CheckBox1.Caption := '16 / 8 bit';
end;
end.
Всего доброго,
Даниил Карапетян.
На сайте http://delphi4all.narod.ru Вы найдете более 100 советов по Delphi.
email: delphi4all@narod.ru
Как сделать 24bit dithering?
Как сделать 24bit dithering?
{... }
type
PIntegerArray = ^TIntegerArray;
TIntegerArray = array[0..maxInt div sizeof(integer) - 2] of integer;
TColor3 = packed record
b, g, r: byte;
end;
TColor3Array = array[0..maxInt div sizeof(TColor3) - 2] of TColor3;
PColor3Array = ^TColor3Array;
procedure Swap(var p1, p2: PIntegerArray);
var
t: PIntegerArray;
begin
t := p1;
p1 := p2;
p2 := t;
end;
function clamp(x, min, max: integer): integer;
begin
result := x;
if result < min then
result := min;
else
if result > max then
result := max;
end;
procedure Dither(bmpS, bmpD: TBitmap);
var
bmpS, bmpD: TBitmap;
scanlS, scanlD: PColor3Array;
error1R, error1G, error1B,
error2R, error2G, error2B: PIntegerArray;
x, y: integer;
dx: integer;
c, cD: TColor3;
sR, sG, sB: integer;
dR, dG, dB: integer;
eR, eG, eB: integer;
begin
bmpD.Width := bmpS.Width;
bmpD.Height := bmpS.Height;
bmpS.PixelFormat := pf24bit;
bmpD.PixelFormat := pf24bit;
error1R := AllocMem((bmpS.Width + 2) * sizeof(integer));
error1G := AllocMem((bmpS.Width + 2) * sizeof(integer));
error1B := AllocMem((bmpS.Width + 2) * sizeof(integer));
error2R := AllocMem((bmpS.Width + 2) * sizeof(integer));
error2G := AllocMem((bmpS.Width + 2) * sizeof(integer));
error2B := AllocMem((bmpS.Width + 2) * sizeof(integer));
{dx holds the delta for each iteration as we zigzag, it'll change between 1 and -1}
dx := 1;
for y := 0 to bmpS.Height - 1 do
begin
scanlS := bmpS.ScanLine[y];
scanlD := bmpD.ScanLine[y];
if dx > 0 then
x := 0
else
x := bmpS.Width - 1;
while (x >= 0) and (x < bmpS.Width) do
begin
c := scanlS[x];
sR := c.r;
sG := c.g;
sB := c.b;
eR := error1R[x + 1];
eG := error1G[x + 1];
eB := error1B[x + 1];
dR := (sR * 16 + eR) div 16;
dG := (sR * 16 + eR) div 16;
dB := (sR * 16 + eR) div 16;
{actual downsampling}
dR := clamp(dR, 0, 255) and (255 shl 4);
dG := clamp(dR, 0, 255) and (255 shl 4);
dB := clamp(dR, 0, 255) and (255 shl 4);
cD.r := dR;
cD.g := dG;
cD.b := dB;
scanlD[x] := cD;
eR := sR - dR;
eG := sG - dG;
eB := sB - dB;
inc(error1R[x + 1 + dx], (eR * 7)); {next}
inc(error1G[x + 1 + dx], (eG * 7));
inc(error1B[x + 1 + dx], (eB * 7));
inc(error2R[x + 1], (eR * 5)); {top}
inc(error2G[x + 1], (eG * 5));
inc(error2B[x + 1], (eB * 5));
inc(error2R[x + 1 + dx], (eR * 1)); {diag forward}
inc(error2G[x + 1 + dx], (eG * 1));
inc(error2B[x + 1 + dx], (eB * 1));
inc(error2R[x + 1 - dx], (eR * 3)); {diag backward}
inc(error2G[x + 1 - dx], (eG * 3));
inc(error2B[x + 1 - dx], (eB * 3));
inc(x, dx);
end;
dx := dx * -1;
Swap(error1R, error2R);
Swap(error1G, error2G);
Swap(error1B, error2B);
FillChar(error2R^, sizeof(integer) * (bmpS.Width + 2), 0);
FillChar(error2G^, sizeof(integer) * (bmpS.Width + 2), 0);
FillChar(error2B^, sizeof(integer) * (bmpS.Width + 2), 0);
end;
FreeMem(error1R);
FreeMem(error1G);
FreeMem(error1B);
FreeMem(error2R);
FreeMem(error2G);
FreeMem(error2B);
end;
Взято с
Delphi Knowledge BaseКак сделать ADO-connection?
Как сделать ADO-connection?
uses
ComObj;
function OpenConnection(ConnectionString: AnsiString): Integer;
var
ADODBConnection: OleVariant;
begin
ADODBConnection := CreateOleObject('ADODB.Connection');
ADODBConnection.CursorLocation := 3; // User client
ADODBConnection.ConnectionString := ConnectionString;
Result := 0;
try
ADODBConnection.Open;
except
Result := -1;
end;
end;
function DataBaseConnection_Test(bMessage: Boolean): AnsiString;
var
asTimeout, asUserName, asPassword, asDataSource, ConnectionString: AnsiString;
iReturn: Integer;
OldCursor: TCursor;
begin
OldCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
asTimeout := '150';
asUserName := 'NT_Server';
asPassword := 'SA';
asDataSource := 'SQL Server - My DataBase';
ConnectionString := 'Data Source = ' + asDataSource +
'User ID = ' + asUserName +
'Password = ' + asPassword +
'Mode = Read|Write;Connect Timeout = ' + asTimeout;
try
iReturn := OpenConnection(ConnectionString);
if (bMessage) then
begin
if (iReturn = 0) then
Application.MessageBox('Connection OK!', 'Information', MB_OK)
else if (iReturn = -1) then
Application.MessageBox('Connection Error!', 'Error', MB_ICONERROR + MB_OK);
end;
if (iReturn = 0) then
Result := ConnectionString
else if (iReturn = -1) then
Result := '';
finally
Screen.Cursor := OldCursor;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
DataBaseConnection_Test(True);
end;
Взято с сайта
Как сделать анимацию минимизации формы?
Как сделать анимацию минимизации формы?
In FormShow:
var
RecS, RecL: TRect;
begin
RecS := Rect(Screen.Width, Screen.Height, Screen.Width, Screen.Height);
RecL := ThisForm.BoundsRect;
DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RecS, RecL);
{ ... }
end;
In FormHide:
var
RecS, RecL: TRect;
begin
HideTimer.Enabled := False;
RecS := Rect(Screen.Width, Screen.Height, Screen.Width, Screen.Height);
RecL := ThisForm.BoundsRect;
DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RecL, RecS);
end;
Взято с
Delphi Knowledge BaseКак сделать анимацию немерцающей
Как сделать анимацию немерцающей
Мерцание возникает, когда цвет точки меняется два раза подряд. Например, правильнее объект при его перемещении стирать и затем рисовать на новом месте не на экране, а в памяти, и выводить на форму уже готовое изображение поверх предыдущего. В таком случае смена цветов на экране происходит только один раз.
var
bm: TBitMap;
procedure TForm1.FormCreate(Sender: TObject);
begin
bm := TBitMap.Create;
bm.Width := Form1.ClientWidth;
bm.Height := Form1.ClientHeight;
with bm.Canvas do
begin
Font.name := 'Arial';
Font.Size := 50;
Font.Color := clBlue;
end;
Timer1.Interval := 100;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
s: string;
Hour, Min, Sec, MSec: Word;
begin
DecodeTime(Time, Hour, Min, Sec, MSec);
with bm.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clWhite;
FillRect(ClipRect);
s := TimeToStr(Time);
TextOut((bm.Width - TextWidth(s)) div 2,
(bm.Height - TextHeight(s)) div 2, s);
Pen.Mode := pmMask;
Pen.Width := 20;
Pen.Color := clLime;
Brush.Style := bsClear;
Rectangle(bm.Width div 2 - (MSec * bm.Width) div 5000,
bm.Height div 2 - (MSec * bm.Height) div 5000,
bm.Width div 2 + (MSec * bm.Width) div 5000,
bm.Height div 2 + (MSec * bm.Height) div 5000);
end;
Form1.Canvas.Draw(0, 0, bm);
end;
Взято с
Как сделать balloon tooltips?
Как сделать balloon tooltips?
uses
Commctrl;
procedure ShowBalloonTip(Control: TWinControl; Icon: integer; Title: pchar; Text: PWideChar;
BackCL, TextCL: TColor);
const
TOOLTIPS_CLASS = 'tooltips_class32';
TTS_ALWAYSTIP = $01;
TTS_NOPREFIX = $02;
TTS_BALLOON = $40;
TTF_SUBCLASS = $0010;
TTF_TRANSPARENT = $0100;
TTF_CENTERTIP = $0002;
TTM_ADDTOOL = $0400 + 50;
TTM_SETTITLE = (WM_USER + 32);
ICC_WIN95_CLASSES = $000000FF;
type
TOOLINFO = packed record
cbSize: Integer;
uFlags: Integer;
hwnd: THandle;
uId: Integer;
rect: TRect;
hinst: THandle;
lpszText: PWideChar;
lParam: Integer;
end;
var
hWndTip: THandle;
ti: TOOLINFO;
hWnd: THandle;
begin
hWnd := Control.Handle;
hWndTip := CreateWindow(TOOLTIPS_CLASS, nil,
WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP,
0, 0, 0, 0, hWnd, 0, HInstance, nil);
if hWndTip <> 0 then
begin
SetWindowPos(hWndTip, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
ti.cbSize := SizeOf(ti);
ti.uFlags := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS;
ti.hwnd := hWnd;
ti.lpszText := Text;
Windows.GetClientRect(hWnd, ti.rect);
SendMessage(hWndTip, TTM_SETTIPBKCOLOR, BackCL, 0);
SendMessage(hWndTip, TTM_SETTIPTEXTCOLOR, TextCL, 0);
SendMessage(hWndTip, TTM_ADDTOOL, 1, Integer(@ti));
SendMessage(hWndTip, TTM_SETTITLE, Icon mod 4, Integer(Title));
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowBalloonTip(Button1, 1, 'Title',
'Balloon tooltip,http://kingron.myetang.com; updated by Calin', clBlue, clNavy);
end;
{....}
uses Commctrl;
{....}
const
TTS_BALLOON = $40;
TTM_SETTITLE = (WM_USER + 32);
var
hTooltip: Cardinal;
ti: TToolInfo;
buffer : array[0..255] of char;
{....}
procedure CreateToolTips(hWnd: Cardinal);
begin
hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON,
Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
if hToolTip <> 0 then
begin
SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
SWP_NOSIZE or SWP_NOACTIVATE);
ti.cbSize := SizeOf(TToolInfo);
ti.uFlags := TTF_SUBCLASS;
ti.hInst := hInstance;
end;
end;
procedure AddToolTip(hwnd: DWORD; lpti: PToolInfo; IconType: Integer;
Text, Title: PChar);
var
Item: THandle;
Rect: TRect;
begin
Item := hWnd;
if (Item <> 0) and (GetClientRect(Item, Rect)) then
begin
lpti.hwnd := Item;
lpti.Rect := Rect;
lpti.lpszText := Text;
SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
FillChar(buffer, SizeOf(buffer), #0);
lstrcpy(buffer, Title);
if (IconType > 3) or (IconType < 0) then IconType := 0;
SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CreateToolTips(Form1.Handle);
AddToolTip(Memo1.Handle, @ti, 1, 'Tooltip text', 'Title');
end;
{
IconType can be:
0 - No icon
1 - Information
2 - Warning
3 - Error
}
Взято с сайта
Как сделать, чтобы форма закрывалась при нажатии Esc?
Как сделать, чтобы форма закрывалась при нажатии Esc?
Для начала необходимо установить свойство формы KeyPreview в True. А потом уже можно отлавливать "Esc":
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.KeyPreview := True;
end;
procedure TForm1.FormKeyPress
(Sender: TObject; var Key: Char);
begin
if key = #27 then Close;
end;
Взято с Исходников.ru
Как сделать, чтобы компоненты отбрасывали тень?
Как сделать, чтобы компоненты отбрасывали тень?
procedure ShadeIt(f: TForm; c: TControl; Width: Integer; Color: TColor);
var
rect: TRect;
old: TColor;
begin
if (c.Visible) then
begin
rect := c.BoundsRect;
rect.Left := rect.Left + Width;
rect.Top := rect.Top + Width;
rect.Right := rect.Right + Width;
rect.Bottom := rect.Bottom + Width;
old := f.Canvas.Brush.Color;
f.Canvas.Brush.Color := Color;
f.Canvas.fillrect(rect);
f.Canvas.Brush.Color := old;
end;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
i: Integer;
begin
for i := 0 to Self.ControlCount - 1 do
ShadeIt(Self, Self.Controls[i], 3, clBlack);
end;
Взято с сайта
Как сделать чтобы окно было на весь экран?
Как сделать чтобы окно было на весь экран?
PostMessage(Application.Handle, WM_SYSCOMMAND, SC_MAXIMIZE, 1);
Автор ответа: Baa
Взято с Vingrad.ru
Как сделать, чтобы TEdit воспринимал одни цифры и DecimalSeparator?
Как сделать, чтобы TEdit воспринимал одни цифры и DecimalSeparator?
Автор: Full ( http://full.hotmail.ru/ )
type
TNumEdit = class(TEdit)
procedure CreateParams(var Params: TCreateParams); override;
procedure KeyPress(var Key: Char); override;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TNumEdit]);
end;
procedure TNumEdit.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or ES_MULTILINE or ES_RIGHT;
end;
procedure TNumEdit.KeyPress(var Key: Char);
begin
case key of
'0'..'9': ; // цифры
#8: ; // забой
'.', ',': if Pos(DecimalSeparator, Text)=0 then Key:=DecimalSeparator else Key:=#0; // десятичный разделитель
else key:=#0;
end; // case
end;
end.
Взято с Исходников.ru
Как сделать, чтобы запускалась только одна копия приложения?
Как сделать, чтобы запускалась только одна копия приложения?
varAtomText: array[0..31] of Char;
procedure LookForPreviousInstance;
var
PreviousInstanceWindow : hWnd;
AppName : array[0..30] of char;
FoundAtom : TAtom;
begin
// помещаем имя приложения в AtomText
StrFmt(AtomText, 'OnlyOne%s', [Copy(Application.Title,1,20)]);
// Проверяем, не создано ли уже атома с таким именем приложения
FoundAtom := GlobalFindAtom(AtomText);
if FoundAtom <> 0 then // эта копия приложения уже запущена
begin
StrFmt(AppName,'%s', [Application.Title]);
// изменяем текущий заголовок, чтобы FindWindow не видела его
Application.ShowMainForm := false;
Application.Title := 'destroy me';
// ищем предыдущую копию приложения
PreviousInstanceWindow := FindWindow(nil,AppName);
// Передаём фокус на предыдущую копию приложения
// завершаем текущую копию
Application.Terminate;
if PreviousInstanceWindow <> 0 then
if IsIconic(PreviousInstanceWindow) then
ShowWindow(PreviousInstanceWindow,SW_RESTORE)
else SetForegroundWindow(PreviousInstanceWindow);
end;
// создаём глобальный атом, чтобы предотвратить запуск другой копии приложения
FoundAtom := GlobalAddAtom(AtomText);
end;
constructor TForm.Create(AOwner: TComponent);
begin
inherited;
LookForPreviousInstance;
...
end;
destructor TForm.Destroy;
var
FoundAtom : TAtom;
ValueReturned : word;
begin
// не забудьте удалить глобальный атом
FoundAtom := GlobalFindAtom(AtomText);
if FoundAtom <> 0 then ValueReturned := GlobalDeleteAtom(FoundAtom);
inherited Destroy;
end;
Взято с Исходников.ru
В блоке begin..end модуля .dpr:
begin
if HPrevInst <> 0 then
begin
ActivatePreviousInstance;
Halt;
end;
end;
Реализация:
unit PrevInst;
interface
uses
WinProcs,
WinTypes,
SysUtils;
type
PHWnd = ^HWnd;
function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool; export;
procedure ActivatePreviousInstance;
implementation
function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool;
var
ClassName: array[0..30] of char;
begin
Result := true;
if GetWindowWord(Wnd, GWW_HINSTANCE) = HPrevInst then
begin
GetClassName(Wnd, ClassName, 30);
if STRIComp(ClassName, 'TApplication') = 0 then
begin
TargetWindow^ := Wnd;
Result := false;
end;
end;
end;
procedure ActivatePreviousInstance;
var
PrevInstWnd: HWnd;
begin
PrevInstWnd := 0;
EnumWindows(@EnumApps, LongInt(@PrevInstWnd));
if PrevInstWnd <> 0 then
if IsIconic(PrevInstWnd) then
ShowWindow(PrevInstWnd, SW_Restore)
else
BringWindowToTop(PrevInstWnd);
end;
end.
Взято из
Советов по Delphi от
Сборник Kuliba
Как сделать colorize?
Как сделать colorize?
functionColorize(RGB, Luma: Cardinal);
var
l, r, g, b: Single;
begin
Result := Luma;
if Luma = 0 then { it's all black anyway}
Exit;
l := Luma / 255;
r := RGB and $FF * l;
g := RGB shr 8 and $FF * l;
b := RGB shr 16 and $FF * l;
Result := Round(b) shl 16 or Round(g) shl 8 or Round(r);
end;
Взято с
Delphi Knowledge BaseКак сделать дырку в окне?
Как сделать дырку в окне?
procedure TForm1.Button4Click(Sender: TObject);
var
HRegion1, Hreg2, Hreg3: THandle;
Col: TColor;
begin
ShowMessage ('Ready for a real crash?');
Col := Color;
Color := clRed;
PlaySound ('boom.wav', 0, snd_sync);
HRegion1 := CreatePolygonRgn (Pts,
sizeof (Pts) div 8,
alternate);
SetWindowRgn (
Handle, HRegion1, True);
ShowMessage ('Now, what have you done?');
Color := Col;
ShowMessage ('Вам лучше купить новый монитор');
end;
Взято с Исходников.ru
Как сделать фон у текста прозрачным?
Как сделать фон у текста прозрачным?
Для этого можно воспользоваться API функцией SetBkMode().
procedure TForm1.Button1Click(Sender: TObject);
var
OldBkMode : integer;
begin
with Form1.Canvas do begin
Brush.Color := clRed;
FillRect(Rect(0, 0, 100, 100));
Brush.Color := clBlue;
TextOut(10, 20, 'Not Transparent!');
OldBkMode := SetBkMode(Handle, TRANSPARENT);
TextOut(10, 50, 'Transparent!');
SetBkMode(Handle, OldBkMode);
end;
end;
Взято с Исходников.ru
Как сделать форму без caption?
Как сделать форму без caption?
Обычная форма:
TForm.Style:=bsNone
Автор ответа: Song
Взято с Vingrad.ru
MDIChild форма:
setWindowLong (handle,GWL_STYLE,getWindowLong(handle, GWL_STYLE) and not WS_CAPTION);
width:=width+1;
width:=width-1;
Автор ответа: rhf
Взято с Vingrad.ru
{ Private Declaration }
procedure CreateParams(var Params : TCreateParams); override;
...
procedure TForm1.CreateParams(var Params : TCreateParams);
begin
inherited Createparams(Params);
with Params do
Style := (Style or WS_POPUP) and not WS_DLGFRAME;
end;
Взято с Исходников.ru
Как сделать графический hint?
Как сделать графический hint?
{*********************************************************
Mit Hilfe des folgendes Codes lassen sich leicht beliebige
Hints erstellen. Dazu muss nur dir Prozedur "Paint" den
Wьnschen entsprechend angepasst werden.
With the following Code you can simply create custom hints.
You just have to change the procedur "Paint".
*********************************************************}
type
TGraphicHintWindow = class(THintWindow)
constructor Create(AOwner: TComponent); override;
private
FActivating: Boolean;
public
procedure ActivateHint(Rect: TRect; const AHint: string); override;
protected
procedure Paint; override;
published
property Caption;
end;
{...}
constructor TGraphicHintWindow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{
Hier kцnnen beliebige Schrift Eigenschaften gesetzt
werden.
Here you can set custom Font Properties:
}
with Canvas.Font do
begin
Name := 'Arial';
Style := Style + [fsBold];
Color := clBlack;
end;
end;
procedure TGraphicHintWindow.Paint;
var
R: TRect;
bmp: TBitmap;
begin
R := ClientRect;
Inc(R.Left, 2);
Inc(R.Top, 2);
{*******************************************************
Der folgende Code ist ein Beispiel wie man die Paint
Prozedur nutzen kann um einen benutzerdefinierten Hint
zu erzeugen.
The folowing Code ist an example how to create a custom
Hint Object. :
}
bmp := TBitmap.Create;
bmp.LoadfromFile('D:\hint.bmp');
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clsilver;
Pen.Color := clgray;
Rectangle(0, 0, 18, R.Bottom + 1);
Draw(2,(R.Bottom div 2) - (bmp.Height div 2), bmp);
end;
bmp.Free;
//Beliebige HintFarbe
//custom Hint Color
Color := clWhite;
Canvas.Brush.Style := bsClear;
Canvas.TextOut(20, (R.Bottom div 2) - (Canvas.Textheight(Caption) div 2), Caption);
{********************************************************}
end;
procedure TGraphicHintWindow.ActivateHint(Rect: TRect; const AHint: string);
begin
FActivating := True;
try
Caption := AHint;
//Hцhe des Hints setzen setzen
//Set the "Height" Property of the Hint
Inc(Rect.Bottom, 14);
//Breite des Hints setzen
//Set the "Width" Property of the Hint
Rect.Right := Rect.Right + 20;
UpdateBoundsRect(Rect);
if Rect.Top + Height > Screen.DesktopHeight then
Rect.Top := Screen.DesktopHeight - Height;
if Rect.Left + Width > Screen.DesktopWidth then
Rect.Left := Screen.DesktopWidth - Width;
if Rect.Left < Screen.DesktopLeft then Rect.Left := Screen.DesktopLeft;
if Rect.Bottom < Screen.DesktopTop then Rect.Bottom := Screen.DesktopTop;
SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,
SWP_SHOWWINDOW or SWP_NOACTIVATE);
Invalidate;
finally
FActivating := False;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
HintWindowClass := TGraphicHintWindow;
Application.ShowHint := False;
Application.ShowHint := True;
end;
Взято с сайта
Как сделать greyscale dithering?
Как сделать greyscale dithering?
procedureGreyscale(dib8, dib24: TFastDIB; Colors: Byte);
type
TDiv3 = array[0..767] of Byte;
TScale = array[0..255] of Byte;
TLineErrors = array[-1.. - 1] of DWord;
PDiv3 = ^TDiv3;
PScale = ^TScale;
PLineErrors = ^TLineErrors;
var
x, y, i, Ln, Nxt: Integer;
pc: PFColor;
pb: PByte;
Lines: array[0..1] of PLineErrors;
Div3: PDiv3;
Scale: PScale;
pti: PDWord;
dir: ShortInt;
begin
dib8.FillColors(0, Colors, tfBlack, tfWhite);
New(Div3);
pb := Pointer(Div3);
for i := 0 to 255 do
begin
pb^ := i;
Inc(pb);
pb^ := i;
Inc(pb);
pb^ := i;
Inc(pb);
end;
New(Scale);
pb := Pointer(Scale);
x := (Colors shl 16) shr 8;
y := x;
for i := 0 to 255 do
begin
pb^ := y shr 16;
Inc(y, x);
Inc(pb);
end;
GetMem(Lines[0], 24 * (dib24.Width + 2));
GetMem(Lines[1], 24 * (dib24.Width + 2));
pc := PFColor(dib24.Bits);
for x := 0 to dib24.Width - 1 do
begin
Lines[0, x] := Div3[pc.r + pc.g + pc.b] * 16;
Inc(pc);
end;
pc := Ptr(Integer(pc) + dib24.Gap);
dir := 1;
for y := 1 to dib24.Height do
begin
Nxt := y mod 2;
Ln := 1 - Nxt;
if y < dib24.Height then
begin
for x := 0 to dib24.Width - 1 do
begin
Lines[Nxt, x] := Div3[pc.r + pc.g + pc.b] * 16;
Inc(pc);
end;
pc := Ptr(Integer(pc) + dib24.Gap);
end;
x := 0;
if dir = -1 then
x := dib24.Width - 1;
pti := @Lines[Ln, x];
pb := @dib8.Pixels8[y - 1, x];
while ((x > -1) and (x < dib24.Width)) do
begin
pti^ := pti^ div 16;
if pti^ > 255 then
pti^ := 255
else if pti^ < 0 then
pti^ := 0;
pb^ := Scale[pti^];
i := pti^ - dib8.Colors[pb^].r;
if i <> 0 then
begin
Inc(Lines[Ln, x + dir], i * 7);
Inc(Lines[Nxt, x - dir], i * 3);
Inc(Lines[Nxt, x], i * 5);
Inc(Lines[Nxt, x + dir], i);
end;
Inc(pb, dir);
Inc(pti, dir);
Inc(x, dir);
end;
Inc(pb, dib8.Gap);
dir := -dir;
end;
Dispose(Lines[0]);
Dispose(Lines[1]);
Dispose(Scale);
Dispose(Div3);
end;
Взято с
Delphi Knowledge BaseКак сделать экспорт TDataSet в XML file?
Как сделать экспорт TDataSet в XML file?
{Unit to export a dataset to XML}
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.
//Beispiel, Example:
uses DS2XML;
procedure TForm1.Button1Click(Sender: TObject);
begin DatasetToXML(Table1, 'test.xml');
end;
Взято с сайта
Как сделать картинки из TImageList прозрачными?
Как сделать картинки из TImageList прозрачными?
procedure TForm1.Button1Click(Sender: TObject);
var
bm: TBitmap;
il: TImageList;
begin
bm := TBitmap.Create;
bm.LoadFromFile('C:\DownLoad\TEST.BMP');
il := TImageList.CreateSize(bm.Width, bm.Height);
il.DrawingStyle := dsTransparent;
il.Masked := true;
il.AddMasked(bm, clRed);
il.Draw(Form1.Canvas, 0, 0, 0);
bm.Free;
il.Free;
end;
Как сделать MDI-приложение, где сливаются меню дочернего и главного окна, и полосы инструментов?
Как сделать MDI-приложение, где сливаются меню дочернего и главного окна, и полосы инструментов?
Ваpиант 1. CoolBar.
procedureTMainForm.SetBands(AControls: array of TWinControl;
ABreaks: array of boolean);
var
i: integer;
begin
with CoolBar do
begin
for i:=0 to High(AControls) do
begin
if Bands.Count=succ(i) then
TCoolBand.Create(Bands);
with Bands[succ(i)] do
begin
if Assigned(Control) then
Control.Hide;
MinHeight:=AControls[i].Height;
Break:=ABreaks[i];
Control:=AControls[i];
Control.Show;
Visible:=true;
end
end;
for i:=High(AControls)+2 to pred(Bands.Count) do
Bands[i].Free
end
end;
и
procedure TMsgForm.FormActivate(Sender: TObject);
begin
MainForm.SetBands([ToolBar],[false])
end;
Пpимечание:
Оба массива pавны по длине. CoolBar.Bands[0] должен существовать всегда,.. на нём я pазмешаю "глобальные" кнопки. СoolBar[1] тоже можно сделать в DesignTime с Break:=false и пpидвинуть поближе с началу. Пpи CoolBar.AutoSize:=true возможно "мигании" (пpи добавлении на новую стpоку) так что можно добавить:
AutoSize := false;
try
...
finally
AutoSize := true;
TMainForm
...
object SpeedBar: TPanel
...
Align = alTop
BevelOuter = bvNone
object ToolBar: TPanel
...
Align = alLeft
BevelOuter = bvNone
end
object RxSplitter1: TRxSplitter
...
ControlFirst = ToolBar
ControlSecond = ChildBar
Align = alLeft
BevelOuter = bvLowered
end
object ChildBar: TPanel
...
Align = alClient
BevelOuter = bvNone
end
end
TMdiChild {пpородитель всех остальных}
...
object pnToolBar: TPanel
...
Align = alTop
BevelOuter = bvNone
Visible = False
end
procedure TMDIForm.FormActivate(Sender: TObject);
begin
pnToolBar.Parent := MainForm.ChildBar;
pnToolBar.Visible := True;
end;
procedure TMDIForm.FormDeactivate(Sender: TObject);
begin
pnToolBar.Visible := false;
pnToolBar.Parent := self
end;
Взято с
Как сделать Memo с закруглёнными краями?
Как сделать Memo с закруглёнными краями?
procedureTForm1.Button1Click(Sender: TObject);
var
rgn: HRGN;
r: TRect;
begin
r := memo1.ClientRect;
rgn := CreateRoundRectRgn(r.Left, r.top, r.right, r.bottom, 20, 20);
memo1.BorderStyle := bsNone;
memo1.Perform(EM_GETRECT, 0, lparam(@r));
InflateRect(r, -5, -5);
memo1.Perform(EM_SETRECTNP, 0, lparam(@r));
SetWindowRgn(memo1.Handle, rgn, true);
end;
Взято с
Delphi Knowledge BaseКак сделать меню как в Дельфи?
Как сделать меню как в Дельфи?
1. Разместите на форме TControlBar. (закладка Additional) Установите Align = Client.
2. Разместите TToolBar (закладка Win32) внутри TControlBar.
3. Установите в True свойства Flat и ShowCaptions этого TToolBar.
4. Создайте на TToolBar столько TToolButtons сколько Вам нужно. (щелкнув по TToolBar
правой кнопкой и выбрав NewButton)
5. Установите свойство Grouped = True для всех TToolButtons. Это позволит меню выпадать
при перемещении курсора между главными пунктами меню (если меню уже показано).
6. Разместите на фоме TMainMenu и убедитесь, что оно *НЕ присоденено* как меню главной
формы. (посмотрите свойство Menu формы).
7. Создайте все пункты меню (щелкнув по TMainMenu кнопкой и выбрав Menu Designer)
8. Для каждой TToolButton установите ее MenuItem равным соответсвующему пункту TMainMenu.
Взято из
DELPHI VCL FAQ
Перевод с английского Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для
Как сделать многострочную надпись на TBitBtn?
Как сделать многострочную надпись на TBitBtn?
Выводите текст надписи непосредственно на "glyph" TBitBtn'а
procedure TForm1.FormCreate(Sender: TObject);
var
R: TRect;
N: Integer;
Buff: array[0..255] of Char;
begin
with BitBtn1 do
begin
Caption := 'A really really long caption';
Glyph.Canvas.Font := Self.Font;
Glyph.Width := Width - 6;
Glyph.Height := Height - 6;
R := Bounds(0, 0, Glyph.Width, 0);
StrPCopy(Buff, Caption);
Caption := '';
DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R,
DT_CENTER or DT_WORDBREAK or DT_CALCRECT);
OffsetRect(R, (Glyph.Width - R.Right) div 2,
(Glyph.Height - R.Bottom) div 2);
DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R,
DT_CENTER or DT_WORDBREAK);
end;
end;
Как сделать mount?
Как сделать mount?
{
The following example shows a Linux-Console application, which mount
the floppy.
}
program Project1;
{$APPTYPE CONSOLE}
uses
Libc;
begin
if mount('/dev/fd0', '/mnt/floppy', 'vfat', MS_RDONLY, nil) = -1 then
WriteLn('Mount return : ', Errno, '(', strerror(errno), ')')
else
WriteLn('Floppy mounted');
end.
Взято с сайта
