کدهای آماده دلفی افزایش بازدید - افزایش بازدید و ترافیک سایت شما
سفارش تبلیغ
صبا ویژن
آنکه دانش می جوید، خداوند روزیش را به عهده می گیرد . [پیامبر خدا صلی الله علیه و آله]
کدهای آماده دلفی

با استفاده از این تابع می توانید بین صفحه کلید فارسی و صفحه کلید پیش فرض یکی را با استفاده از کد انتخاب کنید

//Change to farsi
loadkeyboardlayout("00000429", KLF_Activate);


//Change to default(English)
 loadkeyboardlayout("0000000", KLF_Activate



محمد مقصودلو ::: شنبه 87/4/29::: ساعت 11:42 صبح

با استفاده از این تابع می توانید چک کنید که آیا به اینترنت متصل هستید یا خیر

const
INTERNET_CONNECTION_MODEM      = 1;
INTERNET_CONNECTION_LAN      = 2;
INTERNET_CONNECTION_PROXY      = 4;
INTERNET_CONNECTION_MODEM_BUSY      = 8;

function InternetGetConnectedState(lpdwFlags: LPDWORD;
dwReserved: DWORD): BOOL; stdcall; external "WININET.DLL";

function IsConnectedToInternet: Boolean;
var
dwConnectionTypes: Integer;
begin
try
  dwConnectionTypes := INTERNET_CONNECTION_MODEM +
INTERNET_CONNECTION_LAN +
INTERNET_CONNECTION_PROXY;
  if InternetGetConnectedState(@dwConnectionTypes, 0) then
    Result := true
  else
    Result := false;
except
  Result := false;
end;
end;

به عنوان مثال


procedure TForm1.Button1Click(Sender: T);
begin
If IsConnectedToInternet Then
 ShowMessage("Ok...You Connected To Internet") // do something, we are connected
Else
 ShowMessage("No...You Not Connected To Internet")  // No active connection
end;

برگرفته شده از سایت دنیای برنامه نویسی دلفی(http://mt85.blogfa.com)



محمد مقصودلو ::: شنبه 87/4/29::: ساعت 11:41 صبح

با استفاده از این تابع می توانید از این پس به راحتی اطلاعات را از بانک خود به نرم افزار اکسل انتقال دهید
نکته این که قبل از استفاده باید نرم افزار اکسل را نصب کرده باشید

procedure  ExporttoExl(TheDataset:TDataSet;SheetExcelName:String);
var
 XApp:Variant;
 sheet:Variant;
 r,c:Integer;
 q:Integer;
 row,col:Integer;
 fildName:Integer;

begin
try

 begin
   XApp:=CreateOle("Excel.Application");
   XApp.Visible:=true;
 end;
except
 showmessage("Unable to link with MS Excel,  it seems as it is not installed on this system.");
 exit;
end;
XApp.WorkBooks.Add(-4167);  //open a new blank workbook
XApp.WorkBooks[1].WorkSheets[1].Name:="Sheet1";  
         //give any name required to ExcelSheet
sheet:=XApp.WorkBooks[1].WorkSheets["Sheet1"];
for fildName:=0 to TheDataset.FieldCount-1 do
        //TheDataset refer to the any dataset holding data
 begin
   q:=fildName+1;
   sheet.Cells[1,q]:=TheDataset.Fields[fildName].FieldName;   // enter the column headings
 end;

//now supply the data from table to excel sheet
TheDataset.First;
for r:=0 to TheDataset.RecordCount-1 do
begin
for c:=0 to TheDataset.FieldCount-1 do
  begin
    row:=r+2;
    col:=c+1;
    sheet.Cells[row,col]:=TheDataset.Fields[c].AsString;
  end;
TheDataset.Next;
end;


//set font attributes of required range if required
XApp.WorkSheets["Sheet1"].Range["A1:AA1"].Font.Bold:=True;
XApp.WorkSheets["Sheet1"].Range["A1:AA1"].Font.Color := clblue;
XApp.WorkSheets["Sheet1"].Range["A1:AA1"].Font.Color := clblue;
XApp.WorkSheets["Sheet1"].Range["A1:K1"].Borders.LineStyle :=13;

// set other attributes as below
XApp.WorkSheets["Sheet1"].Range["A1:K11"].HorizontalAlignment := 3;
// .Borders.LineStyle :=13;
XApp.WorkSheets["Sheet1"].Columns[1].ColumnWidth:=10;
XApp.WorkSheets["Sheet1"].Columns[2].ColumnWidth:=10;
XApp.WorkSheets["Sheet1"].Columns[3].ColumnWidth:=15;
XApp.WorkSheets["Sheet1"].Columns[4].ColumnWidth:=6;
XApp.WorkSheets["Sheet1"].Columns[5].ColumnWidth:=18;
XApp.WorkSheets["Sheet1"].Columns[6].ColumnWidth:=9;
XApp.WorkSheets["Sheet1"].Columns[7].ColumnWidth:=23;
XApp.WorkSheets["Sheet1"].Columns[8].ColumnWidth:=23;
XApp.WorkSheets["Sheet1"].Columns[9].ColumnWidth:=23;
XApp.WorkSheets["Sheet1"].Columns[10].ColumnWidth:=10;
xapp.caption := "Exported from Demo programmed by SK Arora,the digitiger";
XApp.WorkSheets["Sheet1"].name := "Exported from " + SheetExcelName;
//assuming dataset is TTable based its tablename can be given as title of worksheet
//close;
end;

به عنوان مثال


procedure TForm1.Button1Click(Sender: T);
begin
  ExporttoExl(ClientDataSet1,"Sabetee");
  close;
end;

برگرفته شده از سایت دنیای برنامه نویسی دلفی(http://mt85.blogfa.com)



محمد مقصودلو ::: شنبه 87/4/29::: ساعت 11:41 صبح

از این تابع می توانید برای تبدیل فایل PDF به متن استفاده کنید

توجه:قبل از استفاده از این تابع باید برنامه Reader  را نصب کرده باشد در غیر این صورت تابع کار نخواهد کرد

procedure Tform1.PDF2Text(APDFFileName, ATextFileName: TFileName);
var
App,AVDoc:Variant;
begin
//create an instance. if no running instance is found a new one is started
App:=CreateOle("AcroExch.App");
// App.Show;   //only if you want to..
AVDoc:=App.GetActiveDoc;//doc handle
AVDoc.Open(APDFFileName,"");//see note below
//select all and copy to clipboard
App.MenuItemExecute("Edit");
App.MenuItemExecute("SelectAll");
App.MenuItemExecute("Edit");
App.MenuItemExecute("Copy");
// Memo1 CAN be set to invisible
// You need this in order to get it from
// the clipboard into a text file
Memo1.PasteFromClipboard;
// Save the text to a file
Memo1.Lines.SaveToFile(ATextFileName);
App.Exit; //unless you want to leave it running.
end;

برگرفته شده از سایت دنیای برنامه نویسی دلفی(http://mt85.blogfa.com)


 



محمد مقصودلو ::: شنبه 87/4/29::: ساعت 11:40 صبح

تبدیل یک فایل به فلش به یک فایل اجرایی ویندوز


function Swf2Exe(S, D, F: string): string;
 //S = Source file (swf)
 //D = Destionation file (exe)
 //F = Flash Player
var
 SourceStream, DestinyStream, LinkStream: TFileStream;
 flag: Cardinal;
 SwfFileSize: integer;
begin
 result := "something error";
 DestinyStream := TFileStream.Create(D, fmCreate);
 try
   LinkStream := TFileStream.Create(F, fmOpenRead or fmShareExclusive);
   try
     DestinyStream.CopyFrom(LinkStream, 0);
   finally
     LinkStream.Free;
   end;

   SourceStream := TFileStream.Create(S, fmOpenRead or fmShareExclusive);
   try
     DestinyStream.CopyFrom(SourceStream, 0);
     flag := $FA123456;
     DestinyStream.WriteBuffer(flag, sizeof(integer));
     SwfFileSize := SourceStream.Size;
     DestinyStream.WriteBuffer(SwfFileSize, sizeof(integer));
     result := "";
   finally
     SourceStream.Free;
   end;
 finally
   DestinyStream.Free;
 end;
end;

به عنوان مثال:

procedure TForm1.Button1Click(Sender: T);
begin
 Swf2Exe("c:somefile.swf", "c:somefile.exe", "c:Program FilesMacromediaFlash MXPlayersSAFlashPlayer.exe");
end;

برگرفته شده از سایت دنیای برنامه نویسی دلفی(http://mt85.blogfa.com)



محمد مقصودلو ::: شنبه 87/4/29::: ساعت 11:39 صبح

تبدیل عدد به حروف انگلیسی بسیار عالی

Function RealToTxt(Amount : Real) : String;
var
 Num : LongInt;
 Fracture : Integer;

 function Num2Str(Num: LongInt): String;
 Const hundred = 100;
       thousand = 1000;
       million = 1000000;
       billion = 1000000000;
  begin
    if Num >= billion then
      if (Num mod billion) = 0 then
        Num2Str := Num2Str(Num div billion) + " Billion"
      else
        Num2Str := Num2Str(Num div billion) + " Billion " +
                   Num2Str(Num mod billion)
    else
      if Num >= million then
        if (Num mod million) = 0 then
          Num2Str := Num2Str(Num div million) + " Million"
        else
          Num2Str := Num2Str(Num div million) + " Million " +
                     Num2Str(Num mod million)
      else
        if Num >= thousand then
          if (Num mod thousand) = 0 then
            Num2Str := Num2Str(Num div thousand) + " Thousand"
          else
            Num2Str := Num2Str(Num div thousand) + " Thousand " +
                       Num2Str(Num mod thousand)
        else
          if Num >= hundred then
            if (Num mod hundred) = 0 then
              Num2Str := Num2Str(Num div hundred) + " Hundred"
            else
              Num2Str := Num2Str(Num div  hundred) + " Hundred " +
                         Num2Str(Num mod hundred)
          else
          case (Num div 10) of
         6,7,9: if (Num mod 10) = 0 then
                   Num2Str := Num2Str(Num div 10) + "ty"
                 else
                   Num2Str := Num2Str(Num div 10) + "ty-" +
                              Num2Str(Num mod 10);
              8: if Num = 80 then
                   Num2Str := "Eighty"
                 else
                   Num2Str := "Eighty-" + Num2Str(Num mod 10);
              5: if Num = 50 then
                   Num2Str := "Fifty"
                 else
                   Num2Str := "Fifty-" + Num2Str(Num mod 10);
              4: if Num = 40 then
                   Num2Str := "Forty"
                 else
                   Num2Str := "Forty-" + Num2Str(Num mod 10);
              3: if Num = 30 then
                   Num2Str := "Thirty"
                 else
                   Num2Str := "Thirty-" + Num2Str(Num mod 10);
              2: if Num = 20 then
                   Num2Str := "Twenty"
                 else
                   Num2Str := "Twenty-" + Num2Str(Num mod 10);
            0,1: case Num of
                    0: Num2Str := "Zero";
                    1: Num2Str := "One";
                    2: Num2Str := "Two";
                    3: Num2Str := "Three";
                    4: Num2Str := "Four";
                    5: Num2Str := "Five";
                    6: Num2Str := "Six";
                    7: Num2Str := "Seven";
                    8: Num2Str := "Eight";
                    9: Num2Str := "Nine";
                   10: Num2Str := "Ten";
                   11: Num2Str := "Eleven";
                   12: Num2Str := "Twelve";
                   13: Num2Str := "Thirteen";
                   14: Num2Str := "Fourteen";
                   15: Num2Str := "Fifteen";
                   16: Num2Str := "Sixteen";
                   17: Num2Str := "Seventeen";
                   18: Num2Str := "Eightteen";
                   19: Num2Str := "Nineteen"
                 end
          end
 end {Num2Str};

begin
 Num:= Trunc(Amount);
 Fracture:= Round(1000*Frac(Amount));
 if Num > 0 then
   Result := Num2Str(Num) + " and ";
 if Fracture > 0 then
   Result := Result + IntToStr(Fracture) + "/1000"
 else
   Result := Result +  "000/1000";
end;

به عنوان مثال:

procedure TForm1.Button1Click(Sender: T);
begin
form1.Caption:=realtotxt(123);
end;

برگرفته شده از سایت دنیای برنامه نویسی دلفی(http://mt85.blogfa.com)



محمد مقصودلو ::: شنبه 87/4/29::: ساعت 11:38 صبح

از این تابع برای نمایش هینت محتوای هر خانه از استرینگ گرید خود استفاده کنید

procedure TForm1.ShowCellHint(X,Y:Integer);
const  LastRow:integer=0;LastCol : Integer=0;
var
  ACol, ARow : Integer;
begin
  //ShowHint auf True setzen
  If StringGrid.ShowHint = False Then
     StringGrid.ShowHint := True;
  //Col und Row Position lesen
  StringGrid.MouseToCell(X, Y, ACol, ARow);
  //wenn im gültigen Bereich zeige Zelleninhalt als Hint
  If (ACol <> -1) And (ARow <> -1) Then
      StringGrid.Hint:=StringGrid.Cells[ACol,ARow];
  If (ACol<>LastCol) or (ARow<>LastRow) Then
  begin
    Application.CancelHint;
    LastCol:=ACol;
    LastRow:=ARow;
  end;
end;

//Example, in MouseMove Event
procedure TForm1.StringGridMouseMove(Sender: T; Shift: TShiftState; X,
  Y: Integer);
begin
  ShowCellHint(X,Y);
end;

برگرفته شده از سایت دنیای برنامه نویسی دلفی(http://mt85.blogfa.com)



محمد مقصودلو ::: شنبه 87/4/29::: ساعت 11:36 صبح

نحوه دسترسی به کامپوننت ها بدون دانستن نام آنها این روش بسیار مفید است برای زمانی که می خواهید یک یا چند خاصیت کامپوننت ها را به صورت دسته جمعی در زمان اجرا تغییر دهید


var
 i : integer;
...
 
for i := 0 to Form1.ComponentCount-1 do
begin
 if (Form1.Components[i] is TEdit) then
 if (TEdit(Form1.Components[i]).tag = 1) then
  TEdit(Form1.Components[i]).Visible := false;
end;
 
 
or
 
for i := 0 to Form1.ComponentCount-1 do
 begin
  if (Form1.Components[i] is TEdit) then
   if (TEdit(Form1.Components[i]).tag in [1..5,10..15]) then
    TEdit(Form1.Components[i]).Visible := false;
 end;
 
or
 
for i := 0 to Form1.ComponentCount-1 do
  begin
    if (Form1.Components[i] is TEdit) then
      begin
        case TEdit(Form1.Components[i]).tag of
          1..14  : TEdit(Form1.Components[i]).Visible := false;
          15..18 : TEdit(Form1.Components[i]).Visible := true;
          19..25 : TEdit(Form1.Components[i]).Visible := false;
          26..30 : TEdit(Form1.Components[i]).Visible := false;
        end; { case }
      end; {if TEdit)
  end; {i loop }

برگرفته شده از سایت دنیای برنامه نویسی دلفی(http://mt85.blogfa.com)



محمد مقصودلو ::: شنبه 87/4/29::: ساعت 11:35 صبح

به وسیله این تابع می توانید یک فایل فلش را از یک فایل اجرایی خارج کنید و به صورت یک فایل فلش ذخیره نمایید

procedure ExeToSWF(ExeFile,aSWF:string);
var
p:pointer;
f:file;
sz,
swfsize:integer;
const
SWF_FLAG:integer=$FA123456;
begin
if not fileexists(ExeFile) then begin
   messagebox(Application.Handle,pchar("File not found"),pchar("Error"),MB_ICONERROR);
   exit;
end;
assignfile(f,ExeFile);
reset(f,1);
seek(f,filesize(f)-(2*sizeof(integer)));
blockread(f,sz,sizeof(integer));
if sz<>swf_flag then begin
     messagebox(Application.Handle,pchar("Not a valid Projector Exe"),pchar("Error"),MB_ICONERROR);
     closefile(f);
     exit;
end;
blockread(f,swfsize,sizeof(integer));
seek(f,filesize(f)-(2*sizeof(integer))-swfsize);
getmem(p,swfsize);
blockread(f,p^,swfsize);
closefile(f);
assignfile(f,aSWF);
rewrite(f,1);
blockwrite(f,p^,swfsize);
closefile(f);
freemem(p,swfsize);
messagebox(Application.Handle,pchar("SWF Extracted"),pchar("Succes"),MB_ICONINFORMATION);
end;

به عنوان مثال

procedure TForm1.Button1Click(Sender: T);
begin
ExeToSWF("C:Desktopflash.exe","C:Desktopf.swf");
end;

برگرفته شده از سایت دنیای برنامه نویسی دلفی(http://mt85.blogfa.com)


 



محمد مقصودلو ::: شنبه 87/4/29::: ساعت 11:34 صبح

فراخوانی فرم خاموش کردن کامپیوتر از طرق این تابع امکان پذیر است

uses ComObj;

{....}

procedure TForm1.Button1Click(Sender: T);
var
  shell: Variant;
begin
  shell := CreateOle("Shell.Application");
  shell.ShutdownWindows;
end;



محمد مقصودلو ::: شنبه 87/4/29::: ساعت 11:33 صبح

<      1   2   3   4   5   >>   >

لیست کل یادداشت های این وبلاگ

>> بازدیدهای وبلاگ <<
بازدید امروز: 14
بازدید دیروز: 8
کل بازدید :87582

>> درباره خودم <<
کدهای آماده دلفی
محمد مقصودلو
در این وبلاگ سعی میکنم مطالب مربوط به برنامه نویسی دلفی ، پاسکال و گرافیک رایانه ای 2 بعدی و 3 بعدی را به روز کنم منتظر سوالات شما نیز هستم

>>تست سرعت تایپ<<

>> پیوندهای روزانه <<

>>فهرست موضوعی یادداشت ها<<

>>آرشیو شده ها<<

>>لوگوی وبلاگ من<<
کدهای آماده دلفی

>>لوگوی دوستان<<



>>اشتراک در خبرنامه<<
 

>>طراح قالب<<


>>ذکر روزهای هفته<<

>>جستجوگر وبلاگها<<

>>ساعت<<

>> اخبار فناوری<<

>>جدیدترین اس ام اس های اینترنت<<

>>فال حافظ<<

>>دیکشنری آنلاین<<
-

>>جک یا لطیفه<<

>>هواشناسی<<

>>تاریخ و ساعت<<
شنبه 103/2/15 ساعت 4:10 صبح