nyuuzyou/wikis huggingface dataset:
Как упаковать таблицу?

=== Как упаковать таблицу? ===
uses BDE; // for D3, для D2 не помню (что-то типа DbiProcs и еще что-то)
var
 // для примеpа
 tLog: TTable; // таблица, юзающая d:\db\log.db
var
 TblDesc: CRTblDesc;
 rslt: DBIResult;
 Dir: string; // имеется в виду huge string т.е. {$H+}
 hDb: hDbiDb;
begin
 tLog.Active := False; // деактивиpуем TTable
 SetLength(Dir, dbiMaxNameLen + 1);
 DbiGetDirectory(tLog.DBHandle, False, PChar(Dir));
 SetLength(Dir, StrLen(PChar(Dir)));
 DbiOpenDatabase(nil, nil, dbiReadWrite, dbiOpenExcl, nil, 0, nil, nil, hDb);
 DbiSetDirectory(hDb, PChar(Dir));
 FillChar(TblDesc, sizeof(CRTblDesc), 0);
 StrPCopy(TblDesc.szTblName, 'd:\db\log.db');
 // здесь должно быть полное имя файла
 // которое можно: а) ввести руками;
 // б) вытащить из пропертей таблицы;
 // в) вытащить из алиаса;
 // г) см. FAQ
 StrCopy(TblDesc.szTblType, szParadox);
 // BTW тут может и szDBase стоять
 TblDesc.bPack := TRUE;
 DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False);
 DbiCloseDatabase(hDb);
end;
Author: Pavel Kulchenko 
Source: Взято с http://delphiworld.narod.ru
ID: 02951
Category:Базы данных
Category:Paradox
Как управлять сервисом на другом компьютере в W2K?

=== Как управлять сервисом на другом компьютере в W2K? ===
Требуется написать управление сервисом, запущенном на другом компьютере. С помощью чего это лучше сделать?
uses
 Windows, Messages, SysUtils,
 StdCtrls, SvcMgr;
var
 ssStatus: TServiceStatus;
 schSCManager, schService: SC_HANDLE;
begin
 schSCManager := OpenSCManager(PChar('Comp1'), // имя компьютера, nil - local machine
 nil, // ServicesActive database
 SC_MANAGER_ALL_ACCESS); // full access rights
 if schSCManager = 0 then exit; // Ошибка?
 schService := OpenService(
 schSCManager, // SCM database
 PChar('SQLServerAgent'), // посмотри имя в Services. В данном случае - MS Server Agent
 SERVICE_ALL_ACCESS);
 if schService = 0 then exit; // Ошибка?
 if not QueryServiceStatus(
 schService, // handle to service
 ssStatus) then // address of status information structure
 exit; // Ошибка?
 case ssStatus.dwCurrentState of
 SERVICE_RUNNING: ShowMessage('Работает!');
 SERVICE_STOPPED: ShowMessage('Выключен');
 // ну и т.д.
 end;
end;
Source: Взято с сайта http://blackman.wp-club.net/
ID: 02231
Как ускорить поиск?

=== Как ускорить поиск? ===
type
 TForm1 = class(TForm)
 DataSource1: TDataSource;
 Table1: TTable;
 Button1: TButton;
 end;
procedure TForm1.Button1Click(Sender: TObject);
var
 SeekValue: string;
begin
 Table1.DisableControls;
 Table1.FindKey([SeekValue]);
 Table1.EnableControls;
end;
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 02643
Как установить драйвер принтера

Приведенный пример устанавливает драйвер принтера. Вам необходимо скопировать файлы с драйвером принтера в каталог Windows\System и внести необходимые изменения в файл Win.Ini.
Примечание:
* DriverName = Имя драйвера;
* DRVFILE - имя файла с драйвером без расширения (".drv" - по умолчанию).
procedure TForm1.Button1Click(Sender: TObject);
var
 s: array [0..64] of Char;
begin
 WriteProfileString('PrinterPorts', 'DriverName', 'DRVFILE,FILE:,15,45');
 WriteProfileString('Devices', 'DriverName', 'DRVFILE,FILE:');
 StrCopy(S, 'PrinterPorts');
 SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
 StrCopy(S, 'Devices');
 SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;
