برنامه ای برای کپی سورس برنامه ها به فلش مموری
این برنامه فقط برخی فایلهای پوشه رو کپی می کنه :(dcu.dfm.dpr.ddp.pas.exe.ico)
CopyFoldersToFlash.rar
برنامه ای برای کپی سورس برنامه ها به فلش مموری
این برنامه فقط برخی فایلهای پوشه رو کپی می کنه :(dcu.dfm.dpr.ddp.pas.exe.ico)
CopyFoldersToFlash.rar
سلام دوستان
کدهایی که دوست داشتم به صورت فایل متن کوچک دسته بندی کردم.
مثلا مباحثی مثل تصویر ،صفحه کلید،هندل،کار با فایل و شاخه،صوت و... که بیشتر به صورت یک پروسیجر در یک فایل هست.
برای مبتدیها ممکنه جالب باشه:
نمونه کدهای آموزشی.rar
سلام
میخواستم ببینم کجای یونیت تغییر کرده.دو نسخه یونیت رو به روش ساده مقایسه کردم.دو متن رو ریختم در دو ممو و سطرهای تکراری رو از دو متن حذف کردم.(البته این روش ساده به ترتیب حساس نیست!)
گفتم ممکنه به درد کسی بخوره.تا اونجا که یادم میاد قبلا با یه روش دیگه سطر به سطر مقایسه کرده بودم که به جابجایی کد هم حساس میشد.اما پیچیدگیهایی داه مثل نادیده گرفتن سطرهای غیر تکراری و...
این هم از سورس برنامه:
Compare2Pas.rar
سلام
یه برنامه بازی ساختم گفتم به کسی نشون داده باشم.
ترکیب دو بازی در یه صفحه هست یکی حدس کلمه و دیگری پیدا کردن تصاویر مشابه.
دو نفر میتونند همزمان بازی کنند یکی با کلید و دیگری با ماوس.
برای مبتدی سر در آوردن از برنامه سخته.
برای کار ساده با تصویر و صوت و اعداد تصاوفی کمی آموزشیه.
من برای پیدا کردن عدد تصادفی در یک محدوده 16 تایی(شماره تصویر در جدول تصاویر بدون تکرار برنامه) یه رشته به طول همون محدوده تعریف کردم که از کارکتر یک تا مثلا شانزده رو به ترتیب داره.یک کارکتر رو از گردونه خارج کردم و برای به دست آوردن عدد دوم که جای تصویر مشابه دوم هست،بین بقیه رشته یک کارکتر رو از گردونه خارج کردم و..
برای حدس کلمه یه کم کار متفاوته.
برنامه کد خیلی پیچیده ای نداره(یعنی مثل کدهایی که از نت میگیرم نیست) اما سورس برنامه پر از تصویره که همه شون به جز یکی رو خودم طراحی کردم.
تصاویر حدس زدنی رو هم از بازی فلش خودم که نا تموم مونده و تا مرحله 24 ساختم استخراج کردم.
اگر از برنامه سر در نیوردید هم باکی نیست..بالاخره بازی خوبیه(ضد آلزایمر)!!!
Untitled-1.jpg
بازی فلشی بیست و چهار مرحله ای ساخت خودم
این هم اگه کسی فایل swf خواست
بازی فکری دو نفره
سورس برنامه بازی نوشته شده در محیط XE2
یادم رفت: Panel2.Left:=Panel1.Left; رو کامنت کنید و یه کم panel2 رو بیارید سمت راست.
(پیکوفایل سرعت پایینی داره.حوصله ندارم از اول، سورس رو بذارم!ایتا بی شوخی ده برابر سرعت داره)
آخرین ویرایش به وسیله mbshareat : شنبه 09 فروردین 1399 در 10:07 صبح
سلام
کمتر از دو ماهه گوشی هوشمند گرفتم.
چند تا بازی پیدا کردن اختلاف دو تصویر دانلود کردم.مثل کارآگاه ريز بین و اختلاف تصویر سینا و اختلاف تصویر ثنا و ثمین.
معمولا آخرین اختلافها رو نمیتونستم پیدا کنم. پس براش برنامه نوشتم.
a.jpg
اولش از یه روش سخت استفاده می کردم.تصویر صفحه گوشی رو میریختم پیکوفایل.
بعد در کامپیوتر دو تکه از یک jpeg (که هر کدوم یکی از دوتصویر مشابه بود) رو به تناوب نمایش میدادم که اختلاف معلوم شه.(وقتی تصویر Jpeg باشه نمیشه روی رنگ حساس شد!)
جدیدا شبیه ساز اندروید LDPlayer.3.79.3 نصب کردم.بازی کارآگاه ریزبین رو هم در اون نصب کردم.
یه برنامه نوشتم که به رنگها حساسه و رنگهای دو ناحیه از یه تصویر رو مقایسه می کنه و قسمتهایی که نقاط رنگی متفاوت داره قرمز می کنه.
در برنامه میشه مختصات دو محدوده تصویر (که همون دو تصویر مشابه هست) رو در تصویر گرفته شده از صفحه بازی هست، تعیین کرد.
این روش خیلی به دقیق بودن مختصات، حساس هست و میشه با فشار Alt+Q (وقتی ماوس روی پنجره شبیه ساز هست) تصویر ورودی رو برای برنامه تعیین کرد یا از یه فایل کنار برنامه .
مقادیر پیشفرض برنامه هم مربوط به بازی کارآگاه ریزبین با پایینترین رزولوشن شبیه ساز LDPlayer هست که قابل تغییره.
نکته:
وقتی با Alt+Q تصویر رو میگیریم میتونیم با الصاق محتوای کلیپ برد در برنامه msPaint، مختصات دو محدوده تصویرهای مشابه رو بررسی کنیم.
سورس برنامه نسخه جدید
مختصات سینا.jpg
تصويري از نسخه کمی قدیمی تر:
untitled.jpg
یه توضیح کوچولو:
بازی بالاتر، اختلاف تصویر سینا هست که رنگ آمیزی دو ناحیه تصوی مشابه اونقدر دقیق نیست که بشه اختلاف رنگ رو بررسی کرد و باید از دکمه تصوی اول/دوم استفاده کرد.
بازی پایین کارآگاه ریز بین هست که رنگهای دو محدوده تصویر، دقیق و قابل انطباق بر هم هست.در این بازی میشه از قرمز کردن نقاط رنگی که در دو تصویر متفاوتند، استفاده کرد.
آخرین ویرایش به وسیله mbshareat : یک شنبه 03 فروردین 1399 در 03:43 صبح
اجرای برنامه در پس زمینه
//FormCreate
WindowState:=wsMinimized;
Left:=-100;
Width:=0;
Height:=0;
SetWindowLong(Application.Handle, GWL_EXSTYLE,WS_EX_TOOLWINDOW AND NOT WS_EX_APPWINDOW);
//FormPaint
Application.MainForm.Hide;
آخرین ویرایش به وسیله mbshareat : سه شنبه 12 فروردین 1399 در 10:58 صبح
تبدیل تصویر عمودی و افقی به مربع با اضافه کردن حاشیه سفید
میخواستم تصویر برای اینستاگرام بفرستم کناره هاش رو حذف می کرد.در مورد اندازه تصویر تحقیق کردم به کارم نیومد.میخواستم در یک پست چند تصویر بذارم پس تنظیم تمام تصویر اینستاگرام هم به کارم نیومد.NoCrop نصب کردم به نظرم اومد خوب کار می کنه بعد دیدم اندازه تصویر رو بی منطق 2080 در 2080 می کنه.منوی تنظیماتش رو هم می زدم خیلی عجیب نرم افزار کمی قفل می کرد میرفت پس زمینه و بالا می آوردیمش از اول میشد.
بگذریم.خودم یه برنامه نوشتم که فضای خالی به تصویر اضافه می کنه که تصویر مربع بشه.متاسفانه اینترنت گوشیم تموم شد.(مثل اینکه *1000*27# هم لغو شده!)
نتونستم ببینم مربع کردن با هر اندازه ای جواب میده یا نه.البته من تصاویر حد اکثر 1000*1000 کافیم بود.
برنامه رو میذارم چون کوچیکه میشه بهش از جنبه آموزشی هم نگاه کرد.تبدیل Jpg و Bmp به هم و حذف خاکستری برای تصویر تک رنگ(من میخواستم تصویر کتاب انگلیسی پست کنم!) در برنامه هست.
نمی دونم چرا در سایت آپلود کردم لینک درست نمیده.مجبورم نسخه دوم رو در پیکو فایل بذارم.
آخرین ویرایش به وسیله mbshareat : سه شنبه 19 فروردین 1399 در 04:02 صبح
ایجاد فایل متن برای دانلود سریال توسط IDM
ابتدا لینک یک قسمت سریال رو به برنامه می دیم و شماره اولین و آخرین قسمتی که میخوایم IDM دانلود کنه تعیین می کنیم.
برنامه فایل متن میسازه که لینک قسمتها در اون هست و از قسمت امور>وارد کردن<از فایل تکست فایل متن رو به IDM معرفی می کنیم که لینکها رو استفاده کنه
آخرین ویرایش به وسیله mbshareat : سه شنبه 24 آبان 1401 در 13:24 عصر
سلام علیکم
چند وقت پیش رفتم سایت Pinterest .
تصاویر بامزه و آیکنهای مفید برای برنامه نویسی داره که به صورت مجموعه ای هستند
من دوست داشتم برنامه ای باشه که بتونم با کلیک یکی از تصاویر کوچک فایل تصویری رو بگیرم.
از کد MagicWand برای گرفتن ناحیه و GraphicEx برای تنظیم اندازه با کیفیت استفاده کردم.
میتونید با درگ هم تصویر رو روی پنجره برنامه بکشید!
امیدوارم به درد کسی بخوره و اگر دعا کنیدهم ممنون میشم.
Untitled-1.jpg
این هم سورس برنامه و تصویر:
MultiDrawing.Prg.rar
این هم نسخه بهبود يافته با جعبه ابزار که به علت استفاده از کامپوننت دکمه بدقلق خودم فقط فایل اجرایی میذارم:
س.JPG
MultiDrawing.exe.rar
آخرین ویرایش به وسیله mbshareat : جمعه 27 آبان 1401 در 17:20 عصر
سلام علیکم
گاهی لازمه در یک TEDit مقدار عددی وارد کنیم و همزمان با تغییر عدد نتیجه رو در پنجره ببینیم.
من برای راحتی کار از کلید جهت بالا یا پایین برای تنظیم عدد استفاده می کنم. اگر کنترل رو هم نگه داریم، عدد ده تا کم یا زیاد میشه.
این هم از کد:
procedure EditAction(E:TEdit;Key:Word;Shift: TShiftState);
Var
N:Byte;
begin
SetWindowLong(E.Handle, GWL_STYLE, GetWindowLong(E.Handle, GWL_STYLE) or ES_NUMBER);
If ssCtrl in Shift then
N:=10
Else
N:=1;
If Key=vk_UP then
E.Text:=IntToStr(StrToInt(E.Text)+N);
If Key=VK_DOWN then
E.Text:=IntToStr(StrToInt(E.Text)-N);
end;
سطر اول پروسیجر رو میتونید در FormCreate بذارید و فقط یک بار اجرا کنید که ادیت فقط عدد قبول کنه.
نحوه استفاده:
یک TEdit روی فرم میذاریم و چنین کدی استفاده می کنیم:
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
EditAction(TEdit(Sender),Key,Shift);
end;
سریع ترین کد برای قرینه کردن بیت مپ:
procedure FlipBmp(B:TBitmap;Mode:Byte);
Var
R,R2:TRect;
begin
R:=B.Canvas.ClipRect;
If Mode=1 then
R2:=Rect(R.Right,R.Top,R.Left,R.Bottom)
Else
R2:=Rect(R.Left,R.Bottom,R.Right,R.Top);
B.Canvas.CopyRect(R2,B.Canvas,R);
end;
کد برای تغییر رنگ پس زمینه سطر جاری در لیست باکس(حوصله توضیح اضافه ندارم)
ListBox1.Style-> lbOwnerDrawFixed
Var
LastItem:Integer=-1;
..
implementation
...
procedure TReplaceTextForm.ListBox1DrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
procedure DrawItem(Idx:Integer;R:TRect);
Var
S:String;
W:Word;
begin
If Idx=ListBox1.ItemIndex Then
ListBox1.Canvas.Brush.Color:=clAqua
Else
ListBox1.Canvas.Brush.Color:=ListBox1.Color;
//SetBkMode(ListBox1.Canvas.Handle,Transparent);
ListBox1.Canvas.FillRect(R);
ListBox1.Canvas.Font.Color:=clBlack;//ضروري
ListBox1.Canvas.TextOut(R.Left,R.Top,ListBox1.Item s[Idx]);
end;
begin
If (LastItem<>-1) And (LastItem<>ListBox1.ItemIndex)
And (LastItem<ListBox1.Items.Count) then
DrawItem(LastItem,ListBox1.ItemRect(LastItem));
DrawItem(Index,Rect);
LastItem:=Index;
end;
آخرین ویرایش به وسیله mbshareat : پنج شنبه 08 دی 1401 در 09:33 صبح
سلام دوستان
یه کد نسبتا ساده گذاشتم برای وقتیکه خواستید یه پیغام فارسی با شکلک نمایش بدید.میتونید تعیین کنیدچند ثانیه نمایش داده بشه یا تعیین نکنید.
نکته: شکلک نمایش داده شده، تصادفی است و احساس رو با رنگ نمایش میدیدم
All.JPG
a.JPG
نحوه استفاده:
بعد از اضافه کردن یونیت موجود در فایل فشرده به برنامه ، در فرم مد نظر چنین کدی میذاریم(حوصله توضیح بیشتر نداشتم):
FaceMsgForm.Msg('اين يک پيغام نمايشي است.',clYellow,1);FaceMasgForm.rar
یه تابع هم نوشتم که اگر تصویر بیت مپ شکلکها رو با نام AllFacesImg در یک فرم بذاریم، میتونیم یه پنجره پیغام مثل شکل داشته باشم(بدون اضافه کردن فرم پیغام به برنامه!)
فرق این کد با کد بالا اینه که تایمر نداره و اگر متن پیام کوتاه باشه، پهنای پنجره پیغام هم تنظیم میشه.
FaceMsg Function.rar
آخرین ویرایش به وسیله mbshareat : دوشنبه 29 خرداد 1402 در 10:53 صبح
سلام
احوال؟
چند تابع ساده نوشتم برای اینکه تعداد کارکترهای کد کمتر بشه. گفتم شاید به درد کسی خورد:
function TForm1.TrimFirst(S:String;N:Integer):String;begin
If S='' then
Exit;
Result:=Copy(S,N+1,Length(S)-N);
end;
function TForm1.TrimLast(S:String;N:Integer):String;
begin
If S='' then
Exit;
Result:=Copy(S,1,Length(S)-N);
end;
function TForm1.BeforeStr(S,S2:String):String;
begin
If S='' then
Exit;
Result:=Copy(S,1,Pos(S2,S)-1);
end;
function TForm1.AfterStr(S,S2:String):String;
begin
If S='' then
Exit;
Result:=Copy(S,Pos(S2,S)+1,Length(S)-Pos(S2,S));
end;
function TForm1.BetweenStr(S,S2,S3:String):String;
begin
If S='' then
Exit;
Result:=Copy(S,Pos(S2,S)+Length(S2),PosEx(S3,S,Pos (S2,S))-Pos(S2,S)-Length(S2));
end;
function TForm1.LastChar(S:String):String;
begin
If S='' then
Exit;
Result:=S[Length(S)];
end;
procedure TForm1.GetNums(S:String;Var A:Array of Word;Reverse:Boolean=False;ExitChar:Char=#0);
Var
I,N:Word;
Tmp:String;
begin
For I:=A[0] To High(A) Do
A[I]:=0;
S:=S+'.';
N:=0;
For I:=1 to Length(S) Do
Begin
If pos(S[I],'0123456789')>0 then
Begin
If Reverse=True then
Tmp:=S[I]+Tmp
Else
Tmp:=Tmp+S[I];
End
else If Tmp<>'' then
Begin
A[N]:=StrToInt(Tmp);
if S[I]=ExitChar then
Break;
Tmp:='';
Inc(N);
End;
End;
End;
Function TForm1.IntRev(S:String):Integer;
begin
Result:=StrToInt(ReverseString(S));
end;
Function TForm1.Rev(S:String):String;
begin
Result:=ReverseString(S);
end;
Function TForm1.AppDir:String;
begin
Result:=ExtractFileDir(Application.ExeName);
end;
Function TForm1.TopDir(S:String;LC:Boolean=False):String;
begin
If LC=True then
Result:=LowerCAse(ExtractFileDir(S))
Else
Result:=ExtractFileDir(S);
end;
Function TForm1.FN(S:String;LC:Boolean=False):String;
begin
If LC=True then
Result:=LowerCAse(ExtractFileName(S))
Else
Result:=ExtractFileName(S);
end;
Function TForm1.Ext(S:String;LC:Boolean=False):String;
begin
If LC=True then
Result:=LowerCAse(ExtractFileExt(S))
Else
Result:=ExtractFileExt(S);
end;
function TForm1.MatchPos(S,S2:String;N:Word):Integer;
Var
P,M:Integer;
begin
Result:=0;
P:=0;
M:=0;
While True Do
Begin
P:=PosEx(S2,S,P+1);
If P=0 then
Exit
Else
Begin
Inc(M);
If N=M then
Begin
Result:=P;
Exit;
End;
End;
End;
end;
function TForm1.FirstMatchPos(S:String;A:Array of String):Integer;
Var
I,P,P2:Integer;
begin
P:=0;
For I:=0 To High(A) Do
Begin
P2:=Pos(A[I],S);
If (P=0) or (P2<P) then
P:=P2;
End;
Result:=P;
end;
procedure TForm1.FormCreate(Sender: TObject);
Var
A:Array [1..3]Of Word;
begin
GetNums('}12\3-4{65',A,False,'{');
ShowMessage(IntToStr(A[3]));
ShowMessage(LastChar('bagher'));
ShowMessage(IntToStr(MatchPos('Papa','a',2)));
ShowMessage(IntToStr(FirstMatchPos('I am a Good Student!',['Go','!','a'])));
end;
دو نکته:
1. اگر اسم فرم شما TForm1 نیست میتونید با Ctrl+R تغییرش بدید و اگر صلاح دونستید .Tform1 رو حذف کنید.
2.من چون از بیسیک سراغ دلفی اومدم ترجیح میدم جای زیر رشته رو بعد از رشته اول بنویسم. اگر دلتون خواست جای پارامترها رو در MatchPos عوض کنید.
آخرین ویرایش به وسیله mbshareat : شنبه 23 دی 1402 در 12:23 عصر