صفحه 2 از 11 اولاول 1234 ... آخرآخر
نمایش نتایج 41 تا 80 از 435

نام تاپیک: نکات برنامه نویسی در دلفی

  1. #41
    لیست تمام فایلهای موجود در یک دایرکتوری
    procedure ListFileDir(Path: string; FileList: TStrings);
    var
    SR: TSearchRec;
    begin
    if FindFirst(Path + '*.*', faAnyFile, SR) = 0 then
    begin
    repeat
    if (SR.Attr <> faDirectory) then
    begin
    FileList.Add(SR.Name);
    end;
    until FindNext(SR) <> 0;
    FindClose(SR);
    end;
    end;

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    ListFileDir('C:\WINDOWS\', ListBox1.Items);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:16 عصر

  2. #42
    نصب یک فایل INF در دلفی
    uses
    ShellAPI;

    function InstallINF(const PathName: string; hParent: HWND): Boolean;
    var
    instance: HINST;
    begin
    instance := ShellExecute(hParent,
    PChar('open'),
    PChar('rundll32.exe'),
    PChar('setupapi,InstallHinfSection DefaultInstall 132 ' + PathName),
    nil,
    SW_HIDE);

    Result := instance > 32;
    end; {/ InstallINF /}

    // Example:

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    InstallINF('C:\XYZ.inf', 0);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:17 عصر

  3. #43
    دسترسی به ListBox از طریق API
    function LB_GetItemCount(hListBox: THandle): Integer;
    begin
    Result := SendMessage(hListBox, LB_GETCOUNT, 0, 0);
    end;

    // Delete a string in a ListBox
    // Einen String in einer ListBox l&ouml;schen

    procedure LB_DeleteItem(hListBox: THandle; Index: Integer);
    begin
    SendMessage(hListBox, LB_DELETESTRING, Index, 0);
    end;

    // Retrieve the selected item from a ListBox
    // Gibt den Text des markiertes Items einer ListBox zurück

    function LB_GetSelectedItem(hListBox: THandle): string;
    var
    Index, len: Integer;
    s: string;
    buffer: PChar;
    begin
    Index := SendMessage(hListBox, LB_GETCURSEL, 0, 0);
    len := SendMessage(hListBox, LB_GETTEXTLEN, wParam(Index), 0);
    GetMem(buffer, len + 1);
    SendMessage(hListBox, LB_GETTEXT, wParam(Index), lParam(buffer));
    SetString(s, buffer, len);
    FreeMem(buffer);
    Result := IntToStr(Index) + ' : ' + s;
    end;

    // Example, Beispiel:

    procedure TForm1.Button1Click(Sender: TObject);
    var
    hListBox: THandle;
    begin
    hListBox := {/.../}; // listbox handle
    ListBox1.Items.Text := LB_GetSelectedItem(hListBox);
    end;

    // Retrieve a string from a ListBox
    // Gibt den Text eines bestimmten Items einer ListBox zurück

    function LB_GetListBoxItem(hWnd: Hwnd; LbItem: Integer): string;
    var
    l: Integer;
    buffer: PChar;
    begin
    l := SendMessage(hWnd, LB_GETTEXTLEN, LbItem, 0);
    GetMem(buffer, l + 1);
    SendMessage(hWnd, LB_GETTEXT, LbItem, Integer(buffer));
    Result := StrPas(buffer);
    FreeMem(buffer);
    end;

    // Example, Beispiel:

    procedure TForm1.Button2Click(Sender: TObject);
    var
    hListBox: THandle;
    begin
    hListBox := {/.../}; // listbox handle
    ListBox1.Items.Text := LB_GetListBoxItem(hListBox, 2);
    end;

    // Gibt den gesamten Text einer ListBox zurück
    // Retrieve all listbox items

    function LB_GetAllItems(hWnd: Hwnd; sl: TStrings): string;
    var
    RetBuffer: string;
    i, x, y: Integer;
    begin
    x := SendMessage(hWnd, LB_GETCOUNT, 0, 0);
    for i := 0 to x - 1 do
    begin
    y := SendMessage(hWnd, LB_GETTEXTLEN, i, 0);
    SetLength(RetBuffer, y);
    SendMessage(hWnd, LB_GETTEXT, i, lParam(PChar(RetBuffer)));
    sl.Add(RetBuffer);
    end;
    end;

    // Example, Beispiel:

    procedure TForm1.Button3Click(Sender: TObject);
    var
    sl: TStringList;
    ListBox_Handle: THandle;
    begin
    hListBox := {/.../}; // listbox handle
    sl := TStringList.Create;
    try
    LB_GetAllItems(ListBox_Handle, sl);
    finally
    ListBox1.Items.Text := sl.Text;
    sl.Free;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:17 عصر

  4. #44
    لیست تمام زیرپوشه های یک پوشه اصلی
    procedure GetSubDirs(const sRootDir: string; slt: TStrings);
    var
    srSearch: TSearchRec;
    sSearchPath: string;
    sltSub: TStrings;
    i: Integer;
    begin
    sltSub := TStringList.Create;
    slt.BeginUpdate;
    try
    sSearchPath := AddDirSeparator(sRootDir);
    if FindFirst(sSearchPath + '*', faDirectory, srSearch) = 0 then
    repeat
    if ((srSearch.Attr and faDirectory) = faDirectory) and
    (srSearch.Name <> '.') and
    (srSearch.Name <> '..') then
    begin
    slt.Add(sSearchPath + srSearch.Name);
    sltSub.Add(sSearchPath + srSearch.Name);
    end;
    until (FindNext(srSearch) <> 0);

    FindClose(srSearch);

    for i := 0 to sltSub.Count - 1 do
    GetSubDirs(sltSub.Strings[i], slt);
    finally
    slt.EndUpdate;
    FreeAndNil(sltSub);
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:18 عصر

  5. #45
    جایگزینی یک متن درون TextFile
    procedure FileReplaceString(const FileName, searchstring, replacestring: string);
    var
    fs: TFileStream;
    S: string;
    begin
    fs := TFileStream.Create(FileName, fmOpenread or fmShareDenyNone);
    try
    SetLength(S, fs.Size);
    fs.ReadBuffer(S[1], fs.Size);
    finally
    fs.Free;
    end;
    S := StringReplace(S, SearchString, replaceString, [rfReplaceAll, rfIgnoreCase]);
    fs := TFileStream.Create(FileName, fmCreate);
    try
    fs.WriteBuffer(S[1], Length(S));
    finally
    fs.Free;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:18 عصر

  6. #46
    تغییر نام یک دایرکتوری
    uses
    ShellApi;

    procedure RenameDir(DirFrom, DirTo: string);
    var
    shellinfo: TSHFileOpStruct;
    begin
    with shellinfo do
    begin
    Wnd := 0;
    wFunc := FO_RENAME;
    pFrom := PChar(DirFrom);
    pTo := PChar(DirTo);
    fFlags := FOF_FILESONLY or FOF_ALLOWUNDO or
    FOF_SILENT or FOF_NOCONFIRMATION;
    end;
    SHFileOperation(shellinfo);
    end;


    procedure TForm1.Button1Click(Sender: TObject);
    begin
    RenameDir('C:\Dir1', 'C:\Dir2');
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:18 عصر

  7. #47
    خواندن یک فایل table-textfile درون یک StringGrid
    procedure ReadTabFile(FN: TFileName; FieldSeparator: Char; SG: TStringGrid);
    var
    i: Integer;
    S: string;
    T: string;
    Colonne, ligne: Integer;
    Les_Strings: TStringList;
    CountCols: Integer;
    CountLines: Integer;
    TabPos: Integer;
    StartPos: Integer;
    InitialCol: Integer;
    begin
    Les_Strings := TStringList.Create;
    try
    // Load the file, Datei laden
    Les_Strings.LoadFromFile(FN);

    // Get the number of rows, Anzahl der Zeilen ermitteln
    CountLines := Les_Strings.Count + SG.FixedRows;

    // Get the number of columns, Anzahl der Spalten ermitteln
    T := Les_Strings[0];
    for i := 0 to Length(T) - 1 do Inc(CountCols, Ord(IsDelimiter(FieldSeparator, T, i)));
    Inc(CountCols, 1 + SG.FixedCols);

    // Adjust Grid dimensions, Anpassung der Grid-Gr&ouml;&szlig;e
    if CountLines > SG.RowCount then SG.RowCount := CountLines;
    if CountCols > SG.ColCount then SG.ColCount := CountCols;

    // Initialisierung
    InitialCol := SG.FixedCols - 1;
    Ligne := SG.FixedRows - 1;

    // Iterate through all rows of the table
    // Schleife durch allen Zeilen der Tabelle
    for i := 0 to Les_Strings.Count - 1 do
    begin
    Colonne := InitialCol;
    Inc(Ligne);
    StartPos := 1;
    S := Les_Strings[i];
    TabPos := Pos(FieldSeparator, S);
    repeat
    Inc(Colonne);
    SG.Cells[Colonne, Ligne] := Copy(S, StartPos, TabPos - 1);
    S := Copy(S, TabPos + 1, 999);
    TabPos := Pos(FieldSeparator, S);
    until TabPos = 0;
    end;
    finally
    Les_Strings.Free;
    end;
    end;

    // Example, Beispiel:

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    Screen.Cursor := crHourGlass;
    // Open tab-delimited files
    ReadTabFile('C:\TEST.TXT', #9, StringGrid1);
    Screen.Cursor := crDefault;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:19 عصر

  8. #48
    استفاده از توابع shell برای copy/move یک فایل
    uses
    ShellApi;

    procedure ShellFileOperation(fromFile: string; toFile: string; Flags: Integer);
    var
    shellinfo: TSHFileOpStructA;
    begin
    with shellinfo do
    begin
    wnd := Application.Handle;
    wFunc := Flags;
    pFrom := PChar(fromFile);
    pTo := PChar(toFile);
    end;
    SHFileOperation(shellinfo);
    end;




    procedure TForm1.Button1Click(Sender: TObject);
    begin
    ShellFileOperation('c:\afile.txt', 'd:\afile2.txt', FO_COPY);
    // To Move a file: FO_MOVE
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:19 عصر

  9. #49
    اضافه کردن اطلاعات به یک فایل EXE
    function AttachToFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;
    var
    aStream: TFileStream;
    iSize: Integer;
    begin
    Result := False;
    if not FileExists(AFileName) then
    Exit;
    try
    aStream := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyWrite);
    MemoryStream.Seek(0, soFromBeginning);
    // seek to end of File
    // ans Ende der Datei Seeken
    aStream.Seek(0, soFromEnd);
    // copy data from MemoryStream
    // Daten vom MemoryStream kopieren
    aStream.CopyFrom(MemoryStream, 0);
    // save Stream-Size
    // die Streamgr&ouml;&szlig;e speichern
    iSize := MemoryStream.Size + SizeOf(Integer);
    aStream.Write(iSize, SizeOf(iSize));
    finally
    aStream.Free;
    end;
    Result := True;
    end;

    function LoadFromFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;
    var
    aStream: TFileStream;
    iSize: Integer;
    begin
    Result := False;
    if not FileExists(AFileName) then
    Exit;

    try
    aStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
    // seek to position where Stream-Size is saved
    // zur Position seeken wo Streamgr&ouml;&szlig;e gespeichert
    aStream.Seek(-SizeOf(Integer), soFromEnd);
    aStream.Read(iSize, SizeOf(iSize));
    if iSize > aStream.Size then
    begin
    aStream.Free;
    Exit;
    end;
    // seek to position where data is saved
    // zur Position seeken an der die Daten abgelegt sind
    aStream.Seek(-iSize, soFromEnd);
    MemoryStream.SetSize(iSize - SizeOf(Integer));
    MemoryStream.CopyFrom(aStream, iSize - SizeOf(iSize));
    MemoryStream.Seek(0, soFromBeginning);
    finally
    aStream.Free;
    end;
    Result := True;
    end;

    procedure TForm1.SaveClick(Sender: TObject);
    var
    aStream: TMemoryStream;
    begin
    aStream := TMemoryStream.Create;
    Memo1.Lines.SaveToStream(aStream);
    AttachToFile('Test.exe', aStream);
    aStream.Free;
    end;

    procedure TForm1.LoadClick(Sender: TObject);
    var
    aStream: TMemoryStream;
    begin
    aStream := TMemoryStream.Create;
    LoadFromFile('Test.exe', aStream);
    Memo1.Lines.LoadFromStream(aStream);
    aStream.Free;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:19 عصر

  10. #50
    پاک کردن یک فایل درون پوشه Document
    uses
    ShlObj;

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    SHAddToRecentDocs(0, nil);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:20 عصر

  11. #51
    توابع مفید جهت کار با Stream
    unit ClassUtils;

    interface

    uses
    SysUtils,
    Classes;

    {/: Write a string to the stream
    @param Stream is the TStream to write to.
    @param s is the string to write
    @returns the number of bytes written. /}
    function Writestring(_Stream: TStream; const _s: string): Integer;

    {/: Write a string to the stream appending CRLF
    @param Stream is the TStream to write to.
    @param s is the string to write
    @returns the number of bytes written. /}
    function WritestringLn(_Stream: TStream; const _s: string): Integer;

    {/: Write formatted data to the stream appending CRLF
    @param Stream is the TStream to write to.
    @param Format is a format string as used in sysutils.format
    @param Args is an array of const as used in sysutils.format
    @returns the number of bytes written. /}
    function WriteFmtLn(_Stream: TStream; const _Format: string;
    _Args: array of const): Integer;

    implementation

    function Writestring(_Stream: TStream; const _s: string): Integer;
    begin
    Result := _Stream.Write(PChar(_s)^, Length(_s));
    end;

    function WritestringLn(_Stream: TStream; const _s: string): Integer;
    begin
    Result := Writestring(_Stream, _s);
    Result := Result + Writestring(_Stream, #13#10);
    end;

    function WriteFmtLn(_Stream: TStream; const _Format: string;
    _Args: array of const): Integer;
    begin
    Result := WritestringLn(_Stream, Format(_Format, _Args));
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:21 عصر

  12. #52
    تبدیل OEM به ANSI
    procedure ConvertFile(const FileName: string; fromCodepage: Integer);
    var
    ms: TMemoryStream;
    begin
    if getOEMCP <> fromCodepage then
    raise Exception.Create('ConvertFile: Codepage doesn't match!');
    ms := TMemoryStream.Create;
    try
    ms.LoadFromFile(FileName);
    // make backup
    ms.Position := 0;
    ms.SaveToFile(ChangeFileExt(FileName, '.BAK'));
    // convert text
    OEMToCharBuff(ms.Memory, ms.Memory, ms.Size);
    // save back to original file
    ms.Position := 0;
    ms.SaveToFile(FileName);
    finally
    ms.Free;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:21 عصر

  13. #53
    ثبت خروجی یک برنامه DOS
    function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile,
    ErrMsg: string): Boolean;
    const
    ROUTINE_ID = '[function: CreateDOSProcessRedirected ]';
    var
    OldCursor: TCursor;
    pCommandLine: array[0..MAX_PATH] of Char;
    pInputFile, pOutPutFile: array[0..MAX_PATH] of Char;
    StartupInfo: TStartupInfo;
    ProcessInfo: TProcessInformation;
    SecAtrrs: TSecurityAttributes;
    hAppProcess, hAppThread, hInputFile, hOutputFile: THandle;
    begin
    Result := False;

    {/ check for InputFile existence /}
    if not FileExists(InputFile) then
    raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
    'Input file * %s *' + #10 +
    'does not exist' + #10 + #10 +
    ErrMsg, [InputFile]);

    {/ save the cursor /}
    OldCursor := Screen.Cursor;
    Screen.Cursor := crHourglass;

    {/ copy the parameter Pascal strings to null terminated strings /}
    StrPCopy(pCommandLine, CommandLine);
    StrPCopy(pInputFile, InputFile);
    StrPCopy(pOutPutFile, OutputFile);

    try

    {/ prepare SecAtrrs structure for the CreateFile calls
    This SecAttrs structure is needed in this case because
    we want the returned handle can be inherited by child process
    This is true when running under WinNT.
    As for Win95 the documentation is quite ambiguous /}
    FillChar(SecAtrrs, SizeOf(SecAtrrs), #0);
    SecAtrrs.nLength := SizeOf(SecAtrrs);
    SecAtrrs.lpSecurityDescriptor := nil;
    SecAtrrs.bInheritHandle := True;

    {/ create the appropriate handle for the input file /}
    hInputFile := CreateFile(pInputFile,
    {/ pointer to name of the file /}
    GENERIC_READ or GENERIC_WRITE,
    {/ access (read-write) mode /}
    FILE_SHARE_READ or FILE_SHARE_WRITE,
    {/ share mode /} @SecAtrrs, {/ pointer to security attributes /}
    OPEN_ALWAYS, {/ how to create /}
    FILE_ATTRIBUTE_TEMPORARY, {/ file attributes /}
    0); {/ handle to file with attributes to copy /}


    {/ is hInputFile a valid handle? /}
    if hInputFile = INVALID_HANDLE_VALUE then
    raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
    'WinApi function CreateFile returned an invalid handle value' +
    #10 +
    'for the input file * %s *' + #10 + #10 +
    ErrMsg, [InputFile]);

    {/ create the appropriate handle for the output file /}
    hOutputFile := CreateFile(pOutPutFile,
    {/ pointer to name of the file /}
    GENERIC_READ or GENERIC_WRITE,
    {/ access (read-write) mode /}
    FILE_SHARE_READ or FILE_SHARE_WRITE,
    {/ share mode /} @SecAtrrs, {/ pointer to security attributes /}
    CREATE_ALWAYS, {/ how to create /}
    FILE_ATTRIBUTE_TEMPORARY, {/ file attributes /}
    0); {/ handle to file with attributes to copy /}

    {/ is hOutputFile a valid handle? /}
    if hOutputFile = INVALID_HANDLE_VALUE then
    raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
    'WinApi function CreateFile returned an invalid handle value' +
    #10 +
    'for the output file * %s *' + #10 + #10 +
    ErrMsg, [OutputFile]);

    {/ prepare StartupInfo structure /}
    FillChar(StartupInfo, SizeOf(StartupInfo), #0);
    StartupInfo.cb := SizeOf(StartupInfo);
    StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
    StartupInfo.wShowWindow := SW_HIDE;
    StartupInfo.hStdOutput := hOutputFile;
    StartupInfo.hStdInput := hInputFile;

    {/ create the app /}
    Result := CreateProcess(nil, {/ pointer to name of executable module /}
    pCommandLine,
    {/ pointer to command line string /}
    nil, {/ pointer to process security attributes /}
    nil, {/ pointer to thread security attributes /}
    True, {/ handle inheritance flag /}
    CREATE_NEW_CONSOLE or
    REALTIME_PRIORITY_CLASS, {/ creation flags /}
    nil, {/ pointer to new environment block /}
    nil, {/ pointer to current directory name /}
    StartupInfo, {/ pointer to STARTUPINFO /}
    ProcessInfo); {/ pointer to PROCESS_INF /}

    {/ wait for the app to finish its job and take the handles to free them later /}
    if Result then
    begin
    WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
    hAppProcess := ProcessInfo.hProcess;
    hAppThread := ProcessInfo.hThread;
    end
    else
    raise Exception.Create(ROUTINE_ID + #10 + #10 +
    'Function failure' + #10 + #10 +
    ErrMsg);

    finally
    {/ close the handles
    Kernel objects, like the process and the files we created in this case,
    are maintained by a usage count.
    So, for cleaning up purposes we have to close the handles
    to inform the system that we don't need the objects anymore /}
    if hOutputFile <> 0 then CloseHandle(hOutputFile);
    if hInputFile <> 0 then CloseHandle(hInputFile);
    if hAppThread <> 0 then CloseHandle(hAppThread);
    if hAppProcess <> 0 then CloseHandle(hAppProcess);
    {/ restore the old cursor /}
    Screen.Cursor := OldCursor;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:22 عصر

  14. #54
    قرار دادن یک فایل Exe درون برنامه و اجرای آن
    var
    Form1: TForm1;
    NOTEPAD_FILE: string;

    implementation

    {/$R *.DFM/}
    {/$R MYRES.RES/}

    function GetTempDir: string;
    var
    Buffer: array[0..MAX_PATH] of Char;
    begin
    GetTempPath(SizeOf(Buffer) - 1, Buffer);
    Result := StrPas(Buffer);
    end;

    // Extract the Resource
    function ExtractRes(ResType, ResName, ResNewName: string): Boolean;
    var
    Res: TResourceStream;
    begin
    Result := False;
    Res := TResourceStream.Create(Hinstance, Resname, PChar(ResType));
    try
    Res.SavetoFile(ResNewName);
    Result := True;
    finally
    Res.Free;
    end;
    end;

    // Execute the file
    procedure ShellExecute_AndWait(FileName: string);
    var
    exInfo: TShellExecuteInfo;
    Ph: DWORD;
    begin
    FillChar(exInfo, SizeOf(exInfo), 0);
    with exInfo do
    begin
    cbSize := SizeOf(exInfo);
    fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
    Wnd := GetActiveWindow();
    ExInfo.lpVerb := 'open';
    lpFile := PChar(FileName);
    nShow := SW_SHOWNORMAL;
    end;
    if ShellExecuteEx(@exInfo) then
    begin
    Ph := exInfo.HProcess;
    end
    else
    begin
    ShowMessage(SysErrorMessage(GetLastError&# 41;);
    Exit;
    end;
    while WaitForSingleObject(ExInfo.hProcess, 50) <> WAIT_OBJECT_0 do
    Application.ProcessMessages;
    CloseHandle(Ph);
    end;

    // To Test it
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    if ExtractRes('EXEFILE', 'TESTFILE', NOTEPAD_FILE) then
    if FileExists(NOTEPAD_FILE) then
    begin
    ShellExecute_AndWait(NOTEPAD_FILE);
    ShowMessage('Notepad finished!');
    DeleteFile(NOTEPAD_FILE);
    end;
    end;

    procedure TForm1.FormCreate(Sender: TObject);
    begin
    NOTEPAD_FILE := GetTempDir + 'Notepad_FROM_RES.EXE';
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:23 عصر

  15. #55
    پاک کردن برنامه توسط خودش بعد از اجرای آن
    procedure DeleteEXE;

    function GetTmpDir: string;
    var
    pc: PChar;
    begin
    pc := StrAlloc(MAX_PATH + 1);
    GetTempPath(MAX_PATH, pc);
    Result := string(pc);
    StrDispose(pc);
    end;

    function GetTmpFileName(ext: string): string;
    var
    pc: PChar;
    begin
    pc := StrAlloc(MAX_PATH + 1);
    GetTempFileName(PChar(GetTmpDir), 'uis', 0, pc);
    Result := string(pc);
    Result := ChangeFileExt(Result, ext);
    StrDispose(pc);
    end;

    var
    batchfile: TStringList;
    batchname: string;
    begin
    batchname := GetTmpFileName('.bat');
    FileSetAttr(ParamStr(0), 0);
    batchfile := TStringList.Create;
    with batchfile do
    begin
    try
    Add(':Label1');
    Add('del "' + ParamStr(0) + '"');
    Add('if Exist "' + ParamStr(0) + '" goto Label1');
    Add('rmdir "' + ExtractFilePath(ParamStr(0)) + '"');
    Add('del ' + batchname);
    SaveToFile(batchname);
    ChDir(GetTmpDir);
    ShowMessage('Uninstalling program...');
    WinExec(PChar(batchname), SW_HIDE);
    finally
    batchfile.Free;
    end;
    Halt;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:24 عصر

  16. #56
    غیر فعال کردن دکمه Close در فرم
    procedure TFMain.FormCreate(Sender: TObject);
    var
    hMenuHandle: Integer;
    begin
    hMenuHandle := GetSystemMenu(Handle, False);
    if (hMenuHandle <> 0) then
    DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:24 عصر

  17. #57
    روش استفاده از TFileStream
    type

    TPerson = record
    Name: string[50];
    vorname: string[50];
    end;

    TComputer = record
    Name: string[30];
    cpu: string[30];
    end;

    var
    Form1: TForm1;

    Person: TPerson;
    Computer: TComputer;

    Stream: TFileStream;

    implementation

    {/$R *.DFM/}

    //Speichern resp. Erstellen von Datei
    //Save or create the file
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    try
    Stream := TFileStream.Create('c:\test.dat', fmOpenReadWrite);
    except
    Stream := TFileStream.Create('c:\test.dat', fmCreate);
    end;

    //2 Eintr&auml;ge pro Record
    //save 2 records for TPerson and TComputer
    Person.Name := 'Grossenbacher';
    Person.vorname := 'Simon';
    Stream.WriteBuffer(Person, SizeOf(TPerson));

    Person.Name := 'Stutz';
    Person.vorname := 'Thomas';
    Stream.WriteBuffer(Person, SizeOf(TPerson));

    Computer.Name := 'Delphi';
    Computer.cpu := 'Intel';
    Stream.WriteBuffer(Computer, SizeOf(TComputer));

    Computer.Name := 'Win';
    Computer.cpu := 'AMD';
    Stream.WriteBuffer(Computer, SizeOf(TComputer));

    Stream.Free;
    end;

    //l&auml;dt alle daten von TPerson in listbox1 und
    //daten von TComputer in Listbox2

    //load records from TPerson to listbox1 and
    //load records from TComputer to listbox2
    procedure TForm1.Button2Click(Sender: TObject);
    var
    i: Integer;
    begin
    try
    // nur lesen &ouml;ffnen
    //open read only
    Stream := TFileStream.Create('c:\test.dat', fmOpenRead);
    except
    ShowMessage('Datei konnte nicht geladen werden.');
    Exit;
    end;

    //variable i auf anzahl Eintr&auml;ge setzen

    //set variable i to the record count

    //Einlesen von TPerson
    //Read records TPerson
    for i := 2 downto 1 do
    begin
    Stream.ReadBuffer(Person, SizeOf(TPerson));
    Listbox1.Items.Add(Person.vorname + ' ' + Person.Name);
    end;

    //Einlesen von TComputer
    //Read Records TComputer
    for i := 2 downto 1 do
    begin
    Stream.ReadBuffer(Computer, SizeOf(TComputer));
    Listbox2.Items.Add(Computer.Name + ' ' + Computer.cpu);
    end;

    Stream.Free;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:24 عصر

  18. #58
    جایگزینی یک Dll در حال استفاده از آن
    function SystemErrorMessage: string;
    var
    P: PChar;
    begin
    if FormatMessage(Format_Message_Allocate_Buffer + Format_Message_From_System,
    nil,
    GetLastError,
    0,
    @P,
    0,
    nil) <> 0 then
    begin
    Result := P;
    LocalFree(Integer(P))
    end
    else
    Result := '';
    end;


    // Path to Original File

    procedure TForm1.Button2Click(Sender: TObject);
    begin
    if Opendialog1.Execute then
    edit1.Text := OpenDialog1.FileName;
    end;

    // Path to New File

    procedure TForm1.Button3Click(Sender: TObject);
    begin
    if Opendialog2.Execute then
    edit2.Text := OpenDialog2.FileName;
    end;

    // Replace the File.

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    if (Movefileex(PChar(Edit1.Text), PChar(Edit2.Text), MOVEFILE_DELAY_UNTIL_REBOOT) = False) then
    ShowMessage(SystemErrorMessage)
    else
    begin
    ShowMessage('Please Restart Windows to have these changes take effect');
    halt;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:25 عصر

  19. #59
    تغییر صفات یک فایل
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    FileSetAttr('C:\YourFile.ext', faHidden);
    end;

    {/
    Other Files Attributes:
    Andere Dateiattribute:
    /}

    {/
    faReadOnly $00000001 Schreibgeschützte Datei
    faHidden $00000002 Verborgene Datei
    faSysFile $00000004 Systemdatei
    faVolumeID $00000008 Laufwerks-ID
    faDirectory $00000010 Verzeichnis
    faArchive $00000020 Archivdatei
    faAnyFile $0000003F Beliebige Datei
    /}


    {/
    You can also set some attributes at once:
    Es kِnnen auch mehrere Attribute aufs Mal gesetzt werden:
    /}

    FileSetAttr('C:\Autoexec.bat', faReadOnly + faHidden);


    {/
    To remove write protection on a file:
    Den Schreibschutz einer Datei aufheben:
    /}

    if (FileGetAttr(FileName) and faReadOnly) > 0
    then FileSetAttr(FileName, FileGetAttr(FileName) xor faReadOnly);

    {/
    Re-Set write protection:
    Schreibschutz wieder setzen:
    /}

    FileSetAttr(FileName, FileGetAttr(FileName) or faReadOnly);
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:26 عصر

  20. #60
    خواندن یک فایل متنی بصورت خط به خط و تغییر آن
    procedure TForm1.Button1Click(Sender: TObject);
    var
    i, z: Integer;
    f: TextFile;
    t: string;
    Data: array of string;
    begin
    if OpenDialog1.Execute then
    begin
    //Read line by line in to the array data
    AssignFile(f, OpenDialog1.FileName);
    Reset(f);
    z := 0;
    SetLength(Data, 0);
    //Repeat for each line until end of file
    repeat
    Inc(z);
    readln(f, t);
    SetLength(Data, Length(Data) + Length(t));
    Data[z] := t;
    until EOF(f);

    SetLength(Data, Length(Data) + 3 * z);
    //Add to each line the line number
    for i := 1 to z do Data[i] := IntToStr(i) + ' ' + Data[i];
    SetLength(Data, Length(Data) + 2);
    //Add a carriage return and line feed
    Data[1] := Data[1] + #13 + #10;
    i := Length(Data[5]);
    Data[5] := '';
    SetLength(Data, Length(Data) - i);
    //create a new textfile with the new data
    AssignFile(f, OpenDialog1.FileName + '2');
    ReWrite(f);
    //write all lines
    for i := 1 to z do writeln(f, Data[i]);
    //save file and close it
    CloseFile(f);
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:27 عصر

  21. #61
    تعیین فضای آزاد دیسک
    procedure TForm1.Button1Click(Sender: TObject);
    var
    freeSpace, totalSpace: Double;
    s: Char;
    begin
    // Drive letter
    // Laufwerksbuchstabe
    s := 'D';

    freeSpace := DiskFree(Ord(s) - 64);
    totalSpace := DiskSize(Ord(s) - 64);

    label1.Caption := Format('Free Space: %12.0n', [freeSpace]);
    Label2.Caption := Format('Total Space: %12.0n', [totalSpace]);
    Label3.Caption := IntToStr(Round((totalSpace - freeSpace) / totalSpace * 100)) +
    ' Percent used.';
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:27 عصر

  22. #62
    استفاده از فایلهای INI
    uses
    IniFiles;

    // Write values to a INI file

    procedure TForm1.Button1Click(Sender: TObject);
    var
    ini: TIniFile;
    begin
    // Create INI Object and open or create file test.ini
    ini := TIniFile.Create('c:\MyIni.ini');
    try
    // Write a string value to the INI file.
    ini.WriteString('Section_Name', 'Key_Name', 'String Value');
    // Write a integer value to the INI file.
    ini.WriteInteger('Section_Name', 'Key_Name', 2002);
    // Write a boolean value to the INI file.
    ini.WriteBool('Section_Name', 'Key_Name', True);
    finally
    ini.Free;
    end;
    end;


    // Read values from an INI file

    procedure TForm1.Button2Click(Sender: TObject);
    var
    ini: TIniFile;
    res: string;
    begin
    // Create INI Object and open or create file test.ini
    ini := TIniFile.Create('c:\MyIni.ini');
    try
    res := ini.ReadString('Section_Name', 'Key_Name', 'default value');
    MessageDlg('Value of Section: ' + res, mtInformation, [mbOK], 0);
    finally
    ini.Free;
    end;
    end;

    // Read all sections

    procedure TForm1.Button3Click(Sender: TObject);
    var
    ini: TIniFile;
    begin
    ListBox1.Clear;
    ini := TIniFile.Create('MyIni.ini');
    try
    ini.ReadSections(listBox1.Items);
    finally
    ini.Free;
    end;
    end;

    // Read a section

    procedure TForm1.Button4Click(Sender: TObject);
    var
    ini: TIniFile;
    begin
    ini: = TIniFile.Create('WIN.INI');
    try
    ini.ReadSection('Desktop', ListBox1.Items);
    finally
    ini.Free;
    end;
    end;


    // Read section values

    procedure TForm1.Button5Click(Sender: TObject);
    var
    ini: TIniFile;
    begin
    ini := TIniFile.Create('WIN.INI');
    try
    ini.ReadSectionValues('Desktop', ListBox1.Items);
    finally
    ini.Free;
    end;
    end;

    // Erase a section

    procedure TForm1.Button6Click(Sender: TObject);
    var
    ini: TIniFile;
    begin
    ini := TIniFile.Create('MyIni.ini');
    try
    ini.EraseSection('My_Section');
    finally
    ini.Free;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:28 عصر

  23. #63
    سایز یک دایرکتوری
    function GetDirSize(dir: string; subdir: Boolean): Longint;
    var
    rec: TSearchRec;
    found: Integer;
    begin
    Result := 0;
    if dir[Length(dir)] <> '\' then dir := dir + '\';
    found := FindFirst(dir + '*.*', faAnyFile, rec);
    while found = 0 do
    begin
    Inc(Result, rec.Size);
    if (rec.Attr and faDirectory > 0) and (rec.Name[1] <> '.') and (subdir = True) then
    Inc(Result, GetDirSize(dir + rec.Name, True));
    found := FindNext(rec);
    end;
    FindClose(rec);
    end;

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    label1.Caption := FloatToStr(GetDirSize('e:\download', False) / Sqr(1024)) + ' MBytes';
    label2.Caption := FloatToStr(GetDirSize('e:\download', True) / Sqr(1024)) + ' MBytes';
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:28 عصر

  24. #64
    کپی کردن یک فایل

    var
    fileSource, fileDest: string;
    begin
    fileSource := 'C:\SourceFile.txt';
    fileDest := 'G:\DestFile.txt';
    CopyFile(PChar(fileSource), PChar(fileDest), False);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:29 عصر

  25. #65
    روش بدست آوردن اطلاعات CPU
    unit main;

    interface

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

    type
    Tfrm_main = class(TForm)
    img_info: TImage;
    procedure FormShow(Sender: TObject);
    private
    {/ Private declarations /}
    public
    {/ Public declarations /}
    procedure info(s1, s2: string);
    end;

    var
    frm_main: Tfrm_main;
    gn_speed_y: Integer;
    gn_text_y: Integer;
    const
    gn_speed_x: Integer = 8;
    gn_text_x: Integer = 15;
    gl_start: Boolean = True;

    implementation

    {/$R *.DFM/}

    procedure Tfrm_main.FormShow(Sender: TObject);
    var
    _eax, _ebx, _ecx, _edx: Longword;
    i: Integer;
    b: Byte;
    b1: Word;
    s, s1, s2, s3, s_all: string;
    begin
    //Set the startup colour of the image
    img_info.Canvas.Brush.Color := clblue;
    img_info.Canvas.FillRect(rect(0, 0, img_info.Width, img_info.Height));


    gn_text_y := 5; //position of the 1st text

    asm //asm call to the CPUID inst.
    mov eax,0 //sub. func call
    db $0F,$A2 //db $0F,$A2 = CPUID instruction
    mov _ebx,ebx
    mov _ecx,ecx
    mov _edx,edx
    end;

    for i := 0 to 3 do //extract vendor id
    begin
    b := lo(_ebx);
    s := s + chr(b);
    b := lo(_ecx);
    s1:= s1 + chr(b);
    b := lo(_edx);
    s2:= s2 + chr(b);
    _ebx := _ebx shr 8;
    _ecx := _ecx shr 8;
    _edx := _edx shr 8;
    end;
    info('CPU', '');
    info(' - ' + 'Vendor ID: ', s + s2 + s1);

    asm
    mov eax,1
    db $0F,$A2
    mov _eax,eax
    mov _ebx,ebx
    mov _ecx,ecx
    mov _edx,edx
    end;
    //06B1
    //|0000| |0000 0000| |0000| |00| |00| |0110| |1011| |0001|
    b := lo(_eax) and 15;
    info(' - ' + 'Stepping ID: ', IntToStr(b));
    b := lo(_eax) shr 4;
    info(' - ' + 'Model Number: ', IntToHex(b, 1));
    b := hi(_eax) and 15;
    info(' - ' + 'Family Code: ', IntToStr(b));
    b := hi(_eax) shr 4;
    info(' - ' + 'Processor Type: ', IntToStr(b));
    //31. 28. 27. 24. 23. 20. 19. 16.
    // 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
    b := lo((_eax shr 16)) and 15;
    info(' - ' + 'Extended Model: ', IntToStr(b));

    b := lo((_eax shr 20));
    info(' - ' + 'Extended Family: ', IntToStr(b));

    b := lo(_ebx);
    info(' - ' + 'Brand ID: ', IntToStr(b));
    b := hi(_ebx);
    info(' - ' + 'Chunks: ', IntToStr(b));
    b := lo(_ebx shr 16);
    info(' - ' + 'Count: ', IntToStr(b));
    b := hi(_ebx shr 16);
    info(' - ' + 'APIC ID: ', IntToStr(b));

    //Bit 18 =? 1 //is serial number enabled?
    if (_edx and $40000) = $40000 then
    info(' - ' + 'Serial Number ', 'Enabled')
    else
    info(' - ' + 'Serial Number ', 'Disabled');

    s := IntToHex(_eax, 8);
    asm //determine the serial number
    mov eax,3
    db $0F,$A2
    mov _ecx,ecx
    mov _edx,edx
    end;
    s1 := IntToHex(_edx, 8);
    s2 := IntToHex(_ecx, 8);
    Insert('-', s, 5);
    Insert('-', s1, 5);
    Insert('-', s2, 5);
    info(' - ' + 'Serial Number: ', s + '-' + s1 + '-' + s2);

    asm
    mov eax,1
    db $0F,$A2
    mov _edx,edx
    end;
    info('', '');
    //Bit 23 =? 1
    if (_edx and $800000) = $800000 then
    info('MMX ', 'Supported')
    else
    info('MMX ', 'Not Supported');

    //Bit 24 =? 1
    if (_edx and $01000000) = $01000000 then
    info('FXSAVE &amp; FXRSTOR Instructions ', 'Supported')
    else
    info('FXSAVE &amp; FXRSTOR Instructions Not ', 'Supported');

    //Bit 25 =? 1
    if (_edx and $02000000) = $02000000 then
    info('SSE ', 'Supported')
    else
    info('SSE ', 'Not Supported');

    //Bit 26 =? 1
    if (_edx and $04000000) = $04000000 then
    info('SSE2 ', 'Supported')
    else
    info('SSE2 ', 'Not Supported');

    info('', '');

    asm //execute the extended CPUID inst.
    mov eax,$80000000 //sub. func call
    db $0F,$A2
    mov _eax,eax
    end;

    if _eax > $80000000 then //any other sub. funct avail. ?
    begin
    info('Extended CPUID: ', 'Supported');
    info(' - Largest Function Supported: ', IntToStr(_eax - $80000000));
    asm //get brand ID
    mov eax,$80000002
    db $0F
    db $A2
    mov _eax,eax
    mov _ebx,ebx
    mov _ecx,ecx
    mov _edx,edx
    end;
    s := '';
    s1 := '';
    s2 := '';
    s3 := '';
    for i := 0 to 3 do
    begin
    b := lo(_eax);
    s3:= s3 + chr(b);
    b := lo(_ebx);
    s := s + chr(b);
    b := lo(_ecx);
    s1 := s1 + chr(b);
    b := lo(_edx);
    s2 := s2 + chr(b);
    _eax := _eax shr 8;
    _ebx := _ebx shr 8;
    _ecx := _ecx shr 8;
    _edx := _edx shr 8;
    end;

    s_all := s3 + s + s1 + s2;

    asm
    mov eax,$80000003
    db $0F
    db $A2
    mov _eax,eax
    mov _ebx,ebx
    mov _ecx,ecx
    mov _edx,edx
    end;
    s := '';
    s1 := '';
    s2 := '';
    s3 := '';
    for i := 0 to 3 do
    begin
    b := lo(_eax);
    s3 := s3 + chr(b);
    b := lo(_ebx);
    s := s + chr(b);
    b := lo(_ecx);
    s1 := s1 + chr(b);
    b := lo(_edx);
    s2 := s2 + chr(b);
    _eax := _eax shr 8;
    _ebx := _ebx shr 8;
    _ecx := _ecx shr 8;
    _edx := _edx shr 8;
    end;
    s_all := s_all + s3 + s + s1 + s2;

    asm
    mov eax,$80000004
    db $0F
    db $A2
    mov _eax,eax
    mov _ebx,ebx
    mov _ecx,ecx
    mov _edx,edx
    end;
    s := '';
    s1 := '';
    s2 := '';
    s3 := '';
    for i := 0 to 3 do
    begin
    b := lo(_eax);
    s3 := s3 + chr(b);
    b := lo(_ebx);
    s := s + chr(b);
    b := lo(_ecx);
    s1 := s1 + chr(b);
    b := lo(_edx);
    s2 := s2 + chr(b);
    _eax := _eax shr 8;
    _ebx := _ebx shr 8;
    _ecx := _ecx shr 8;
    _edx := _edx shr 8;
    end;
    info('Brand String: ', '');
    if s2[Length(s2)] = #0 then setlength(s2, Length(s2) - 1);
    info('', ' - ' + s_all + s3 + s + s1 + s2);
    end
    else
    info(' - Extended CPUID ', 'Not Supported.');
    end;

    procedure Tfrm_main.info(s1, s2: string);
    begin
    if s1 <> '' then
    begin
    img_info.Canvas.Brush.Color := clblue;
    img_info.Canvas.Font.Color := clyellow;
    img_info.Canvas.TextOut(gn_text_x, gn_text_y, s1);
    end;
    if s2 <> '' then
    begin
    img_info.Canvas.Brush.Color := clblue;
    img_info.Canvas.Font.Color := clWhite;
    img_info.Canvas.TextOut(gn_text_x + img_info.Canvas.TextWidth(s1), gn_text_y, s2);
    end;
    Inc(gn_text_y, 13);
    end;

    end.
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:29 عصر

  26. #66
    مشخص کردن وجود Terminal Service ها

    function IsRemoteSession: Boolean;
    const
    sm_RemoteSession = $1000; {/ from WinUser.h /}
    begin
    Result := (GetSystemMetrics(sm_RemoteSession) <> 0);
    end;



    type
    OSVERSIONINFOEX = packed record
    dwOSVersionInfoSize: DWORD;
    dwMajorVersion: DWORD;
    dwMinorVersion: DWORD;
    dwBuildNumber: DWORD;
    dwPlatformId: DWORD;
    szCSDVersion: array[0..127] of Char;
    wServicePackMajor: WORD;
    wServicePackMinor: WORD;
    wSuiteMask: WORD;
    wProductType: BYTE;
    wReserved: BYTE;
    end;
    TOSVersionInfoEx = OSVERSIONINFOEX;
    POSVersionInfoEx = ^TOSVersionInfoEx;

    const
    VER_SUITE_TERMINAL = $00000010;
    VER_SUITENAME = $00000040;
    VER_AND = 6;

    function VerSetConditionMask(
    ConditionMask: int64;
    TypeMask: DWORD;
    Condition: Byte
    ): int64; stdcall; external kernel32;

    function VerifyVersionInfo(
    var VersionInformation: OSVERSIONINFOEX;
    dwTypeMask: DWORD;
    dwlConditionMask: int64
    ): BOOL; stdcall; external kernel32 name 'VerifyVersionInfoA';


    function IsTerminalServicesEnabled: Boolean;
    var
    osVersionInfo: OSVERSIONINFOEX;
    dwlConditionMask: int64;
    begin
    FillChar(osVersionInfo, SizeOf(osVersionInfo), 0);
    osVersionInfo.dwOSVersionInfoSize := sizeof(osVersionInfo);
    osVersionInfo.wSuiteMask := VER_SUITE_TERMINAL;
    dwlConditionMask := 0;
    dwlConditionMask :=
    VerSetConditionMask(dwlConditionMask,
    VER_SUITENAME,
    VER_AND);
    Result := VerifyVersionInfo(
    osVersionInfo,
    VER_SUITENAME,
    dwlConditionMask);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:30 عصر

  27. #67
    سلام

    بفرمایید:
    uses
    ShellApi;

    function CopyDir(const fromDir, toDir: string): Boolean;
    var
    fos: TSHFileOpStruct;
    begin
    ZeroMemory(@fos, SizeOf(fos));
    with fos do
    begin
    wFunc := FO_COPY;
    fFlags := FOF_FILESONLY;
    pFrom := PChar(fromDir + #0);
    pTo := PChar(toDir)
    end;
    Result := (0 = ShFileOperation(fos));
    end;


    function MoveDir(const fromDir, toDir: string): Boolean;
    var
    fos: TSHFileOpStruct;
    begin
    ZeroMemory(@fos, SizeOf(fos));
    with fos do
    begin
    wFunc := FO_MOVE;
    fFlags := FOF_FILESONLY;
    pFrom := PChar(fromDir + #0);
    pTo := PChar(toDir)
    end;
    Result := (0 = ShFileOperation(fos));
    end;

    function DelDir(dir: string): Boolean;
    var
    fos: TSHFileOpStruct;
    begin
    ZeroMemory(@fos, SizeOf(fos));
    with fos do
    begin
    wFunc := FO_DELETE;
    fFlags := FOF_SILENT or FOF_NOCONFIRMATION;
    pFrom := PChar(dir + #0);
    end;
    Result := (0 = ShFileOperation(fos));
    end;


    procedure TForm1.Button1Click(Sender: TObject);
    begin
    if cCopyDir('d:\download', 'e:\') = True then
    ShowMessage('Directory copied.');
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:31 عصر

  28. #68
    تعیین نسخه MS Word نصب شده روی کامپیوتر
    uses ComObj;

    {/
    const
    Wordversion97 = 8;
    Wordversion2000 = 9;
    WordversionXP = 10;
    Wordversion2003 = 11;
    /}

    function GetInstalledWordVersion: Integer;
    var
    word: OLEVariant;
    begin
    word := CreateOLEObject('Word.Application');
    result := word.version;
    word.Quit;
    word := UnAssigned;
    end;


    // Example:
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    ShowMessage(IntToStr(GetInstalledWordVersi on));
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:32 عصر

  29. #69
    وارد کردن یک متن RTF در Word
    uses
    Word_TLB, ActiveX, ComObj;

    function GetRTFFormat(DataObject: IDataObject; var RTFFormat: TFormatEtc): Boolean;
    var
    Formats: IEnumFORMATETC;
    TempFormat: TFormatEtc;
    pFormatName: PChar;
    Found: Boolean;
    begin
    try
    OleCheck(DataObject.EnumFormatEtc(DATADIR_ GET, Formats));
    Found := False;
    while (not Found) and (Formats.Next(1, TempFormat, nil) = S_OK) do
    begin
    pFormatName := AllocMem(255);
    GetClipBoardFormatName(TempFormat.cfFormat, pFormatName, 254);
    if (string(pFormatName) = 'Rich Text Format') then
    begin
    RTFFormat := TempFormat;
    Found := True;
    end;
    FreeMem(pFormatName);
    end;
    Result := Found;
    except
    Result := False;
    end;
    end;

    procedure WriteToMSWord(const RTFText: String);
    var
    WordDoc: _Document;
    WordApp: _Application;
    DataObj : IDataObject;
    Formats : IEnumFormatEtc;
    RTFFormat: TFormatEtc;
    Medium : TStgMedium;
    pGlobal : Pointer;
    begin
    try
    GetActiveOleObject('Word.Application').Que ryInterface(_Application, WordApp);
    except
    WordApp := CoWordApplication.Create;
    end;
    WordApp.Documents.Add(EmptyParam, EmptyParam, EmptyParam, EmptyParam);
    WordApp.Visible := True;
    WordDoc := WordApp.ActiveDocument;
    OleCheck(WordDoc.QueryInterface(IDataObjec t,DataObj));
    GetRTFFormat(DataObj, RTFFormat);
    FillChar(Medium,SizeOf(Medium),0);
    Medium.tymed := RTFFormat.tymed;
    Medium.hGlobal := GlobalAlloc(GMEM_MOVEABLE, Length(RTFText)+1);
    try
    pGlobal := GlobalLock(Medium.hGlobal);
    CopyMemory(PGlobal,PChar(RTFText),Leng th(RTFText)+1);
    GlobalUnlock(Medium.hGlobal);
    OleCheck(DataOBJ.SetData(RTFFormat,Medium, True));
    finally
    GlobalFree(Medium.hGlobal);
    ReleaseStgMedium(Medium);
    end;
    end;

    procedure TForm1.Button2Click(Sender: TObject);
    begin
    WriteToMSWord(Memo1.Text); // may be rtf-formatted text
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:32 عصر

  30. #70
    فشرده سازی و ترمیم یک بانک اطلاعاتی Access
    uses
    ComObj;

    function CompactAndRepair(DB: string): Boolean; {/DB = Path to Access Database/}
    var
    v: OLEvariant;
    begin
    Result := True;
    try
    v := CreateOLEObject('JRO.JetEngine');
    try
    V.CompactDatabase('Provider=Microsoft.Jet.OLED B.4.0;Data Source='+DB,
    'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DB+'x;Jet OLEDB:Engine Type=5');
    DeleteFile(DB);
    RenameFile(DB+'x',DB);
    finally
    V := Unassigned;
    end;
    except
    Result := False;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:32 عصر

  31. #71
    ایجاد Database در یک بانک اطلاعاتی sql sever 2000 در حالت local

    procedure CreateDatabase(WindowsSecurity: Boolean; Username, Password: String);
    var
    ConnectionString: String;
    CommandText: String;
    begin
    if WindowsSecurity then
    ConnectionString := 'Provider=SQLOLEDB.1;' +
    'Integrated Security=SSPI;' +
    'Persist Security Info=False;' +
    'Initial Catalog=master'
    else
    ConnectionString := 'Provider=SQLOLEDB.1;' +
    'Password=' + Password + ';' +
    'Persist Security Info=True;' +
    'User ID=' + Username + ';' +
    'Initial Catalog=master';

    try

    try
    ADOConnection.ConnectionString := ConnectionString;
    ADOConnection.LoginPrompt := False;
    ADOConnection.Connected := True;


    CommandText := 'CREATE DATABASE test ON ' +
    '( NAME = test_dat, ' +
    'FILENAME = ''c:\program files\microsoft sql server\mssql\data\test.mdf'', ' +
    'SIZE = 4, ' +
    'MAXSIZE = 10, ' +
    'FILEGROWTH = 1 )';

    ADOCommand.CommandText := CommandText;
    ADOCommand.Connection := ADOConnection;
    ADOCommand.Execute;
    MessageDlg('Database succesfully created.', mtInformation, [mbOK], 0);

    except
    on E: Exception do MessageDlg(E.Message, mtWarning, [mbOK], 0);
    end;

    finally
    ADOConnection.Connected := False;
    ADOCommand.Connection := nil;
    end;

    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:34 عصر

  32. #72
    پیدا کردن یک مقدار در فیلد ایندکس نشده به کمک TTable
    function Locate(const oTable: TTable; const oField: TField;
    const sValue: string): Boolean;
    var

    bmPos: TBookMark;
    bFound: Boolean;
    begin
    Locate := False;
    bFound := False;
    if not oTable.Active then Exit;
    if oTable.FieldDefs.IndexOf(oField.FieldName) < 0 then Exit;
    bmPos := oTable.GetBookMark;
    with oTable do
    begin
    DisableControls;
    First;
    while not EOF do
    if oField.AsString = sValue then
    begin
    Locate := True;
    bFound := True;
    Break;
    end
    else
    Next;
    end;
    if (not bFound) then
    oTable.GotoBookMark(bmPos);
    oTable.FreeBookMark(bmPos);
    oTable.EnableControls;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:34 عصر

  33. #73
    تهیه خروجی از جداول ADO به فرمتهای مختلف
    unit ExportADOTable;

    interface

    uses
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    Db, ADODB;

    type
    TExportADOTable = class(TADOTable)
    private
    {/ Private declarations /}
    //TADOCommand component used to execute the SQL exporting commands
    FADOCommand: TADOCommand;
    protected
    {/ Protected declarations /}
    public
    {/ Public declarations /}
    constructor Create(AOwner: TComponent); override;

    //Export procedures
    //"FiledNames" is a comma separated list of the names of the fields you want to export
    //"FileName" is the name of the output file (including the complete path)
    //if the dataset is filtered (Filtered = true and Filter <> ''), then I append
    //the filter string to the sql command in the "where" directive
    //if the dataset is sorted (Sort <> '') then I append the sort string to the sql command in the
    //"order by" directive

    procedure ExportToExcel(FieldNames: string; FileName: string;
    SheetName: string; IsamFormat: string);
    procedure ExportToHtml(FieldNames: string; FileName: string);
    procedure ExportToParadox(FieldNames: string; FileName: string; IsamFormat: string);
    procedure ExportToDbase(FieldNames: string; FileName: string; IsamFormat: string);
    procedure ExportToTxt(FieldNames: string; FileName: string);
    published
    {/ Published declarations /}
    end;

    procedure Register;

    implementation

    procedure Register;
    begin
    RegisterComponents('Carlo Pasolini', [TExportADOTable]);
    end;

    constructor TExportADOTable.Create(AOwner: TComponent);
    begin
    inherited;

    FADOCommand := TADOCommand.Create(Self);
    end;


    procedure TExportADOTable.ExportToExcel(FieldNames: string; FileName: string;
    SheetName: string; IsamFormat: string);
    begin
    {/IsamFormat values
    Excel 3.0
    Excel 4.0
    Excel 5.0
    Excel 8.0
    /}

    if not Active then
    Exit;
    FADOCommand.Connection := Connection;
    FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    SheetName + ']' + ' IN ' + '"' + FileName + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
    if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
    if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
    FADOCommand.Execute;
    end;

    procedure TExportADOTable.ExportToHtml(FieldNames: string; FileName: string);
    var
    IsamFormat: string;
    begin
    if not Active then
    Exit;

    IsamFormat := 'HTML Export';

    FADOCommand.Connection := Connection;
    FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' +
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
    if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
    if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
    FADOCommand.Execute;
    end;


    procedure TExportADOTable.ExportToParadox(FieldNames&#58 ; string;
    FileName: string; IsamFormat: string);
    begin
    {/IsamFormat values
    Paradox 3.X
    Paradox 4.X
    Paradox 5.X
    Paradox 7.X
    /}
    if not Active then
    Exit;

    FADOCommand.Connection := Connection;
    FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' +
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
    if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
    if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
    FADOCommand.Execute;
    end;

    procedure TExportADOTable.ExportToDbase(FieldNames: string; FileName: string;
    IsamFormat: string);
    begin
    {/IsamFormat values
    dBase III
    dBase IV
    dBase 5.0
    /}
    if not Active then
    Exit;

    FADOCommand.Connection := Connection;
    FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' +
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
    if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
    if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
    FADOCommand.Execute;
    end;

    procedure TExportADOTable.ExportToTxt(FieldNames: string; FileName: string);
    var
    IsamFormat: string;
    begin
    if not Active then
    Exit;

    IsamFormat := 'Text';

    FADOCommand.Connection := Connection;
    FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' +
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
    if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
    if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
    FADOCommand.Execute;
    end;

    end.
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:35 عصر

  34. #74
    ایجاد خروجی از TDBGrid به قالب Excel
    unit DBGridExportToExcel;

    interface

    uses
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    ExtCtrls, StdCtrls, ComCtrls, DB, IniFiles, Buttons, dbgrids, ADOX_TLB, ADODB;


    type TScrollEvents = class
    BeforeScroll_Event: TDataSetNotifyEvent;
    AfterScroll_Event: TDataSetNotifyEvent;
    AutoCalcFields_Property: Boolean;
    end;

    procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
    procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
    procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);


    implementation

    //Support procedures: I made that in order to increase speed in
    //the process of scanning large amounts
    //of records in a dataset

    //we make a call to the "DisableControls" procedure and then disable the "BeforeScroll" and
    //"AfterScroll" events and the "AutoCalcFields" property.
    procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
    begin
    with DataSet do
    begin
    DisableControls;
    ScrollEvents := TScrollEvents.Create();
    with ScrollEvents do
    begin
    BeforeScroll_Event := BeforeScroll;
    AfterScroll_Event := AfterScroll;
    AutoCalcFields_Property := AutoCalcFields;
    BeforeScroll := nil;
    AfterScroll := nil;
    AutoCalcFields := False;
    end;
    end;
    end;

    //we make a call to the "EnableControls" procedure and then restore
    // the "BeforeScroll" and "AfterScroll" events and the "AutoCalcFields" property.
    procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
    begin
    with DataSet do
    begin
    EnableControls;
    with ScrollEvents do
    begin
    BeforeScroll := BeforeScroll_Event;
    AfterScroll := AfterScroll_Event;
    AutoCalcFields := AutoCalcFields_Property;
    end;
    end;
    end;

    //This is the procedure which make the work:

    procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);
    var
    cat: _Catalog;
    tbl: _Table;
    col: _Column;
    i: integer;
    ADOConnection: TADOConnection;
    ADOQuery: TADOQuery;
    ScrollEvents: TScrollEvents;
    SavePlace: TBookmark;
    begin
    //
    //WorkBook creation (database)
    cat := CoCatalog.Create;
    cat._Set_ActiveConnection('Provider=Microsoft. Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0');
    //WorkSheet creation (table)
    tbl := CoTable.Create;
    tbl.Set_Name(SheetName);
    //Columns creation (fields)
    DBGrid.DataSource.DataSet.First;
    with DBGrid.Columns do
    begin
    for i := 0 to Count - 1 do
    if Items[i].Visible then
    begin
    col := nil;
    col := CoColumn.Create;
    with col do
    begin
    Set_Name(Items[i].Title.Caption);
    Set_Type_(adVarWChar);
    end;
    //add column to table
    tbl.Columns.Append(col, adVarWChar, 20);
    end;
    end;
    //add table to database
    cat.Tables.Append(tbl);

    col := nil;
    tbl := nil;
    cat := nil;

    //exporting
    ADOConnection := TADOConnection.Create(nil);
    ADOConnection.LoginPrompt := False;
    ADOConnection.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0';
    ADOQuery := TADOQuery.Create(nil);
    ADOQuery.Connection := ADOConnection;
    ADOQuery.SQL.Text := 'Select * from [' + SheetName + '$]';
    ADOQuery.Open;


    DisableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);
    SavePlace := DBGrid.DataSource.DataSet.GetBookmark;
    try
    with DBGrid.DataSource.DataSet do
    begin
    First;
    while not Eof do
    begin
    ADOQuery.Append;
    with DBGrid.Columns do
    begin
    ADOQuery.Edit;
    for i := 0 to Count - 1 do
    if Items[i].Visible then
    begin
    ADOQuery.FieldByName(Items[i].Title.Ca ption).AsString := FieldByName(Items[i].FieldName).As String;
    end;
    ADOQuery.Post;
    end;
    Next;
    end;
    end;

    finally
    DBGrid.DataSource.DataSet.GotoBookmark(SavePla ce);
    DBGrid.DataSource.DataSet.FreeBookmark(SavePla ce);
    EnableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);

    ADOQuery.Close;
    ADOConnection.Close;

    ADOQuery.Free;
    ADOConnection.Free;

    end;

    end;

    end.
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:36 عصر

  35. #75
    دسترسی به جداول paradox روی cdrom یا درایوهای Read Only
    A:
    This Technical Information document will help step thru concepts regarding
    the creation and use of ALIASES within your Delphi Applications.

    Typically, you use the BDE Configuration Utility BDECFG.EXE to create and
    configure aliases outside of Delphi. However, with the use of the TDatabase
    component, you have the ability to create and use this ALIAS within your
    application-- not pre-defined in the IDAPI.CFG.

    The ability to create Aliases that are only available within your
    application is important. Aliases specify the location of database tables
    and connection parameters for database servers.
    Ultimately, you can gain the advantages of using ALIASES within your
    applications-- without having to worry about the existance of a
    configuration entry in the IDAPI.CFG when you deploy your
    application. /}

    {/Summary of Examples:/}
    {/Example #1:/}
    {/Example #1 creates and configures an Alias to use
    STANDARD (.DB, .DBF) databases. The Alias is
    then used by a TTable component./}
    {/Example #2:/}
    {/Example #2 creates and configures an Alias to use
    an INTERBASE database (.gdb). The Alias is then
    used by a TQuery component to join two tables of
    the database./}
    {/Example #3:/}
    {/Example #3 creates and configures an Alias to use
    STANDARD (.DB, .DBF) databases. This example
    demonstrates how user input can be used to
    configure the Alias during run-time./}


    {/Example #1: Use of a .DB or .DBF database (STANDARD)/}

    {/1. Create a New Project.

    2. Place the following components on the form: - TDatabase, TTable,
    TDataSource, TDBGrid, and TButton.

    3. Double-click on the TDatabase component or choose Database Editor from
    the TDatabase SpeedMenu to launch the Database Property editor.

    4. Set the Database Name to 'MyNewAlias'. This name will serve as your
    ALIAS name used in the DatabaseName Property for dataset components such as
    TTable, TQuery, TStoredProc.

    5. Select STANDARD as the Driveer Name.

    6. Click on the Defaults Button. This will automatically add a PATH= in
    the Parameter Overrides section.

    7. Set the PATH= to C:\DELPHI\DEMOS\DATA (PATH=C:\DELPHI\DEMOS\DATA)

    8. Click the OK button to close the Database Dialog.

    9. Set the TTable DatabaseName Property to 'MyNewAlias'.

    10. Set the TDataSource's DataSet Property to 'Table1'.

    11. Set the DBGrid's DataSource Property to 'DataSource1'.

    12. Place the following code inside of the TButton's OnClick event./}

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    Table1.TableName := 'CUSTOMER';
    Table1.Active := True;
    end;

    {/13. Run the application./}


    {/*** If you want an alternative way to steps 3 - 11, place the following
    code inside of the TButton's OnClick event./}

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    Database1.DatabaseName := 'MyNewAlias';
    Database1.DriverName := 'STANDARD';
    Database1.Params.Clear;
    Database1.Params.Add('PATH=C:\DELPHI\DEMOS \DATA');
    Table1.DatabaseName := 'MyNewAlias';
    Table1.TableName := 'CUSTOMER';
    Table1.Active := True;
    DataSource1.DataSet := Table1;
    DBGrid1.DataSource := DataSource1;
    end;

    {/Example #2: Use of a INTERBASE database/}

    {/1. Create a New Project.

    2. Place the following components on the form: - TDatabase, TQuery,
    TDataSource, TDBGrid, and TButton.

    3. Double-click on the TDatabase component or choose Database Editor from
    the TDatabase SpeedMenu to launch the Database Property editor.

    4. Set the Database Name to 'MyNewAlias'. This name will serve as your
    ALIAS name used in the DatabaseName Property for dataset components such as
    TTable, TQuery, TStoredProc.

    5. Select INTRBASE as the Driver Name.

    6. Click on the Defaults Button. This will automatically add the
    following entries in the Parameter Overrides section.

    SERVER NAME=IB_SERVEER:/PATH/DATABASE.GDB
    USER NAME=MYNAME
    OPEN MODE=READ/WRITE
    SCHEMA CACHE SIZE=8
    LANGDRIVER=
    SQLQRYMODE=
    SQLPASSTHRU MODE=NOT SHARED
    SCHEMA CACHE TIME=-1
    PASSWORD=

    7. Set the following parameters

    SERVER NAME=C:\IBLOCAL\EXAMPLES\EMPLOYEE.GDB
    USER NAME=SYSDBA
    OPEN MODE=READ/WRITE
    SCHEMA CACHE SIZE=8
    LANGDRIVER=
    SQLQRYMODE=
    SQLPASSTHRU MODE=NOT SHARED
    SCHEMA CACHE TIME=-1
    PASSWORD=masterkey

    8. Set the TDatabase LoginPrompt Property to 'False'. If you supply the
    PASSWORD in the Parameter Overrides section and set the LoginPrompt to
    'False', you will not be prompted for the
    password when connecting to the database. WARNING: If an incorrect
    password in entered in the Parameter Overrides section and LoginPrompt is
    set to 'False', you are not prompted by the Password dialog to re-enter a
    valid password.

    9. Click the OK button to close the Database Dialog.

    10. Set the TQuery DatabaseName Property to 'MyNewAliias'.

    11. Set the TDataSource's DataSet Property to 'Query1'.

    12. Set the DBGrid's DataSource Property to 'DataSource1'.

    13. Place the following code inside of the TButton's OnClick event./}

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    Query1.SQL.Clear;
    Query1.SQL.Add('SELECT DISTINCT * FROM CUSTOMER C, SALES S
    WHERE(S.CUST_NO = C.CUST_NO)
    ORDER BY C.CUST_NO, C.CUSTOMER');
    Query1.Active := True;
    end;

    {/14. Run the application./}


    {/Example #3: User-defined Alias Configuration/}

    {/This example brings up a input dialog and prompts the user to enter the
    directory to which the ALIAS is to be configured to.

    The directory, servername, path, database name, and other neccessary Alias
    parameters can be read into the application from use of an input dialog or
    .INI file.

    1. Follow the steps (1-11) in Example #1.

    2. Place the following code inside of the TButton's OnClick event./}

    procedure TForm1.Buttton1Click(Sender: TObject);
    var
    NewString: string;
    ClickedOK: Boolean;
    begin
    NewString := 'C:\';
    ClickedOK := InputQuery('Database Path',
    'Path: --> C:\DELPHI\DEMOS\DATA', NewString);
    if ClickedOK then
    begin
    Database1.DatabaseName := 'MyNewAlias';
    Database1.DriverName := 'STANDARD';
    Database1.Params.Clear;
    Database1.Params.Add('Path=' + NewString);
    Table1.DatabaseName := 'MyNewAlias';
    Table1.TableName := 'CUSTOMER';
    Table1.Active := True;
    DataSource1.DataSet := Table1;
    DBGrid1.DataSource := DataSource1;
    end;
    end;

    //3. Run the Application
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:37 عصر

  36. #76
    ایجاد یک جدول مجازی
    unit Inmem;

    interface

    uses DBTables, WinTypes, WinProcs, DBITypes, DBIProcs, DB, SysUtils;

    type
    TInMemoryTable = class(TTable)
    private
    hCursor: hDBICur;
    procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
    const Name: string; DataType: TFieldType; Size: Word);
    function CreateHandle: HDBICur; override;
    public
    procedure CreateTable;
    end;

    implementation

    {/
    Luckely this function is virtual - so I could override it. In the
    original VCL code for TTable this function actually opens the table -
    but since we already have the handle to the table - we just return it
    /}

    function TInMemoryTable.CreateHandle;
    begin
    Result := hCursor;
    end;

    {/
    This function is cut-and-pasted from the VCL source code. I had to do
    this because it is declared private in the TTable component so I had no
    access to it from here.
    /}

    procedure TInMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc;
    const Name: string; DataType: TFieldType; Size: Word);
    const
    TypeMap: array[TFieldType] of Byte = (fldUNKNOWN, fldZSTRING, fldINT16,
    fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
    begin
    with FieldDesc do
    begin
    AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
    iFldType := TypeMap[DataType];
    case DataType of
    ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic:
    iUnits1 := Size;
    ftBCD:
    begin
    iUnits1 := 32;
    iUnits2 := Size;
    end;
    end;
    case DataType of
    ftCurrency:
    iSubType := fldstMONEY;
    ftBlob:
    iSubType := fldstBINARY;
    ftMemo:
    iSubType := fldstMEMO;
    ftGraphic:
    iSubType := fldstGRAPHIC;
    end;
    end;
    end;

    {/
    This is where all the fun happens. I copied this function from the VCL
    source and then changed it to use DbiCreateInMemoryTable instead of
    DbiCreateTable.

    Since InMemory tables do not support Indexes - I took all of the
    index-related things out
    /}

    procedure TInMemoryTable.CreateTable;
    var
    I: Integer;
    pFieldDesc: pFLDDesc;
    szTblName: DBITBLNAME;
    iFields: Word;
    Dogs: pfldDesc;
    begin
    CheckInactive;
    if FieldDefs.Count = 0 then
    for I := 0 to FieldCount - 1 do
    with Fields[I] do
    if not Calculated then
    FieldDefs.Add(FieldName, DataType, Size, Required);
    pFieldDesc := nil;
    SetDBFlag(dbfTable, True);
    try
    AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
    iFields := FieldDefs.Count;
    pFieldDesc := AllocMem(iFields * SizeOf(FLDDesc));
    for I := 0 to FieldDefs.Count - 1 do
    with FieldDefs[I] do
    begin
    EncodeFieldDesc(PFieldDescList(pFieldDesc& #41;^[I], Name,
    DataType, Size);
    end;
    {/ the driver type is nil = logical fields /}
    Check(DbiTranslateRecordStructure(nil, iFields, pFieldDesc,
    nil, nil, pFieldDesc));
    {/ here we go - this is where hCursor gets its value /}
    Check(DbiCreateInMemTable(DBHandle, szTblName, iFields, pFieldDesc, hCursor));
    finally
    if pFieldDesc <> nil then FreeMem(pFieldDesc, iFields * SizeOf(FLDDesc));
    SetDBFlag(dbfTable, False);
    end;
    end;

    end.
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:38 عصر

  37. #77
    ایجاد سریع یک جدول پارادوکس به کمک کد
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    with Query1 do
    begin
    DatabaseName := 'DBDemos';
    with SQL do
    begin
    Clear;
    {/
    CREATE TABLE creates a table with the given name in the
    current database

    CREATE TABLE erzeugt eine Tabelle mit einem angegebenen
    Namen in der aktuellen Datenbank
    /}
    Add('CREATE TABLE "PDoxTbl.db" (ID AUTOINC,');
    Add('Name CHAR(255),');
    Add('PRIMARY KEY(ID))');
    {/
    Call ExecSQL to execute the SQL statement currently
    assigned to the SQL property.

    Mit ExecSQL wird die Anweisung ausgeführt,
    welche aktuell in der Eigenschaft SQL enthalten ist.
    /}
    ExecSQL;
    Clear;
    Add('CREATE INDEX ByName ON "PDoxTbl.db" (Name)');
    ExecSQL;
    end;
    end;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:38 عصر

  38. #78
    ایجاد یک اتصال DBExpress در زمان اجرا
    procedure TVCLScanner.PostUser(const Email, FirstName, LastName: WideString);
    var
    Connection: TSQLConnection;
    DataSet: TSQLDataSet;
    begin
    Connection := TSQLConnection.Create(nil);
    with Connection do
    begin
    ConnectionName := 'VCLScanner';
    DriverName := 'INTERBASE';
    LibraryName := 'dbexpint.dll';
    VendorLib := 'GDS32.DLL';
    GetDriverFunc := 'getSQLDriverINTERBASE';
    Params.Add('User_Name=SYSDBA');
    Params.Add('Password=masterkey');
    Params.Add('Database=milo2:D:\frank\we bservices\umlbank.gdb');
    LoginPrompt := False;
    Open;
    end;
    DataSet := TSQLDataSet.Create(nil);
    with DataSet do
    begin
    SQLConnection := Connection;
    CommandText := Format('INSERT INTO kings VALUES("%s","%s","%s")',
    [Email, FirstN, LastN]);
    try
    ExecSQL;
    except
    end;
    end;
    Connection.Close;
    DataSet.Free;
    Connection.Free;
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:39 عصر

  39. #79
    رنگ آمیزی یک TDBGrid
    procedure TForm1.ColorGrid(dbgIn: TDBGrid; qryIn: TQuery; const Rect: TRect;
    DataCol: Integer; Column: TColumn;
    State: TGridDrawState);
    var
    iValue: LongInt;
    begin
    // color only the first field
    // nur erstes Feld einf&auml;rben
    if (DataCol = 0) then
    begin
    // Check the field value and assign a color
    // Feld-Wert prüfen und entsprechende Farbe w&auml;hlen
    iValue := qryIn.FieldByName('HINWEIS_COLOR').AsInteg er;
    case iValue of
    1: dbgIn.Canvas.Brush.Color := clGreen;
    2: dbgIn.Canvas.Brush.Color := clLime;
    3: dbgIn.Canvas.Brush.Color := clYellow;
    4: dbgIn.Canvas.Brush.Color := clRed;
    end;
    // Draw the field
    // Feld zeichnen
    dbgIn.DefaultDrawColumnCell(Rect, DataCol, Column, State);
    end;
    end;

    procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
    const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
    begin
    ColorGrid(DBGrid1, Query1, Rect, DataCol, Column, State);
    end;
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:40 عصر

  40. #80
    خواندن تمام رکوردهای یک جدول در TstringGrid
    Loading millions of records into a stringlist can be very slow /}

    procedure TForm1.SlowLoadingIntoStringList(StringList: TStringList);
    begin
    StringList.Clear;
    with SourceTable do
    begin
    Open;
    DisableControls;
    try
    while not EOF do
    begin
    StringList.Add(FieldByName('OriginalData').AsStrin g);
    Next;
    end;
    finally
    EnableControls;
    Close;
    end;
    end;
    end;

    {/ This is much, much faster /}
    procedure TForm1.QuickLoadingIntoStringList(StringList: TStringList);
    begin
    with CacheTable do
    begin
    Open;
    try
    StringList.Text := FieldByName('Data').AsString;
    finally
    Close;
    end;
    end;
    end;

    {/ How can this be done?

    In Microsoft SQL Server 7, you can write a stored procedure that updates every night
    a cache table that holds all the data you want in a single column and row.
    In this example, you get the data from a SourceTable and put it all in a Cachetable.
    The CacheTable has one blob column and must have only one row.
    Here it is the SQL code: /}


    Create Table CacheTable
    (Data Text NULL)
    GO

    Create

    procedure PopulateCacheTable as
    begin
    set NOCOUNT on
    DECLARE @ptrval binary(16), @Value varchar(600) -
    - a good Value for the expected maximum Length
    - - You must set 'select into/bulkcopy' option to True in order to run this sp
    DECLARE @dbname nvarchar(128)
    set @dbname = db_name()
    EXEC sp_dboption @dbname, 'select into/bulkcopy', 'true'
    - - Declare a cursor
    DECLARE scr CURSOR for
    SELECT OriginalData + char(13) + char(10) - - each line in a TStringList is
    separated by a #13#10
    FROM SourceTable
    - - The CacheTable Table must have only one record
    if EXISTS (SELECT * FROM CacheTable)
    Update CacheTable set Data = ''
    else
    Insert CacheTable VALUES('')
    - - Get a Pointer to the field we want to Update
    SELECT @ptrval = TEXTPTR(Data) FROM CacheTable

    Open scr
    FETCH Next FROM scr INTO @Value
    while @ @FETCH_STATUS = 0
    begin - - This UPDATETEXT appends each Value to the
    end
    of the blob field
    UPDATETEXT CacheTable.Data @ptrval NULL 0 @Value
    FETCH Next FROM scr INTO @Value
    end
    Close scr
    DEALLOCATE scr
    - - Reset this option to False
    EXEC sp_dboption @dbname, 'select into/bulkcopy', 'false'
    end
    GO

    {/ You may need to increase the BLOB SIZE parameter if you use BDE /}
    آخرین ویرایش به وسیله بهروز عباسی : چهارشنبه 09 مرداد 1392 در 16:44 عصر

صفحه 2 از 11 اولاول 1234 ... آخرآخر

برچسب های این تاپیک

قوانین ایجاد تاپیک در تالار

  • شما نمی توانید تاپیک جدید ایجاد کنید
  • شما نمی توانید به تاپیک ها پاسخ دهید
  • شما نمی توانید ضمیمه ارسال کنید
  • شما نمی توانید پاسخ هایتان را ویرایش کنید
  •