Source: Взято с http://delphiworld.narod.ru
ID: 03222
Category:Принтер
Как установить клиента InterBase

=== Как установить клиента InterBase ===
1. Для Yaffil или FireBird последних билдов - ничего не надо, кроме gds32.dll в директориях поиска библиотек.
2. Для IB5, IB6 или старого FB первых билдов - надо дополнительно прописать в файле services строчку "gds_db 3050/tcp" {файл должен завершаться пустую строкой}.
3. Для IB5, дополнительно к п.2., добавить в ключ реестра:
 HKLM\SOFTWARE\InterBase Corp\InterBase\CurrentVersion\RootDirectory
строковое значение - имя папки, в которой лежит файл ib_license.dat
4. В случае медленного подключения клиентов в сети TCP/IP попробуйте прописать адреса IB серверов в файле HOSTS.
Source: Взято с http://delphiworld.narod.ru
ID: 02894
Category:Базы данных
Category:Interbase
Как установить компонент от другой версии, если имеется только .DCU файл?

=== Как установить компонент от другой версии, если имеется только .DCU файл? ===
Никак. DCU файлы разных версий Дельфи несовместимы. Нужны либо исходники компонентов, либо надо просить у разработчика компиляцию для текущей версии Дельфи.
ID: 00351
Как установить минимальный размер окна?

=== Как установить минимальный размер окна? ===
Необходимо объявить обработчик события для WM_GETMINMAXINFO:
private 
 procedure WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo); message WM_GETMINMAXINFO; 
// А вот как выглядит сам обработчик:
procedure TForm1.WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo); 
begin 
 Message.MinMaxInfo^.ptMinTrackSize := Point(Width, Height); 
 Message.MinMaxInfo^.ptMaxTrackSize := Point(Width, Height); 
end; 
Примечание от Vit:
Начиная с Дельфи 5 появилось удобное свойство Constrains - специально для ограничесния минимальных и максимальных размеров...
Source: Взято из http://forum.sources.ru
ID: 00414
Как установить обои в формате jpeg?

=== Как установить обои в формате jpeg? ===
Как установить обои в формате jpeg.
SystemParametersInfo только для bmp.
uses
 ComObj, ShlObj;
procedure ChangeActiveWallpaper;
const
 CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
var
 ActiveDesktop: IActiveDesktop;
begin
 ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
 ActiveDesktop.SetWallpaper('c:\windows\forest.jpg', 0);
 ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
end;
Author: Vasya2000
Source: Взято из http://forum.sources.ru
ID: 01828
Как установить переменные окружения?

=== Как установить переменные окружения? ===
Следующая простая подпрограмма создаёт новые значения в переменных окружения. Если переменной окружения не существует, то она создаётся. Если переменной окружения установить значение пустой строки, то переменная удаляется. Функция возвращает 0, если значение переменной установлено или переменная создана успешно, либо возвратит значение ошибки Windows в случае неудачи. Обратите внимание, что размер пространства доступного для переменных окружения ограничен.
function SetEnvVarValue(const VarName, VarValue: string): Integer;
begin
 // Просто вызываем API функцию
 if Windows.SetEnvironmentVariable(PChar(VarName), PChar(VarValue)) then
 Result := 0
 else
 Result := GetLastError;
end;
ЗАМЕЧАНИЕ: данный способ позволяет делать изменения в переменных окружения только для текущего процесса либо для дочерних процессов, порождённых текущим.
Для того, чтобы передать какую-либо переменную окружения в дочерний процесс просто:
1) Создайте новую переменную окружения при помощи SetDOSEnvVar.
2) Запустите новую программу.
А вот как выглядит пример передачи текущих переменных окружения + переменной FOO=Bar в дочерний процесс:
var
 ErrCode: Integer;
begin
 ErrCode := SetEnvVarValue('FOO', 'Bar');
 if ErrCode = 0 then
 WinExec('MyChildProg.exe', SW_SHOWNORMAL);
 else
 ShowMessage(SysErrorMessage(ErrCode));
