صفحه 1 از 13 1234511 ... آخرینآخرین
نمایش نتایج: از شماره 1 تا 16 , از مجموع 201

موضوع: نکات برنامه نویسی در دلفی ‏

  1. #1
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    باز و بسته کردن سیدی درایو

    با استفاده از این فانکشن میتونید در هر نوع سیدی درایوی رو باز و بسته کنید
    در اثر فشارهای مکرر دوستان من ترجمه فارسی توضیحات رو هم به کدها اضافه کردم

    کد:
    uses
    MMSystem;
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    {
    باز کردن سیدی رام: در صورت موفقیت 0 برمیگرداند}
    { open CD-ROM drive; returns 0 if successfull }
    mciSendString('set cdaudio door open wait', nil, 0, handle);
    { close the CD-ROM drive; returns 0 if successfull }
    {
    بستن سیدی رام: در صورت موفقیت 0 برمیگرداند}
    mciSendString('set cdaudio door closed wait', nil, 0, handle);
    end;

  2. #2
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    تغییر Volume ویندوز

    تغییر Volume ویندوز

    یک TrackBar در فرم خود قرار دهید و Max value را به 15 تغییر دهید و در رویداد OnChange آن کد زیر را قرار دهید:

    کد:
    procedure TForm1.TrackBar1Change(Sender: TObject);
    var
    Count, i: integer;
    begin
    Count := waveOutGetNumDevs;
    for i := 0 to Count do
    begin
    waveOutSetVolume(i,longint(TrackBar1.Position*4369 )*65536+longint(TrackBar1.Position*4369));
    end;
    end;
    و با TrackBar بازی کنید

  3. #3
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    چگونه لیست سیدی درایوهای کامپیوتر را بدست آوریم

    به دست آوردن لیست سیدی درایوهای متصل به کامپیوتر
    یک فانشکن مینویسیم که یک استرینگ بر میگرداند

    کد:
    Function GetCDList : String;
    Var
    I : Integer;
    Drives: Integer;
    Tmp : String;
    begin
    Drives := GetLogicalDrives;
    Result := '';
    // units A=0 to el Z=25
    For I := 0 To 25 Do
    If (((1 Shl I) And Drives)<>0) Then
    Begin
    Tmp := Char(65+I)+':\';
    If (GetDriveType(PChar(Tmp))=DRIVE_CDROM) Then
    Result := Result+Char(65+I);
    End;
    End;
    نتیجه یک استرینگ است که لیست سیدی درایوها را بترتیب نشان میدهد

  4. #4
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    تغییر Resolution مونیتور

    تغییر Resolution مونیتور

    باید یک پروسیجر به شکل زیر بنویسیم:

    کد:
    procedure SetResolution(ResX, ResY: DWord);
    var
    lDeviceMode : TDeviceMode;
    begin
    EnumDisplaySettings(nil, 0, lDeviceMode);
    lDeviceMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT;
    lDeviceMode.dmPelsWidth :=ResX;
    lDeviceMode.dmPelsHeight:=ResY;
    ChangeDisplaySettings(lDeviceMode, 0);
    end;
    نکته بسیار مهم:

    اگر اعداد غیر استاندارد برای Resolutoin مونیتوروارد کنید احتمال آسیب رسیدن به مونیتور وجود دارد، از رزولوشن هایاستاندارد مثل 320*240 ، 640*480 ، 1024*768 و ... استفاده کنید

  5. #5
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    قرار دادن یک Bitmap در یک متافایل

    قرار دادن یک Bitmap در یک متافایل


    کد:
    procedure TForm1.Button1Click(Sender: TObject);
    var
    m : TmetaFile;
    mc : TmetaFileCanvas;
    b : tbitmap;
    begin
    m := TMetaFile.Create;
    b := TBitmap.create;
    b.LoadFromFile('C:\SomePath\SomeBitmap.BMP');
    m.Height := b.Height;
    m.Width := b.Width;
    mc := TMetafileCanvas.Create(m, 0);
    mc.Draw(0, 0, b);
    mc.Free;
    b.Free;
    m.SaveToFile('C:\SomePath\Test.emf');
    m.Free;
    Image1.Picture.LoadFromFile('C:\SomePath\Test.emf' );
    end;

  6. #6
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    با استفاده از این فانکشن کوچولو میتونید هر نوع برنامه اجرا شده ای رو که پسوند .Exe دارد، از لیست Task Manager ویندوز پاک کنید
    مثلا:
    کد:
    KillTask('notepad.exe');
    KillTask('iexplore.exe'); }

    کد:
    uses
    Tlhelp32, Windows, SysUtils;

    function KillTask(ExeFileName: string): integer;
    const
    PROCESS_TERMINATE=$0001;
    var
    ContinueLoop: BOOL;
    FSnapshotHandle: THandle;
    FProcessEntry32: TProcessEntry32;
    begin
    result := 0;

    FSnapshotHandle := CreateToolhelp32Snapshot
    (TH32CS_SNAPPROCESS, 0);
    FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
    ContinueLoop := Process32First(FSnapshotHandle,
    FProcessEntry32);

    while integer(ContinueLoop) <> 0 do
    begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeF ile)) =
    UpperCase(ExeFileName))
    or (UpperCase(FProcessEntry32.szExeFile) =
    UpperCase(ExeFileName))) then
    Result := Integer(TerminateProcess(OpenProcess(
    PROCESS_TERMINATE, BOOL(0),
    FProcessEntry32.th32ProcessID), 0));
    ContinueLoop := Process32Next(FSnapshotHandle,
    FProcessEntry32);
    end;

    CloseHandle(FSnapshotHandle);
    end;

  7. #7
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    کد:
    function GetCheckSum (FileName : string) : DWORD;
    var
    F : File of DWORD;
    Fsize : DWORD;
    Buffer : Array [0..500] of DWORD;
    P : Pointer;
    begin
    FileMode := 0;
    AssignFile ( F , FileName);
    Reset ( F );
    Seek ( F , FileSize ( F ) div 2);
    Fsize := FileSize( F )-1-FilePos( F );
    if Fsize > 500 then Fsize := 500;
    BlockRead ( F, Buffer, Fsize);
    Close ( F );
    P:=@Buffer;
    asm
    xor eax, eax
    xor ecx, ecx
    mov edi , p
    @again:
    add eax, [edi + 4*ecx]
    inc ecx
    cmp ecx, fsize
    jl @again
    mov @result, eax
    end;
    end;

  8. #8
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    عملیات قابل انجام روی فلاپی دیسک
    این کد کلیه فانکشکنهایی که برای کار با فلاپی درایو مورد نیاز است را در بردارد.

    کد:
    ================================================== ===========
    unit lDrives;
    interface
    uses Forms, Messages, Classes, WinProcs, WinTypes, SysUtils,
    Dialogs, Controls;

    const
    MsgAskDefault = 'Please insert a disk on drive %s:';
    MsgWProtected = 'Error: The disk %s is write-protected.';

    type
    TDriveType = (dtAll,dtFixed,dtRemovable,dtRemote{$IFDEF WIN32},dtCDRom,dtRamDisk{$ENDIF});

    function ComposeFileName (Dir,Name:string):string;
    function HasDiskSpace({$IFDEF WIN32}Drive: string{$ELSE}Drive: char{$ENDIF}; MinRequired: LongInt): boolean;
    function GetDirectorySize(const Path: string): LongInt;
    function GetFileSizeByName(const Filename: string): longInt;
    function IsDiskRemovable(Drive: char): boolean;
    function IsDiskInDrive(Drive: char): boolean;
    function IsDiskWriteProtected(Drive: char): boolean;
    function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;
    procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);

    implementation

    function ComposeFileName (Dir,Name:string):string;
    var
    Separator: string[1];
    begin
    if (length(Dir) > 0) and (Dir[length(Dir)]='\') then
    delete(Dir, length(Dir), 1);
    if (length(Name) > 0) and (Name[1]='\') then
    delete(Name, 1, 1);
    if Name='' then Separator:='' else Separator:='\';
    result:=format('%s%s%s',[Dir,Separator,Name]);
    end;

    function HasDiskSpace(Drive: {$IFDEF WIN32}string{$ELSE}char{$ENDIF}; MinRequired: LongInt): boolean;
    begin
    if Drive='' then Drive:='C';
    {$IFDEF WIN32}
    result:=((GetDriveType(PChar(Drive))<>0) and
    (SysUtils.DiskFree(Ord(UpCase(Drive[1]))-$40)=-1) or
    (SysUtils.DiskFree(Ord(UpCase(Drive[1]))-$40)>=MinRequired));
    {$ELSE}
    result:=((GetDriveType(Ord(UpCase(Drive))-$40)<>0) and
    (DiskFree(Ord(UpCase(Drive))-$40)=-1) or
    (DiskFree(Ord(UpCase(Drive))-$40)>=MinRequired));
    {$ENDIF}
    end;

    function GetDirectorySize(const Path: string): LongInt;
    var
    S: TSearchRec;
    TotalSize: LongInt;
    begin
    TotalSize:=0;
    if FindFirst(ComposeFileName(Path,'*.*'), faAnyFile, S)=0 then
    repeat
    Inc(TotalSize, S.Size);
    until FindNext(S)<>0;
    result:=TotalSize;
    end;

    function GetFileSizeByName(const Filename: string): longInt;
    var
    F: File;
    begin
    AssignFile(F, Filename);
    Reset(F,1);
    result:=FileSize(F);
    CloseFile(F);
    end;

    function IsDiskRemovable(Drive: char): boolean;
    begin
    {$IFDEF WIN32}
    result:=GetDriveType(PChar(Drive+':\'))=DRIVE_REMO VABLE;
    {$ELSE}
    result:=GetDriveType(ord(UpCase(Drive))-65)=DRIVE_REMOVABLE;
    {$ENDIF}
    end;

    function IsDiskInDrive(Drive: char): Boolean;
    var
    ErrorMode: word;
    begin
    Drive:=Upcase(Drive);
    if not (Drive in ['A'..'Z']) then
    begin
    Result:=False;
    Exit;
    end;
    ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
    try
    if DiskSize(Ord(Drive) - 64) = -1 then
    Result := False
    else
    Result := True;
    finally
    SetErrorMode(ErrorMode);
    end;
    end;

    function IsDiskWriteProtected(Drive: char): Boolean;
    var
    F: File;
    ErrorMode: Word;
    begin
    ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
    AssignFile(F,Drive+':\_$.$$$');
    try
    try
    Rewrite(F);
    CloseFile(F);
    Erase(F);
    Result:=False;
    except
    Result:=True;
    end;
    finally
    SetErrorMode(ErrorMode);
    end;
    end;

    {$IFDEF WIN32}
    procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
    var
    Drive: Integer;
    DriveLetter: string;
    begin
    Items.Clear;
    for Drive := 0 to 25 do
    begin
    DriveLetter := Chr(Drive + ord('A'))+':\';
    case DriveType of
    dtAll : if GetDriveType(PChar(DriveLetter)) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE,
    DRIVE_CDROM,DRIVE_RAMDISK] then
    Items.Add(DriveLetter);
    dtRemovable: if GetDriveType(PChar(DriveLetter))=DRIVE_REMOVABLE then
    Items.Add(DriveLetter);
    dtFixed : if GetDriveType(PChar(DriveLetter))=DRIVE_FIXED then
    Items.Add(DriveLetter);
    dtRemote : if GetDriveType(PChar(DriveLetter))=DRIVE_REMOTE then
    Items.Add(DriveLetter);
    dtCDRom : if GetDriveType(PChar(DriveLetter))=DRIVE_CDROM then
    Items.Add(DriveLetter);
    dtRamDisk : if GetDriveType(PChar(DriveLetter))=DRIVE_RAMDISK then
    Items.Add(DriveLetter);
    end;
    end;
    end;
    {$ELSE}
    procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
    var
    Drive: Integer;
    DriveLetter: char;
    begin
    Items.Clear;
    for Drive := 0 to 25 do
    begin
    DriveLetter := Chr(Drive + ord('A'));
    case DriveType of
    dtAll : if GetDriveType(Drive) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE] then
    Items.Add(DriveLetter+':\');
    dtRemovable: if GetDriveType(Drive)=DRIVE_REMOVABLE then
    Items.Add(DriveLetter+':\');
    dtFixed : if GetDriveType(Drive)=DRIVE_FIXED then
    Items.Add(DriveLetter+':\');
    dtRemote : if GetDriveType(Drive)=DRIVE_REMOTE then
    Items.Add(DriveLetter+':\');
    end;
    end;
    end;
    {$ENDIF}

    function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;
    var
    Ready : boolean;
    begin
    Ready:=false; Result:=false;
    if Msg='' then Msg:=Format(MsgAskDefault,[Drive]);
    while not(Ready) do
    try
    if IsDiskRemovable(Drive) then
    case MessageDlg(Msg, mtConfirmation, [mbOk,mbCancel],0) of
    mrOk : ready:=IsDiskInDrive(Drive);
    mrCancel: exit;
    end
    else
    Ready:=true;
    except
    result:=false;
    exit;
    end;
    ready:=false;
    while not(Ready) do
    try
    if CheckWriteProtected and IsDiskWriteProtected(Drive) then
    begin
    ready:=false;
    if MessageDlg(Format(MsgWProtected,[Upcase(Drive)+':']),mtError,[mbRetry,mbCancel],0)=mrCancel then
    exit;
    end
    else
    ready:=true;
    except
    result:=false;
    exit;
    end;
    result:=Ready;
    end;

    end.

  9. #9
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    اضافه کردن تکست به Log Files
    کد:
    function AddTextToFile(const aFileName, aText: string; AddCRLF: Boolean): Boolean;
    var
    lF: Integer;
    lS: string;
    begin
    Result := False;
    if FileExists(aFileName) then lF := FileOpen(aFileName, fmOpenWrite + fmShareDenyNone)
    else lF := FileCreate(aFileName);
    if (lF >= 0) then
    try
    FileSeek(lF, 0, 2);
    if AddCRLF then lS := aText + #13#10
    else lS := aText;
    FileWrite(lF, lS[1], Length(lS));
    finally
    FileClose(lF);
    end;
    end;

  10. #10
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    دیالوگ برای Select Directory
    کد:
    uses FileCtrl; // for SelectDirectory

    var
    Dir: string;
    (...)
    Dir := 'C:\Windows';
    if SelectDirectory(Dir, [sdAllowCreate, sdPerformCreate,
    sdPrompt], 0) then
    Label1.Caption := Dir

  11. #11
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    کد:
    const
    PIDiv180 = 0.017453292519943295769236907684886;

    procedure Rotate(RotAng: Double; x, y, ox, oy: Double; var Nx, Ny: Double);
    begin
    Rotate(RotAng, x - ox, y - oy, Nx, Ny);
    Nx := Nx + ox;
    Ny := Ny + oy;
    end;
    (* End Of Rotate Cartesian Point About Origin *)


    procedure Rotate(RotAng: Double; x, y: Double; var Nx, Ny: Double);
    var
    SinVal: Double;
    CosVal: Double;
    begin
    RotAng := RotAng * PIDiv180;
    SinVal := Sin(RotAng);
    CosVal := Cos(RotAng);
    Nx := x * CosVal - y * SinVal;
    Ny := y * CosVal + x * SinVal;
    end;

  12. #12
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    Screen Shots
    با استفاده از این کد میتوانید تصویر Screen را در یک فایل Bitmap ذخیره نمائید. اگر نمیخواهید از یک برنامه فعال دلفی استفاده کنید میتوانید یک 'Application.Minimize;' در Beginning پروسیجر وارد کنید.

    کد:

    uses
    Windows, Graphics, Forms;

    procedure TForm1.Button1Click(Sender: TObject);
    var
    DC: HDC;
    Canvas: TCanvas;
    MyBitmap: TBitmap;
    begin
    Canvas := TCanvas.Create;
    MyBitmap := TBitmap.Create;
    DC := GetDC(0);

    try
    Canvas.Handle := DC;
    with Screen do
    begin
    { detect the actual height and with of the screen }
    MyBitmap.Width := Width;
    MyBitmap.Height := Height;

    { copy the screen content to the bitmap }
    MyBitmap.Canvas.CopyRect(Rect(0, 0, Width, Height), Canvas,
    Rect(0, 0, Width, Height));
    { stream the bitmap to disk }
    MyBitmap.SaveToFile('c:\windows\desktop\screen.bmp ');
    end;

    finally
    { free memory }
    ReleaseDC(0, DC);
    MyBitmap.Free;
    Canvas.Free
    end;
    end;

  13. #13
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    کد:
    function CalculateAge(Birthday, CurrentDate: TDate): Integer;
    var
    Month, Day, Year, CurrentYear, CurrentMonth, CurrentDay: Word;
    begin
    DecodeDate(Birthday, Year, Month, Day);
    DecodeDate(CurrentDate, CurrentYear, CurrentMonth, CurrentDay);

    if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then
    begin
    Result := 0;
    end
    else
    begin
    Result := CurrentYear - Year;
    if (Month > CurrentMonth) then
    Dec(Result)
    else
    begin
    if Month = CurrentMonth then
    if (Day > CurrentDay) then
    Dec(Result);
    end;
    end;
    end;

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    Label1.Caption := Format('Your age is %d', [CalculateAge(StrToDate('01.01.1903'), Date)]);
    end;

  14. #14
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    کد:
    function Log(x, b: Real): Real;
    begin
    Result := ln(x) / ln(b);
    end;

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    ShowMessage(Format('%f', [Log(10, 10)]));
    end;

  15. #15
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    کد:
    type
    IntNo = record
    Low32, Hi32: DWORD;
    end;

    function Multiply(p, q: DWORD): IntNo;
    var
    x: IntNo;
    begin
    asm
    MOV EAX,[p]
    MUL [q]
    MOV [x.Low32],EAX
    MOV [x.Hi32],EDX
    end;
    Result := x
    end;



    var
    r: IntNo;
    begin
    r := Multiply(40000000, 80000000);
    ShowMessage(IntToStr(r.Hi32) + ', ' + IntToStr(r.low32))
    end;

  16. #16
    کاربرسایت PARS آواتار ها
    تاریخ عضویت
    ۸۷-۰۲-۲۵
    نوشته ها
    666
    سپاس ها
    0
    سپاس شده 0 در 0 پست

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

    کد:
    function Decode(const S: AnsiString): AnsiString;
    const
    Map: array[Char] of Byte = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, 0, 0, 0, 63, 52, 53,
    54, 55, 56, 57, 58, 59, 60, 61, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2,
    3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
    20, 21, 22, 23, 24, 25, 0, 0, 0, 0, 0, 0, 26, 27, 28, 29, 30,
    31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,
    46, 47, 48, 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0);
    var
    I: LongInt;
    begin
    case Length(S) of
    2:
    begin
    I := Map[S[1]] + (Map[S[2]] shl 6);
    SetLength(Result, 1);
    Move(I, Result[1], Length(Result))
    end;
    3:
    begin
    I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12);
    SetLength(Result, 2);
    Move(I, Result[1], Length(Result))
    end;
    4:
    begin
    I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12) +
    (Map[S[4]] shl 18);
    SetLength(Result, 3);
    Move(I, Result[1], Length(Result))
    end
    end
    end;

    function Encode(const S: AnsiString): AnsiString;
    const
    Map: array[0..63] of Char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +
    'abcdefghijklmnopqrstuvwxyz0123456789+/';
    var
    I: LongInt;
    begin
    I := 0;
    Move(S[1], I, Length(S));
    case Length(S) of
    1:
    Result := Map[I mod 64] + Map[(I shr 6) mod 64];
    2:
    Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
    Map[(I shr 12) mod 64];
    3:
    Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
    Map[(I shr 12) mod 64] + Map[(I shr 18) mod 64]
    end
    end;

صفحه 1 از 13 1234511 ... آخرینآخرین

اطلاعات موضوع

کاربرانی که در حال مشاهده این موضوع هستند

در حال حاضر 1 کاربر در حال مشاهده این موضوع است. (0 کاربران و 1 مهمان ها)

موضوعات مشابه

  1. طریقه گزارش نویسی
    توسط HRG در انجمن مقالات علمی
    پاسخ ها: 0
    آخرين نوشته: شنبه ۰۸ اسفند ۸۸, ۲۱:۱۲
  2. برنامه نویسی گرافیک در c و ++c
    توسط PARS در انجمن C و ++‍C
    پاسخ ها: 5
    آخرين نوشته: پنجشنبه ۲۲ بهمن ۸۸, ۱۷:۵۴
  3. راهنمای برنامه نویسی پاسکال (pdf)
    توسط PARS در انجمن برنامه نويسي
    پاسخ ها: 0
    آخرين نوشته: جمعه ۱۶ بهمن ۸۸, ۲۱:۱۲
  4. عددنویسی رومی
    توسط hrg1356 در انجمن مطالب جامع وکاربردی ریاضی
    پاسخ ها: 0
    آخرين نوشته: پنجشنبه ۰۷ آبان ۸۸, ۰۸:۴۸
  5. فرهنگ نویسی در ايران
    توسط hrg1356 در انجمن کتاب و فرهنگ مطالعه
    پاسخ ها: 7
    آخرين نوشته: سه شنبه ۰۹ مرداد ۸۶, ۲۲:۲۶

مجوز های ارسال و ویرایش

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