دانلود کنید
fileisempty,addisdone.rar
دانلود کنید
fileisempty,addisdone.rar
یک یونیت برای کار با FaceBook مثل login و ....
این سورس کامل درخت فیثاغورث که برای یکی از کاربران تازه وارد قرار داده بودم مثل اینکه ایشون زرنگ تشریف داشتن پس از برداشتن سورس تاپیک رو پاک کردن. توضیحات بیشتر در این تاپیک قرار دارد.http://www.barnamenevis.org/sh...=106906&page=2
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls;
type
TPoints = Array of TPoint;
Tline = record
p1,p2 : TPoint;
end;
TForm1 = class(TForm)
Button2: TButton;
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
p1,p2 : TPoint;
function NormDegre(Degre : integer):integer;
procedure DrawPoint(Pnts : TPoints);
procedure FillTringle(Pnts : TPoints);
function LineLen(p1,p2 : TPoint) : Integer;
function GetDegre(P1,p2 : TPoint):integer;
function InterSection(P1, p2: TPoint; Deg1, Deg2: Real): TPoint;
procedure DrawTree(p1,p2 : TPoint;counter : integer);
function Square1(p1,p2 : TPoint):TPoints;
function Tringle1(p1,p2 : TPoint):TPoints;
end;
var
Form1: TForm1;
implementation
uses Math, Types;
{$R *.dfm}
procedure TForm1.Button2Click(Sender: TObject);
var p1,p2 : TPoint;
begin
p1 := Point(400,400);
p2 := Point(450,400);
DrawTree(p1,p2,1);
end;
function TForm1.InterSection(P1, p2: TPoint; Deg1, Deg2: Real): TPoint;
begin
Deg1 := Tan( DegToRad(Deg1));
Deg2 := Tan(DegToRad(Deg2));
Result.X := round( ((P1.Y - P2.Y)+(Deg2*p2.X- Deg1*P1.X))/(-Deg1+Deg2)) ;
Result.Y :=round( Deg2*(Result.X - P2.X)+P2.Y);
{
Result.X := round((-p1.Y+p2.Y+p1.X*Deg1-p2.X*Deg2)/(Deg1-Deg2));
Result.Y :=round( Deg1*(Result.X - P1.X)+P1.Y);
}
end;
function TForm1.GetDegre(P1, p2: TPoint): Integer;
begin
Result := round( RadToDeg( ArcTan2(p2.Y-p1.Y,p2.X-p1.X)));
if Result <0 then Result := 360 + Result;
end;
function TForm1.LineLen(p1, p2: TPoint):Integer ;
begin
if p2.X = p1.X then Result := abs(p2.Y-p1.Y)
else if p2.Y = p1.Y then Result := abs(p2.x-p1.x)
else Result := trunc( sqrt( sqr(p2.Y-p1.Y)+sqr(p2.X-p1.X)));
end;
procedure TForm1.DrawPoint(Pnts: TPoints);
var i , j : integer;
colors:array[0..2] of byte;
begin
Canvas.Pen.Color := clBlack;
Canvas.MoveTo(Pnts[0].x,Pnts[0].y);
for i := 1 to Length(Pnts)-1 do
Canvas.LineTo(Pnts[i].X,Pnts[i].Y);
Canvas.LineTo(Pnts[0].X,Pnts[0].Y);
if Length(Pnts)=3 then
begin
end;
end;
procedure TForm1.DrawTree(p1,p2 : TPoint;counter : integer);
var SqrPnts ,TringPnts : TPoints;
begin
if counter> 16 then Exit;
counter := counter+1;
SqrPnts := Square1(p1,p2);
DrawPoint(SqrPnts);
TringPnts := Tringle1(SqrPnts[3],SqrPnts[2]);
DrawPoint(TringPnts);
FillTringle(TringPnts);
DrawTree(TringPnts[2],TringPnts[1],counter+1);
DrawTree(TringPnts[0],TringPnts[2],counter+1);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
p1 := Point(-1,-1);
p2 := Point(-1,-1);
end;
function TForm1.NormDegre(Degre: Integer): integer;
begin
Result := Degre;
if Degre< 0 then Result := 360 + Degre
else if Degre> 360 then Result := Degre mod 360;
end;
function TForm1.Square1(p1, p2: TPoint):TPoints;
var G1,G2 : integer;
r : integer;
p3,p4 : TPoint;
begin
G1 := GetDegre(p1,p2);
G2 := GetDegre(p2,p1);
r := LineLen(p1,p2);
SetLength(Result,4);
Result[0] := p1;
Result[1] := p2;
Result[2].X := p2.X+ round( r*cos(DegToRad(NormDegre( g2+90 ))));
Result[2].Y := p2.Y+ round(r*sin(DegToRad(NormDegre( g2+90))));
Result[3].X :=p1.X+ round( r*cos(DegToRad(NormDegre( g1-90) )));
Result[3].Y := p1.Y+ round(r*sin(DegToRad(NormDegre( g1-90) )));
end;
function TForm1.Tringle1(p1, p2: TPoint): TPoints;
var g : Integer;
r , l ,r2 : Real;
begin
SetLength(Result,3);
Result[0] := p1;
Result[1] := p2;
g := GetDegre(p1,p2);
r := LineLen(p1,p2);
r2 := r /2;
l := r2/ sin(DegToRad(45)) ;
Result[2].X := round(p1.X +l*cos(DegToRad(NormDegre( g-45 ))));
Result[2].Y := round(p1.Y +l*sin(DegToRad(NormDegre( g-45 ))));
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if p1.X=-1 then p1 := Point(x,y)
else if p2.X=-1 then p2 := Point(x,y);
if (p1.X<>-1) and (p2.X<>-1) then
begin
Refresh;
DrawTree(p1,p2,1);
p1 := Point(-1,-1);
p2 := Point(-1,-1);
end;
end;
procedure TForm1.FillTringle(Pnts: TPoints);
var
g ,r : integer;
p ,q: TPoint;
tempB : TBrush;
begin
g := GetDegre(Pnts[0],Pnts[1]);
r := LineLen(Pnts[0],Pnts[1]) div 2;
p.X := Pnts[0].X+ round( r*cos(DegToRad(NormDegre( g ))));
p.Y := Pnts[0].Y+ round(r*sin(DegToRad(NormDegre( g))));
g := GetDegre(P,Pnts[2]);
r := LineLen(P,Pnts[2]) div 2;
q.X := P.X+ round( r*cos(DegToRad(NormDegre( g ))));
q.Y := P.Y+ round(r*sin(DegToRad(NormDegre( g))));
// tempB := Canvas.Brush;
// Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := clBlack;
Canvas.FloodFill(q.X,q.Y,clBlack,fsBorder);
// Canvas.Brush := tempB;
end;
end.
این برنامه فیلد های جدول اول رو میخونه و در جدول دوم درج میکنه فقط باید دو جدول بسازید به اسم person1 و person2 و در جدول اول فیلد های id,fname,lname و در جدول دوم فیلد های fname و lname را قرار بدید و بعد پروژه رو اجرا کنید:
table1totable2.rar
سلام
با استفاده از این برنامه ای که ساخته ام شما می توانید فایل های مورد نظر خود را به صورتی از رایانه حذف کنید که دیگر با هیچ نرم افزار بازیابی اطلاعاتی قابل بازگشت نباشد. یادش بخیر این یکی از هفت برنامه ای بود که برای پروژه نهایی کاردانی نوشته بودم.
روش کار با این برنامه بسیار ساده است. فقط باید فایلهای مورد نظر را به روی ListView درگ کرده و برای حذف آن ها چک باکس موجود در کنار فایل های مورد نظر را به صورت انتخاب شده در آورید و سپس بر روی دکمه Erase کلیک کنید. در اصطلاح کلی به این گونه برنامه ها File Shredder گفته می شود. در ضمن توجه کنید که برای ساخت این برنامه از دلفی 2010 استفاده کرده ام. بنابرین برای کامپایل و اجرای برنامه به دلفی 2010 نیاز دارید.
امروز یکی از کاربران تاپیکی زده بود و درخواست کدی کرده بود که بتونه یک فایل رو تو آدرس مورد نظر کپی و روند پیشرفت عملیات رو داخل یک ProgressBar نمایش بده ، بدین منظور کتابخانه ای با نام PBCopy نوشتم که یک فایل رو به آدرس مورد نظر کپی میکنه و روند پیشرفت عملیات کپی رو داخل یک ProgressBar نمایش میده که کتابخانه و نمونه برنامه رو میتونید از فایل ضمیمه دریافت کنید .
آخرین ویرایش به وسیله Felony : سه شنبه 07 دی 1389 در 10:00 صبح دلیل: اضافه کردن نمایش % روند عملیات
با استفاده از کد زیر شما می توانید نام نسخه سیستم عامل ویندوز را بدست آورید: (این کد در Delphi XE تست شده است)
uses ActiveX, OleAuto;
function GetWin32_OSNameVersion: string;
var
objWMIService: OLEVariant;
colItems: OLEVariant;
colItem: OLEVariant;
oEnum: IEnumvariant;
iValue: LongWord;
function GetWMIObject(const objectName: String): IDispatch;
var
chEaten: Integer;
BindCtx: IBindCtx;
Moniker: IMoniker;
begin
OleCheck(CreateBindCtx(0, BindCtx));
OleCheck(MkParseDisplayName(BindCtx, StringToOleStr(objectName), chEaten,
Moniker));
OleCheck(Moniker.BindToObject(BindCtx, nil, IDispatch, Result));
end;
begin
try
objWMIService := GetWMIObject('winmgmts:\\localhost\root\cimv2');
colItems := objWMIService.ExecQuery('SELECT * FROM Win32_OperatingSystem',
'WQL', 0);
oEnum := IUnknown(colItems._NewEnum) as IEnumvariant;
if oEnum.Next(1, colItem, iValue) = 0 then
Result := Format('%s %s', [colItem.Caption, colItem.Version]);
except
Result := '?'
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetWin32_OSNameVersion);
end;
Overload کردن تابع ShowMessage برای پذیرفتن مقادیر اعشاری، صحیح و بولی:
unit common;
interface
uses dialogs, sysutils;
procedure ShowMessage(const value : string) ; overload;
procedure ShowMessage(const value : integer) ; overload;
procedure ShowMessage(const value : extended) ; overload;
procedure ShowMessage(const value : boolean) ; overload;
implementation
//displays a string in a dialog box
procedure ShowMessage(const value : string) ;
begin
Dialogs.ShowMessage(value) ;
end;
//displays an integer in a dialog box
procedure ShowMessage(const value : integer) ;
begin
ShowMessage(IntToStr(value)) ;
end;
//displays a float in a dialog box
procedure ShowMessage(const value : extended) ;
begin
ShowMessage(FloatToStr(value)) ;
end;
//displays a boolean in a dialog box
procedure ShowMessage(const value : boolean) ;
begin
ShowMessage(BoolToStr(value, true)) ;
end;
end.
چند روز پیش یکی از دوستان از فضای کم میز کارش و اینکه مانیتورش کوچیک هست گله میکرد و به ذهنم رسید تا برنامه ای بنویسم تا چند تا میز کار مختلف در اختیار کابر بزاره تا بتونه تو هر کدومش کار متفاوتی انجام بده و ...
برنامه رو تا جایی که بشه ازش استفاده کرد نوشتم ولی بازم روش میشه کار کرد ، میتونید ازش برای یادگیری نحوه استفاده از تابع SetThreadDesktop , CretaeDesktop ، SwitchToDesktop , CreateProcess استفاده کنید ، چون منبع جامعی برای استفاده از این توابع Desktop در دلفی پیدا نمیشه ، من هم با خوندن MSDN برنامه رو نوشتم .
برنامه بهتون علاوه بر میزکار پیش فرض ، 2 میز کار اضافی هم میده و میتونید از هر میز کاری که هستید یک برنامه رو تو میزکار دیگه اجرا کنید یا بهش سوئیچ کنید .
برای زیبائی برنامه از کامپوننت های Alpha Control استفاده شده .
سورس برنامه هم ضمیمه شده .
موفق باشید .
undocument messagebox
این تابع از توابع استاندارد ویندوز درون User32.dll هست که یک messagebox با قابلیت زماندهی برای بسته شدن میباشد
function MessageBoxTimeOut(
hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
function MessageBoxTimeOutA(
hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
function MessageBoxTimeOutW(
hWnd: HWND; lpText: PWideChar; lpCaption: PWideChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
implementation
// this const is not defined in Windows.pas
const
MB_TIMEDOUT = 32000;
function MessageBoxTimeOut; externaluser32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutA; external user32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutW; external user32 name 'MessageBoxTimeoutW';
نمونه مثال:
var
iResult: Integer;
iFlags: Integer;
begin
// Define a MessagBox with an OK button and a timeout of 2 seconds
iFlags := MB_OK or MB_SETFOREGROUND or MB_SYSTEMMODAL or MB_ICONINFORMATION;
iResult := MessageBoxTimeout(
Application.Handle,
'Test a timeout of 2 seconds.',
'MessageBoxTimeout Test', iFlags, 0, 2000);
// iResult will = 1 (IDOK)
ShowMessage(IntToStr(iRet));
// Define a MessageBox with a Yes and No button and a timeout of 5 seconds
iFlags := MB_YESNO or MB_SETFOREGROUND or MB_SYSTEMMODAL or MB_ICONINFORMATION;
iResult := MessageBoxTimeout(
Application.Handle,
'Test a timeout of 5 seconds.',
'MessageBoxTimeout Test', iFlags, 0, 5000);
// iResult = MB_TIMEDOUT if no buttons clicked, otherwise
// iResult will return the value of the button clicked
case iResult of
IDYES: // Pressed Yes button
ShowMessage('Yes');
IDNO: // Pressed the No button
ShowMessage('No');
MB_TIMEDOUT: // MessageBox timed out
ShowMessage('TimedOut');
end;
end;
سلام ،
دیروز یکی از دوستان تو تاپیکی درخواست کدی کرده بود که بشه لیست کامپوننت های یک برنامه دیگه رو به دست آورد ، من یک نمونه نوشتم و گفتم اینجا هم قرار بدم تا دوستان دیگه هم استفاده کنن ، توسط برنامه ضمیمه شده میتونید عنوان ، نام کلاس و هندل کامپوننت های برنامه های دیگر رو به دست بیارید ، کافی هست تا عنوان پنجره و کلاس فرم مربوط به برنامه مورد نظر رو در بخش مربوطه وارد کنید تا برنامه لیست تمام کامپوننت های موجود رو فرم اون برنامه رو نمایش بده .
این نمونه برای یادگیری Callback Function ها منجمله EnumChildWindow بسیار مناسب هست .
با سلام.
توسط برنامه زیر اگه یه پیکسل مشکی انتخاب کنید . برنامه میگرده و بقیشو پیدا میکنه.
http://up.iranblog.com/images/dd1ygpnrrpw4624sfwwf.rar
استخراج تمامی ایمیل های موجود در یک رشته طولانی :
procedure TForm1.ExtractEmails(StrContent: string);
var
i, r, P1, P2, DContinue: integer;
Email, StrPre, StrPos: string;
begin
StrContent := StringReplace(StrContent, #13#10, ' ', [rfReplaceAll]);
StrContent := StrContent + #13#10;
i := 1;
ListBox1.Items.Clear;
while (i <= length(StrContent)) do
begin
r := PosEx('@', StrContent, i);
if r > 0 then
begin
StrPre := copy(StrContent, 1, r - 1);
P1 := r + 1;
StrPos := copy(StrContent, P1, length(StrContent));
P2 := pos(' ', StrPos) - 1;
//
StrPre := ReverseString(StrPre);
StrPre := ReverseString(copy(StrPre, 1, pos(' ', StrPre) - 1));
StrPos := copy(StrPos, 1, P2);
// Catch the email
Email := StrPre + '@' + StrPos;
if pos('.', Email) > 0 then
ListBox1.Items.Add(Email);
DContinue := P1 + P2;
end
else
begin
Break;
end;
// Continue searching
i := DContinue + 1;
end;
end;
البته این تاپیک جای بحث نیست، ولی این کار رو میشه با Regular Expression با دقت و سرعت بالاتر، به راحتی انجام داد.استخراج تمامی ایمیل های موجود در یک رشته طولانی
وَ سَيَعْلَمُ الَّذِينَ ظَلَمُوا [آل محمد حقهم] أَيَّ مُنْقَلَبٍ يَنْقَلِبُونَ - الشعراء (227)
و ظالمین [حق آل محمد (ص) ] به زودی خواهند دانست که به کدام بازگشتگاه بازخواهند گشت.
با سلام و خدا قوت خدمت سروران گرانقدر
چند روز پیش تاپیکی ایجاد کردم و در مورد چگونگی ضبط صوت سوال پرسیدم.
با راهنمایی جناب SAASTN برنامه کوچکی تهیه کردم.
گفتم شاید به درد دوستان بخوره.فایدش اینه که اگه مثلا در کار تقلید از قاریان قرآن باشیم یا بخواهیم صدای بازی ضبط کنیم، می تونیم ازش استفاده کنیم.(من خودم برای ضبط قسمتی از صوت تبلیغات لینا لوله ای ازش استفاده کردم)
گرچه برنامه Sound Recorder هم در خود ویندوز هست ولی من می خواستم قسمتی از صوت پخش شده از یک برنامه رو ضبط کنم فقط کمی از اول صوت رو ذخیره می کرد و بقیه فایل بدون صدا ضبط می شد ولی با این برنامه این مشکل رو نداشتم!!
برای شروع و خاتمه ضبط باین برنامه ترکیب Ctrl+Space زا فشار دهید:
با استفاده از کد زیر به راحتی میتوانید یک درایور را در دلفی نصب کنید
کدی جهت بدست آوردن تقاطع 2 خط بر حسب angle.
ابتدا با دو کلیک نقاط خط اول و سپس با دو کلیک دیگر نقاط خط دوم را وارد نمایید سپس تقاطع دو خط نمایش داده می شود.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
index : Integer;
p :Array[0..3] of TPoint;
end;
var
Form1: TForm1;
implementation
uses Math;
{$R *.dfm}
function GetDegree(p1,p2 : TPoint): Double;
begin
Result := ArcTan2(p2.Y-p1.Y,p2.X -p1.X);
end;
function GetConflictPoint(p1,p2 : TPoint;deg1 ,deg2 : Double):TPoint;
var m1,m2 : Double;
x ,y : Double;
begin
m1 := tan( deg1);
m2 := tan( deg2);
X := (m1*p1.X - m2*p2.X + p2.Y - p1.Y) /(m1-m2);
Y := m1 *(x- p1.X)+p1.Y;
Result := point(round(x),round(y));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
index := 0;
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var resPoint : TPoint;
begin
if index > 3 then
begin
index := 0;
Canvas.FillRect(ClientRect);
end;
p[index] := point(x,y);
if index mod 2 = 1 then
begin
Canvas.Ellipse(p[index-1].X-2,p[index-1].Y-2,p[index-1].X+2,p[index-1].Y+2);
Canvas.Ellipse(p[index].X-2,p[index].Y-2,p[index].X+2,p[index].Y+2);
Canvas.MoveTo(p[index-1].X,p[index-1].Y);
Canvas.LineTo(p[index].X,p[index].Y);
Caption := FloatToStr(GetDegree(p[index-1],p[index]));
end;
if index = 3 then
begin
resPoint := GetConflictPoint(p[0],p[2],GetDegree(p[0],p[1]),GetDegree(p[2],p[3]));
Canvas.Ellipse(resPoint.X-2,resPoint.Y-2,resPoint.X+2,resPoint.Y+2);
end;
inc(index);
end;
end.
فارسی ساز مستقل از ویندوز
فارسی ساز مستقل از ویندوز برای کامپایلرهای 2009 و به بعد
چند وقت پیش از روی بیکاری تصمیم گرفتم کتابخانه ای برای محاسبات بزرگ ریاضی بنویسم ، کتابخانه رو تا قسمت هایی توسعه دادم و بعد به دلیل کنکور و پروژه و ... نتونستم کاملش کنم .
پروژه ضمیمه شده شامل کتابخانه و نمونه برنامه کار با اون هست ، فعلا بخش جمع کتابخانه نوشته شده و عددهای بسیار بسیار بزرگ رو به درستی با هم جمع میکنه ؛ انشاالله اگر وقت کردم و تکمیلش کردم همین جا قرارش میدم .
برای نوشتن کتابخانه از روش آرایه استفاده شده ، با خوندن سورس کتابخانه روند کار دستتون میاد و میتونید خودتون توسعش بدید .
تو یکی از تاپیک ها یکی از کاربران ازم درخواست کرد تا نمونه کدی برای Split کردن یک فایل به چند فایل و سپس Merge کردن فایل های Split شده به یک فایل قرار بدم .
الان کمی بیکار بودم و یک نمونه برنامه نوشتم ، سعی کردم Comment ها واضح و گویا باشه .
موفق باشید .
امروز تو یکی از برنامه ها که داشتم مینوشتم نیاز به تولید اعداد تصادفی ( Random ) غیر تکراری داشتم و تابع زیر رو برای این کار نوشتم :
procedure GenerateRandomList(var NumberList: TStringList; const NumberOfRandomGenerated, RandomRange: Integer);
begin
if RandomRange < NumberOfRandomGenerated then
raise Exception.Create('Random range must be equal or greater than number of random generated !');
NumberList.Duplicates := dupIgnore;
NumberList.Sorted := True;
RandSeed := MilliSecondOf(Now);
repeat
NumberList.Add(IntToStr(Random(RandomRange)));
until (NumberList.Count = NumberOfRandomGenerated);
end;
این هم نمونه استفاده :
var
RandomList: TStringList;
begin
RandomList := TStringList.Create;
try
GenerateRandomList(RandomList, 10000, 20000);
ListBox1.Items.Assign(RandomList);
finally
RandomList.Free;
end;
end;
آخرین ویرایش به وسیله Felony : یک شنبه 06 شهریور 1390 در 07:23 صبح
در مورد این برنامه به دو نکته جدید برخوردم :MySQL Backup Maker
- یک قسمت برای بررسی اینکه جدول وجود دارد یا نه باید در نظر گرفته بشه تا در زمان فراخوانی پشتیبان، در صورتیکه جدول از بانک حذف شده بود به صورت خودکار ایجاد بشه.
- بین خطوط 116 و 117 باید کد زیر اضافه بشه :
Qry.SQL.Text := 'DELETE FROM `' + TableName + '`';
Qry.ExecSQL;
اینکار باعث میشه عملیات Replace روی رکورد ها انجام بشه.
با سلام
چند وقتی بود که دنبال یک برنامه کوچیک و جمع و جور می گشتم که باهاش بتونم رو سیستمی که SQL Server Express یا MSDE نصب شده، لیست دیتابیس ها رو ببینم و بتونم باهاش Attach و Detach دیتابیس هم انجام بدم.
چون برنامه جالبی پیدا نکردم خودم دست به کار شدم و این برنامه رو نوشتم.
امیدوارم به درد شما هم بخوره:
آخرین ویرایش به وسیله zidane : پنج شنبه 12 آبان 1390 در 12:46 عصر دلیل: سازگاری با SQL Server 2000
در اکثر برنامه هایی که با دلفی نوشته شده اند متاسفانه دیده می شود که منوها فونت خوبی ندارند. این موضوع در ویندوز های ویستا و سون به شکل بهتری قابل درک است. با استفاده از تکنیکی که در زیر به توضیح آن می پردازم به راحتی می توانید این مشکل را برطرف نمایید و برای همیشه از دست این مشکل رها شوید.
1- ابتدا یک کنترل TMainMenu بر روی فرم قرار دهید و گزینه های مورد نظر خود را به آن اضافه کنید.
2- خاصیت OwnerDraw مربوط به کنترل TMainMenu را به True تغییر دهید.
3- به رویداد OnCreate مرربوط به فرم رفته و کد های زیر را در آن بنویسید:
Screen.MenuFont.Name := 'tahoma';
حال می بینید که این مشکل برطرف شده است.
چک کردن جنیون بودن ویندوز
function IsWindowsGenuine() : Boolean;
const
app_guid : TGUID = '{55C92734-D682-4D71-983E-D6EC3F16059F}';
module : string = 'Slwga.dll';
api : string = 'SLIsGenuineLocal';
var
app_id : TGUID;
state : Byte;
ret : HRESULT;
CheckGenuine : function (var appID : TGUID ; var result : Byte ; uReserved : Pointer): HRESULT;stdcall;
begin
CheckGenuine := GetProcAddress(LoadLibrary(PChar(module)),PChar(ap i));
if @CheckGenuine <> nil then
begin
app_id := app_guid;
ret := CheckGenuine(app_id,state,nil);
if Succeeded(ret) then
begin
Result := (state = 0);
SetLastError(ERROR_SUCCESS);
end
else
begin
Result := False;
SetLastError(ERROR_ACCESS_DENIED);
end;
end
else
begin
Result := False;
SetLastError(ERROR_INVALID_FUNCTION);
end;
end;
procedure TForm2.Button1Click(Sender: TObject);
begin
if (IsWindowsGenuine()) and (GetLastError() = ERROR_SUCCESS) then
ShowMessage('windows is genuine')
else
ShowMessage('window is not genuine');
end;
سلام به همگی
من یه دکمه ساده طراحی کردم.چند تا حالت از جمله دکمه بدون لبه داره.
برای حالتهای MouseUp ,Mouse Down ,MouseOver می تونین رنگ دکمه رو تعیین کنین.
اگه دوست داشتین بردارین:
untitled.jpgImageButton.rar
آخرین ویرایش به وسیله mbshareat : چهارشنبه 30 فروردین 1391 در 02:17 صبح دلیل: تکمیل
با سلام
این هم یه برنامه ساده و دلچسب جستجو و نمایش کل متن قرآن کریم نوشته خودم!؟
لطفاً بزرگوارانی که قبلا برداشتن دوباره بردارند؛ چون هم اصلاحش کردم هم تکمیل..
(با قلم رایگان QuranTaha1 به همراه فایل متن کل قرآن کریم):
--
حالا آیه ای که با کلیک وسط آیات انتخاب کردیم کپی میشه نه آیه اول!
-------
یکی از دوستان سایت تقاضای سورس برنامه رو فرمودند. این برنامه در واقع قسمتی از یه برنامه حجیم دیگه نوشته خودمه که متن قرآن عثمان طه رو به همراه ترجمه استاد فولادوند نمایش میده. اما چون دسترسی به اینترنت پر سرعت ندارم فعلا نذاشتم.(ممکنه بعدا آپلود کنم و برای دانلود لینک بدم)
لطفا اگه کسی از رفقا روی رابط کاربری یا قسمت دیگه ای کار کرد نسخه اصلاح شده رو برای دانلود بذاره.
به طور مثال یکی از ایرادات برنامه اینه که وقتی از پنجره اصلی وارد پنجره متن کامل قرآن میشیم پنجره متن قرآن پرش داره. همچنین رابط گرافیکی اون رئال نیست و رنگهای خیلی شاد داره که ممکنه یکی بخواد از پوسته (Skin) یا تصویر قشنگتری برای رابط گرافیکی استفاده کنه.
اون رفیق عزیز فرمودند که ممکنه کسی بخواد ترتیل بهش اضافه کنه.
فکر نکنم کسی بتونه ترتیل آیه به آیه از اینترنت یا نرم افزاری گیر بیاره؛ اما ترتیل صفحه ای در آدرس http://haji-shohada.persianblog.ir/page/12 هست. برنامه پارس قرآن هم که منبع ترجمه برنامم بوده و برنامه قشنگیه. یه برنامه جستجو هست به نام AlMobin که جستجوی قرآن هست اما نتیجه قابل قبولی نداره مثلا اگه کلمه 'موسی' رو جستجو بدید متوجه میشید.
این هم سورس برنامه+یونیت ClrCtrls(خیلی پیش میخواستم روش کار کنم تکمیلش کنم.فعلا تو جزئیات همه کامپوننتهاش خورد نشین!):
آخرین ویرایش به وسیله mbshareat : دوشنبه 27 شهریور 1391 در 16:21 عصر دلیل: تکمیل برنامه
سلام
یونیت پنجره پیغام و سوال و InputBox رنگی(جالبه بدونین که حرف ی- ي رو هم درست می کنه):
MSGs.rar
Untitled-1.jpg
البته پروسیجرهای آقای شاهین عشایری رو هم تو یونیت ریختم. می تونین از راه InstallComponent یونیت رو نصب کنین و هر دفعه فقط MSGs رو به لیست Uses اضافه کنین.
یک کم توسعش دادم .اینها رو هم اضافه کردم:
2.jpg
آخرین ویرایش به وسیله mbshareat : چهارشنبه 30 فروردین 1391 در 02:44 صبح
برای کپی من با خطای Can not open file در کد های زیر در یونیت PBCopy مواجه شدم
procedure TCopyThread.CopyFile;
var
S_FileStream, D_FileStream: TFileStream;
Pos, Buff: Cardinal;
begin
S_FileStream:= TFileStream.Create(SFile, fmOpenRead);
D_FileStream:= TFileStream.Create(DFile, fmCreate + fmOpenWrite);
Buff:= (S_FileStream.Size div 100);
Pos:= 0;
// Send max size of progress bar
PostMessage(HWND, WM_UpdatePB, 0, (S_FileStream.Size div 100));
try
S_FileStream.Seek(0, soFromBeginning);
D_FileStream.Seek(0, soFromBeginning);
while Pos < S_FileStream.Size do
begin
if Pos+ Buff > S_FileStream.Size then
Buff:= (S_FileStream.Size - Pos);
D_FileStream.CopyFrom(S_FileStream, Buff);
Inc(Pos, Buff);
// Send current position of progress bar
PostMessage(HWND, WM_UpdatePB, (Pos div 100), 0);
S_FileStream.Position:= Pos;
D_FileStream.Position:= Pos;
Application.ProcessMessages;
end;
finally
S_FileStream.Free;
D_FileStream.Free;
end;
end;
سلام به همه دوستان
آقا مجتبی تاجیک یه برنامه نوشته بودند برای گزارش هندل و خصوصیات دیگه پنجره و کامپوننت.
من یه کم روش کار کردم که بشه باهاش پیغام هم فرستاد.
استفاده اصلی این برنامه تعامل با برنامه های دیگه هست.
اگه خواستین سورس برنامه تغییر یافته رو بردارین:
Send Message 2.gif
SendMessage2.rar
من محتوای یونیت Messages رو تو یه فایل txt ریختم و تو برنامه پیغامها رو جدا می کنم و در یک ListBox می ریزم. دلفی من قدیمیه اگر دوست داشتین محتوای یونیت Messages دلفی خودتون رو رو توی فایل Messages.txt کنار برنامه بریزین تا کامل تر بشه.وقتی در لیست باکس مربوط به نام پیغام هستین می تونین کارکتر اول نام پیغام (بدون پیشوند!) رو فشار بدین تا یکراست (چیزی مثل AutoComplete) به اون پیغام منتقل بشین!
اگه نمی دونستین کدوم پیغام به دردتون میخوره می تونین دکمه View Messages Text File رو فشار بدین و در فایل جستجو بدینتا پیغام مربوطه رو پیدا کنین.البته بعضی پیغامها تو یونیت Windows هستند که البته اگه خواستین می تونین پیغامهاش رو تو فایل Messages.txt بریزین و توی برنامه استفاده کنین.
برای تولید کد یا ارسال پیام روی کامپوننت یا فرم مورد نظر برین و Ctrl+Space رو فشار بدین و بعد دکمه مربوطه رو در برنامه فشار بدین تا برنامه با استفاده از اطلاعات کادرهای بالای فرم کد رو تولید کنه یا پیغام رو بفرسته.Ctrl+L هم باعث میشه برنامه چیزی گزارش نکنه!
توی کادر پارامترها هم می تونین عدد یا رشته وارد کنین. دکمه Send Message هم پیغام می فرسته هم کد ایجاد می کنه.
یک تجربه:
من هندل یک کامپوننت رو نداشتم با ;(متن کامپوننت,نام کلاس کامپوننت)FindWindow نتونستم هندش رو بدست بیارم!
ولی اگه هندل کامپوننت رو دارین با کد جناب MohsenB می تونین هندل فرم رو بدست بیارین:
function GetFormHandle(ObjHandle: THandle): THandle;
begin
if GetParent(ObjHandle) = 0 then
Result := ObjHandle
else
Result := GetFormHandle(GetParent(ObjHandle));
end;
آخرین ویرایش به وسیله mbshareat : چهارشنبه 06 اردیبهشت 1391 در 10:40 صبح
سلام دوستان!
این هم یک برنامه ماشین حساب :
که چهار عمل اصلی + توان را حساب می کند و شما با فهمیدن این برنامه تاحد خوبی برنامه نویسی در دلفی را خواهید آموخت.
دانلود کنید.
سلام.
کنترل TUpDown برای تغییر عدد تو کادر TEdit استفاده میشه که من یه تغییر کوچیکی توش دادم که موقع کلیک کردن رو دکمه هاش میتونید کلید موس رو نگه دارید و به بالا و پایین درگ کنید و با حرکت موس عدد رو تنظیم کنید. کامپوننتش :
unit SpinnerUpDown;
interface
uses
SysUtils, Classes, Controls, ComCtrls, Types, Windows;
type
TSpinnerUpDown = class(TUpDown)
private
_Scale : Single;
procedure MyOnMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
protected
public
constructor Create(AOwner : TComponent);override;
published
property Scale : Single read _Scale write _Scale;
property AlignButton;
property Anchors;
property Associate;
property ArrowKeys;
property DoubleBuffered;
property Enabled;
property Hint;
property Min;
property Max;
property Increment;
property Constraints;
property Orientation;
property ParentDoubleBuffered;
property ParentShowHint;
property PopupMenu;
property Position;
property ShowHint;
property TabOrder;
property TabStop;
property Thousands;
property Visible;
property Wrap;
property OnChanging;
property OnChangingEx;
property OnContextPopup;
property OnClick;
property OnEnter;
property OnExit;
property OnMouseActivate;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
end;
procedure Register;
implementation
procedure TSpinnerUpDown.MyOnMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
{$J+}
const
MouseLastPos : TPoint = (X : 0; Y : 0);
currVal : Integer = 0;
r : TRect = ();
{$J-}
var
p : TPoint;
begin
if (GetAsyncKeyState(VK_LBUTTON) and $8000 = 0) then
begin
GetCursorPos(MouseLastPos);
GetWindowRect((Sender as TWinControl).Handle, r);
end else begin
GetCursorPos(p);
SetFocus;
if (MouseLastPos.X <> p.X) or (MouseLastPos.Y <> p.Y) then
begin
currVal := currVal + p.Y - MouseLastPos.Y;//Point(X - MouseLastPos.X, Y - MouseLastPos.Y);
if (Abs(currVal * _Scale) > 1.0) then
begin
(Sender as TUpDown).Position := (Sender as TUpDown).Position - Trunc(currVal * _Scale);
if Assigned(Associate) then
Associate.Update;
currVal := 0;
end;
GetWindowRect((Sender as TWinControl).Handle, r);
MouseLastPos := Point(r.Left - 5, (r.Top + r.Bottom) div 2);
SetCursorPos(MouseLastPos.X, MouseLastPos.Y);
end;
end;
end;
constructor TSpinnerUpDown.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
_Scale := 0.1;
Self.OnMouseMove := MyOnMouseMove;
end;
procedure Register;
begin
RegisterComponents('MHD', [TSpinnerUpDown]);
end;
end.
این فایل ها به همراه دلفی وجود دارند. احتمالاً بنا به دلایلی فایل dcu مربوط به آنها از سیستم شما حذف شده است. اگر این مشکل رو با یونیت های دیگر هم دارید به نظر من بهتره که دلفی رو دوباره نصب کنید.من نمي توانم پروژه را اجرا کنم راجع به اين سه فايل پيغام ميدهد؟
WideStrings, DBXMySql
فایلهایی که اول نامشون dbx هست با نصب دلفی به سیستم کپی می شوند و فایل دیگر هم با نصب آن DBMS خاص (در اینجا MySQL) به سیستم کپی می شوند.ضمنا درایور های مربوطه (dbxmys.dll و libmySQL.dll) را از کجا بياورم؟؟
_
برنامه ی تبدیل یک فایل به فایل های کوچک تر.
احتمالا شما هم به فایل هایی برخوردید که خیلی حجمشون زیاده و بخواید اونا رو تو فلش و یا dvd بریزید ولی به دلیل حجم بالا نتونید این کارو بکنید و بخواید اون فایل رو تیکه تیکه کنید و بعد با فلش یا dvd جابجا کنید و رو سیستم مقصد اونا رو بچسبونید. من برنامشو نوشتم. البته حتما برنامه هایی ازین قبیل نوشته شدن و استفاده میشن ولی من دوست داشتم خودم برنامه رو بنویسم. این برنامه فایل ها رو به قطعات 64 مگابایتی تقسیم میکنه. از روشی استفاده کردم که کل فایل لازم نباشه یکجا بیاد روی رم و مثلا تو سیستم من که 4 گیگ رم داره می شه فایل 20 گیگابایتی رو تیکه تیکه کرد چون برای تیکه کردن فایل لازم نیست اون رو روی رم بارگذاری کنیم و 64 مگابایت، 64 مگابایت پیش میره که رو اکثر سیستما جواب بده.
فقط فرصت نکردم دکمه ی Cancel براش بگذارم اگه دیدید کارش طولانی شد و خواستید cancel اش کنید از روش Alt + Ctrl + Delete استفاده کنید.
http://uplod.ir/von20v52jvvy/FileCutter.zip.htm
آخرین ویرایش به وسیله Ananas : دوشنبه 12 تیر 1391 در 15:30 عصر
عكس گرفتن از Desktop يا از پنجره فعال
دانلود سورس كد
ساعت باينري
دانلود سورس كد