end;
Source: Взято из http://forum.sources.ru
ID: 02209
----
{*********************************************}
{ Set Global Environment Function }
{ Coder : Kingron,2002.8.6 }
{ Bug Report : Kingron@163.net }
{ Test OK For Windows 2000 Advance Server }
{ Parameter: }
{ Name : environment variable name }
{ Value: environment variable Value }
{ Ex: SetGlobalEnvironment('MyVar','OK') }
{*********************************************}
function SetGlobalEnvironment(const Name, Value: string;
 const User: Boolean = True): Boolean;
resourcestring
 REG_MACHINE_LOCATION = 'System\CurrentControlSet\Control\Session Manager\Environment';
 REG_USER_LOCATION = 'Environment';
begin
 with TRegistry.Create do
 try
 if User then { User Environment Variable }
 Result := OpenKey(REG_USER_LOCATION, True)
 else { System Environment Variable }
 begin
 RootKey := HKEY_LOCAL_MACHINE;
 Result := OpenKey(REG_MACHINE_LOCATION, True);
 end;
 if Result then
 begin
 WriteString(Name, Value); { Write Registry for Global Environment }
 { Update Current Process Environment Variable }
 SetEnvironmentVariable(PChar(Name), PChar(Value));
 { Send Message To All Top Window for Refresh }
 SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, Integer(PChar('Environment')));
 end;
 finally
 Free;
 end;
end; { SetGlobalEnvironment }
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 02210
Как установить разрешение экрана?

=== Как установить разрешение экрана? ===
ChangeDisplaySettings()
Source: Взято с Vingrad.ru http://forum.vingrad.ru
ID: 01447
----
function SetFullscreenMode: Boolean;
var
 DeviceMode: TDevMode;
begin
 with DeviceMode do
 begin
 dmSize := SizeOf(DeviceMode);
 dmBitsPerPel := 16;
 dmPelsWidth := 640;
 dmPelsHeight := 480;
 dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
 Result := False;
 if ChangeDisplaySettings(DeviceMode, CDS_TEST or CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL then
 Exit;
 Result := ChangeDisplaySettings(DeviceMode, CDS_FULLSCREEN) = DISP_CHANGE_SUCCESSFUL;
 end;
end;
procedure RestoreDefaultMode;
var
 T: TDevMode absolute 0;
begin
 ChangeDisplaySettings(T, CDS_FULLSCREEN);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 if setFullScreenMode then
 begin
 sleep(7000);
 RestoreDefaultMode;
 end;
end;
Author: Зайцев О.В., Владимиров А.М.
Source: Взято из http://forum.sources.ru
ID: 01448
----
procedure ChangeDisplayResolution(x, y: word);
var
 dm: TDEVMODE;
begin
 ZeroMemory(@dm, sizeof(TDEVMODE));
 dm.dmSize := sizeof(TDEVMODE);
 dm.dmPelsWidth := x;
 dm.dmPelsHeight := y;
 dm.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
 ChangeDisplaySettings(dm, 0);
end;
Source: http://delphiworld.narod.ru/
ID: 01449
Как установить фокус на документе в TWebBrowser ?

WebBrowser1.SetFocus ставит фокус на компонент TWebBrowser, а это не всегда то, что нужно. Если нужно поставить фокус на документ в TWebBrowser'е (чтобы, например, кнопки вверх/вниз скроллировали документ, а не ставили фокус на другой компонент), то можно использовать этот код:
uses ActiveX;
with WebBrowser1 do
 if Document <> nil then
 with Application as IOleobject do
 DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser1, 0, Handle, GetClientRect);
Author: p0s0l
Source: Vingrad.ru http://forum.vingrad.ru
ID: 03475
Category:Связь
Category:WebBrowser
Как установить цвет фона иконок на рабочем столе, либо сделать у них прозрачный фон?

=== Как установить цвет фона иконок на рабочем столе, либо сделать у них прозрачный фон? ===
Для этого нужно найти окно "SysListView32" (которое является списком, который содержит иконки рабочего стола). Сперва будем искать главное родительское окно "Progman", которое содержит дочернее окно "SHELLDLL_DefView" , которое в свою очередь имеет дочернее окно "SysListView32". Для этого можно воспользоваться API функцией FindWindow to. Когда Мы получим дескриптор окна "SysListView32", то можно будет воспользоваться макросами ListView_SetTextBkColor и ListView_SetTextColor для установки желаемого цвета.
Ниже приведена процедура, которая делает всё вышеперечисленное. Если параметр Trans равен true, то будет установлен прозрачный фон, иначе цвет фона будет равен Background.
unit DeskIcons;
interface
uses Graphics; // Будет использоваться TColor
procedure SetDesktopIconColor(Forground, Background: TColor; Trans: Boolean);
procedure SetDefaultIconColors;
implementation
uses Windows, CommCtrl; // будут использоваться HWND и ListView_XXXXX
procedure SetDesktopIconColor(Forground, Background: TColor; Trans: Boolean);
var
 Window: HWND;
begin
 // Находим нужное окно в три этапа
 Window := FindWindow('Progman', 'Program Manager');
 // Используем FindWindowEx для нахождения дочернего окна
 Window := FindWindowEx(Window, HWND(nil), 'SHELLDLL_DefView', );
 // SysListView32, это список с иконками на рабочем столе
 Window := FindWindowEx(Window, HWND(nil), 'SysListView32', );
 // Используем макрос для очистки цвета фона
 if Trans then
 ListView_SetTextBkColor(Window, $ffffffff) // фоновый цвет
 else
 ListView_SetTextBkColor(Window, Background); // фоновый цвет
 ListView_SetTextColor(Window, Forground); // передний цвет
 // теперь перерисовываем иконки
 ListView_RedrawItems(Window, 0, ListView_GetItemCount(Window) - 1);
 UpdateWindow(Window); // даём команду "немедленно перерисовать"
end;
procedure SetDefaultIconColors;
{ Эта процедура устанавливает цвета, которые заданы в windows по умолчанию }
var
 Kind: Integer;
 Color: TColor;
begin
 Kind := COLOR_DESKTOP;
 Color := GetSysColor(COLOR_DESKTOP);
 SetSysColors(1, Kind, Color);
end;
end.
Source: Взято из http://forum.sources.ru
ID: 01823
Как хранятся строки?

=== Как хранятся строки? ===
Тип String:
* по смещению -4 храниться длина строки
* по смещению -8 храниться счётчик ссылок на строку (когда он обнуляется строка уничтожается)
Сама строка располагается в памяти как есть - каждая буква занимает 1 байт.
При копировании строки:
 s1 := s2
реального копирования не происходит, увеличивается только счётчик ссылок, но если после этого изменить одну из строк:
 s1 := s1 + 'a';
то произойдёт физическое копирование содержимого строк, и теперь s1 и s2 будут показывать на разные адреса памяти.
PChar - длина строки определяется от начала до #0 байта, по сути это чистой воды pointer, так что все действия по 
отслеживанию распределения памяти лежат на программисте - сами заботьтесь о том чтобы хватило места для распределения памяти и 
освобождении после использования. Тоже одна буква = 1 байт Для хранения unicode (т.е. 2х байтовых символов) используйте 
соответствующие символы с приставкой Wide... 
Примечание Fantasist'a:
Это верно только если s1 - локальная переменная, или s1 и s2 - обе не локальные. Если s1 не локальная(глобальная или член класса), а s2 - локальная происходит копирование. 
Author: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)
Source: Взято с Vingrad.ru http://forum.vingrad.ru
ID: 00136
Как читать/писать в I/O порты?

=== Как читать/писать в I/O порты? ===
В Delphi 1 записывать и считывать из портов можно через глобальный массив 'ports'. Однако данная возможность отсутствует в '32-битном' Delphi.
Следующие две функции можно использовать в любой версии delphi:
function InPort(PortAddr:word): byte; 
{$IFDEF WIN32} 
assembler; stdcall; 
asm 
 mov dx,PortAddr 
 in al,dx 
end; 
{$ELSE} 
begin 
 Result := Port[PortAddr]; 
end; 
{$ENDIF} 
procedure OutPort(PortAddr: 
 word; Databyte: byte); 
{$IFDEF WIN32} 
assembler; stdcall; 
asm 
 mov al,Databyte 
 mov dx,PortAddr 
 out dx,al 
end; 
{$ELSE} 
begin 
 Port[PortAddr] := DataByte; 
end; 
{$ENDIF} 
Source: Взято из http://forum.sources.ru
ID: 01339
Как шифровать файлы при помощи windows NTFS API

{
This tip works with Windows 2000 (NTFS 5) and later
These 2 functions are defined in windows.pas, but they're defined wrong. In this
case our own definition.
}
function EncryptFile(lpFilename: PChar): BOOL; stdcall;
 external advapi32 name 'EncryptFileA';
function DecryptFile(lpFilename: PChar; dwReserved: DWORD): BOOL; stdcall;
 external advapi32 name 'DecryptFileA';
{....}
procedure TForm1.Button1Click(Sender: TObject);
begin
 if not EncryptFile('c:\temp') then
 ShowMessage('Cannot encrypt directory.');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
 if not DecryptFile('c:\temp', 0) then
 ShowMessage('Cannot decrypt directory.');
end;
Source: http://www.swissdelphicenter.ch
ID: 04016
Category:Алгоритмы
Category:Шифрование
Как экспортировать StringGrid в MS Word таблицу?

uses
 ComObj;
procedure TForm1.Button1Click(Sender: TObject);
var
 WordApp, NewDoc, WordTable: OLEVariant;
 iRows, iCols, iGridRows, jGridCols: Integer;
begin
 try
 // Create a Word Instance
 // Word Instanz erzeugen
 WordApp := CreateOleObject('Word.Application');
 except
 // Error...
 // Fehler....
 Exit;
 end;
 // Show Word
 // Word anzeigen
 WordApp.Visible := True;
 // Add a new Doc
 // Neues Dok einfugen
 NewDoc := WordApp.Documents.Add;
 // Get number of columns, rows
 // Spalten, Reihen ermitteln
 iCols := StringGrid1.ColCount;
 iRows := StringGrid1.RowCount;
 // Add a Table
 // Tabelle einfugen
 WordTable := NewDoc.Tables.Add(WordApp.Selection.Range, iCols, iRows);
 // Fill up the word table with the Stringgrid contents
 // Tabelle ausfullen mit Stringgrid Daten
 for iGridRows := 1 to iRows do
 for jGridCols := 1 to iCols do
 WordTable.Cell(iGridRows, jGridCols).Range.Text :=
 StringGrid1.Cells[jGridCols - 1, iGridRows - 1];
 // Here you might want to Save the Doc, quit Word...
 // Hier evtl Word Doc speichern, beenden...
 // ...
 // Cleanup...
 WordApp := Unassigned;
 NewDoc := Unassigned;
 WordTable := Unassigned;
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04411
Category:COM
Category:MS Office
Как экспортировать все таблицы в CSV файл?

=== Как экспортировать все таблицы в CSV файл? ===
procedure TMainForm.SaveAllTablesToCSV(DBFileName: string);
var
 InfoStr, FileName, RecString, WorkingDirectory: string;
 OutFileList, TableNameList: TStringList;
 TableNum, FieldNum: Integer;
 VT: TVarType;
begin
 ADOTable1.Active := False;
 WorkingDirectory := ExtractFileDir(DBFileName);
 TableNameList := TStringList.Create;
 OutFileList := TStringList.Create;
 InfoStr := 'The following files were created' + #13#13;
 ADOConnection1.GetTableNames(TableNameList, False);
 for TableNum := 0 to TableNameList.Count - 1 do
 begin
 FileName := WorkingDirectory + '\' +
 TableNameList.Strings[TableNum] + '.CSV';
 Caption := 'Saving "' + ExtractFileName(FileName) + '"';
 ADOTable1.TableName := TableNameList.Strings[TableNum];
 ADOTable1.Active := True;
 OutFileList.Clear;
 ADOTable1.First;
 while not ADOTable1.Eof do
 begin
 RecString := ;
 for FieldNum := 0 to ADOTable1.FieldCount - 1 do
 begin
 VT := VarType(ADOTable1.Fields[FieldNum].Value);
 case VT of
 // just write the field if not a string
 vtInteger, vtExtended, vtCurrency, vtInt64:
 RecString := RecString + ADOTable1.Fields[FieldNum].AsString
 else
 // it IS a string so put quotes around it
 RecString := RecString + '"' +
 ADOTable1.Fields[FieldNum].AsString + '"';
 end; { case }
 // if not the last field then use a field separator
 if FieldNum < (ADOTable1.FieldCount - 1) then
 RecString := RecString + ',';
 end; { for FieldNum }
 OutFileList.Add(RecString);
 ADOTable1.Next;
 end; { while }
 OutFileList.SaveToFile(FileName);
 InfoStr := InfoStr + FileName + #13;
 ADOTable1.Active := false;
 end; { for TableNum }
 TableNameList.Free;
 OutFileList.Free;
 Caption := 'Done';
 ShowMessage(InfoStr);
end;
procedure TMainForm.Button1Click(Sender: TObject);
const
 ConnStrA = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=';
 ConnStrC = ';Persist Security Info=False';
 ProvStr = 'Microsoft.Jet.OLEDB.4.0';
begin
 OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));
 if OpenDialog1.Execute then
 try
 ADOConnection1.ConnectionString :=
 ConnStrA + OpenDialog1.FileName + ConnStrC;
 ADOConnection1.Provider := ProvStr;
 ADOConnection1.Connected := true;
 ADOTable1.Connection := ADOConnection1;
 SaveAllTablesToCSV(OpenDialog1.FileName);
 except
 ShowMessage('Could not Connect to ' + #13 +
 '"' + OpenDialog1.FileName + '"');
 Close;
 end;
end;
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 02765
Как экспортировать процедуру в EXE файле

В DPR файле совершенно обычного проекта Delphi можно указать функцию (процедуру) и объявить ее как экспортируемую - синтаксис точно такой-же как при создании стандартной DLL. С таким довеском EXE совершенно нормально компилируется и работает и как EXE и как DLL (т.е. из нее можно импортировать описанные функции). Зачем это нужно? Была одна задача - делал консоль которая связывала воедино несколько приложений, так экспортные функции позволяли существенно расширять функциональность комплекса. Правда такой EXE все же имеет недостаток - EXE упаковщики сохраняют исполняемую часть и неправильно упаковывают экспортированную... Кроме того могут быть проблемы передачи строковых параметров.
Author: Vit
Source: Vingrad.ru http://forum.vingrad.ru
ID: 04569
Category:Разработка приложений
Как экспортировать содержимое DBGrid в Excel или ClipBoard?

=== Как экспортировать содержимое DBGrid в Excel или ClipBoard? ===
Пример dbgrid (DBGrid1) имеет всплывающее меню, которое позволяет две опции "Send to Excel" и "Copy"
// ЗАМЕЧАНИЕ: этот метод должен включать COMObj, Excel97 units
// ОБНОВЛЕНИЕ: если Вы используете Delphi 4, то замените xlWBatWorkSheet на 1 (один)
//-----------------------------------------------------------
// если toExcel = false, то экспортируем содержимое dbgrid в Clipboard
// если toExcel = true, то экспортируем содержимое dbgrid в Microsoft Excel
procedure ExportDBGrid(toExcel: Boolean);
var
 bm: TBookmark;
 col, row: Integer;
 sline: String;
 mem: TMemo;
 ExcelApp: Variant;
begin
 Screen.Cursor := crHourglass;
 DBGrid1.DataSource.DataSet.DisableControls;
 bm := DBGrid1.DataSource.DataSet.GetBookmark;
 DBGrid1.DataSource.DataSet.First;
 // создаём объект Excel
 if toExcel then
 begin
 ExcelApp := CreateOleObject('Excel.Application');
 ExcelApp.WorkBooks.Add(xlWBatWorkSheet);
 ExcelApp.WorkBooks[1].WorkSheets[1].Name := 'Grid Data';
 end;
 // Сперва отправляем данные в memo
 // работает быстрее, чем отправлять их напрямую в Excel
 mem := TMemo.Create(Self);
 mem.Visible := false;
 mem.Parent := MainForm;
 mem.Clear;
 sline := ;
 // добавляем информацию для имён колонок
 for col := 0 to DBGrid1.FieldCount-1 do
 sline := sline + DBGrid1.Fields[col].DisplayLabel + #9;
 mem.Lines.Add(sline);
 // получаем данные из memo
 for row := 0 to DBGrid1.DataSource.DataSet.RecordCount-1 do
 begin
 sline := ;
 for col := 0 to DBGrid1.FieldCount-1 do
 sline := sline + DBGrid1.Fields[col].AsString + #9;
 mem.Lines.Add(sline);
 DBGrid1.DataSource.DataSet.Next;
 end;
 // копируем данные в clipboard
 mem.SelectAll;
 mem.CopyToClipboard;
 // если необходимо, то отправляем их в Excel
 // если нет, то они уже в буфере обмена
 if toExcel then
 begin
 ExcelApp.Workbooks[1].WorkSheets['Grid Data'].Paste;
 ExcelApp.Visible := true;
 end;
 FreeAndNil(ExcelApp);
 DBGrid1.DataSource.DataSet.GotoBookmark(bm);
 DBGrid1.DataSource.DataSet.FreeBookmark(bm);
 DBGrid1.DataSource.DataSet.EnableControls;
 Screen.Cursor := crDefault;
end;
Source: Взято из http://forum.sources.ru
ID: 03030
Category:Базы данных
Category:DBGrid
Как экспортировать таблицу базы данных в ASCII-файл?

=== Как экспортировать таблицу базы данных в ASCII-файл? ===
procedure TMyTable.ExportToASCII;
var
 I: Integer;
 Dlg: TSaveDialog;
 ASCIIFile: TextFile;
 Res: Boolean;
begin
 if Active then
 begin
 MessageDlg('Таблица должна быть открытой, чтобы данные '+
 'можно было экспортировать в ASCII-формат.', mtError,
 [mbOK], 0);
 Exit;
 end;
 
 if (FieldCount = 0) or (RecordCount = 0) then
 begin
 MessageDlg('Нет данных для экспортирования.',
 mtInformation, [mbOK], 0);
 Exit;
 end;
 Dlg := TSaveDialog.Create(Application);
 Dlg.FileName := FASCIIFileName;
 Dlg.Filter := 'ASCII-Fiels (*.asc)|*.asc';
 Dlg.Options := Dlg.Options+[ofPathMustExist,
 ofOverwritePrompt, ofHideReadOnly];
 Dlg.Title := 'Экспоритровать данные в ASCII-файл';
 try
 Res := Dlg.Execute;
 if Res then
 FASCIIFileName := Dlg.FileName;
 finally
 Dlg.Free;
 end;
 if Res then
 begin
 AssignFile(ASCIIFile, FASCIIFileName);
 Rewrite(ASCIIFile);
 First;
 if FASCIIFieldNames then
 begin
 for I := 0 to FieldCount-1 do
 begin
 Write(ASCIIFile, Fields[I].FieldName);
 if I <> FieldCount-1 then
 Write(ASCIIFile, FASCIISeparator);
 end;
 Write(ASCIIFile, #13#10);
 end;
 while not EOF do
 begin
 for I := 0 to FieldCount-1 do
 begin
 Write(ASCIIFile, Fields[I].Text);
 if I <> FieldCount-1 then
 Write(ASCIIFile, FASCIISeparator);
 end;
 Next;
 if not EOF then
 Write(ASCIIFile, #13#10);
 end;
 CloseFile(ASCIIFile);
 if IOResult <> 0 then
 MessageDlg('Ошибка при создании или переписывании '+
 'в ASCII-файл', mtError, [mbOK], 0);
 end;
end;
ID: 02971
Category:Базы данных
Category:CSV