منتدى فيجوال بيسك لكل العرب | منتدى المبرمجين العرب - قسم مكتبة أكواد Delphi

[كود] كود مع مثال لجعل البرنامج يعمل بالتاريخ الهجري او الميلادي بغض النظر عن تاريخ

Tue, 05 Nov 2024 12:43:50 +0000

بسم الله الرحمن الرحيم

جعل البرنامج يعمل بالتاريخ الهجري او التاريخ الميلادي دون النظر او اعتبار ما يكون عليه تاريخ الجهاز

والله الموفق

PHP كود :

كود :
'فقط للتاريخ الهجري   

Imports System.Threading  'فقط للتاريخ الهجري   

Imports System.Globalization   'فقط للتاريخ الهجري   

Public Class Form1

    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click

        'هذا الكود لجعل البرنامج يعمل بالتقويم الميلادي حتى لو الجهاز بالتقويم الهجري  تستطيع وضعه في لوود الفورم 

        Threading.Thread.CurrentThread.CurrentCulture = New Globalization.CultureInfo("ar-eg")

        Threading.Thread.CurrentThread.CurrentUICulture = New Globalization.CultureInfo("ar-eg")

        TextBox1.Text = Format(Date.Now, "dd/MM/yyyy")

    End Sub

    Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click

        'هذا الكود لجعل البرنامج يعمل بالتقويم الهجري حتى لو الجهاز بالتقويم الميلادي  تستطيع وضعه في لوود الفورم 

        Dim Ar As CultureInfo = New CultureInfo("AR-SA")

        Thread.CurrentThread.CurrentCulture = Ar

        Ar.DateTimeFormat.Calendar = New HijriCalendar

        Ar.NumberFormat.DigitSubstitution = DigitShapes.NativeNational

        TextBox1.Text = Format(Date.Now, "dd/MM/yyyy")

    End Sub

End Class

وهذا المثال

https://cuty.io/G68su

كود البحث الخاص ب الداتا قريد فيو

Sun, 12 Mar 2023 14:14:24 +0000

السلام عليكم ممكن اعطانا كود البحث الخاص ب الداتاقريد فيو الذي يتم عبر textbox

مخزن ارقام الهاتف

Mon, 15 Feb 2021 15:05:04 +0000

بسم الله الرحمان الرحيم

اقدم لكم برنامج صغير الحجم و لكن الجميع يستطيع الاستفادة منه

اسم البرنامج ..RÉPERTOIRE

يستطيع تخزين اكثر من مليار رقم بحجم صغير

مؤمن بمكون absolute database

حجم البرنامج ...7.0 ميغابيت

لغة البرمجة ...EMBRACADERO XE7

سعر البرنامج ..... ( دعوة صالحة )

مطور البرنامج ...جباري صالح ( يعمل في ششار . مقيم بعين البيضاء )

تحيا الجزائر

رابط البرنامج

http://www.mediafire.com/download/zkt2qf...e_2015.rar

100000 تحية

فهم احداث لوحة المفاتيح واستبدال حروف ومنع حروف

Thu, 08 Aug 2019 12:35:18 +0000

اولا لنرى الكود التالي:

كود :
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);

begin

if NOT (key IN ['0'..'9', '-', #13]) then

key := #0;

end;

هنا يتم مقارنة الحرف المدخل بلوحة المفاتيح اذا كان يساوي من 0 الى 9 اي رقم يمر والا سيتم منعه او اذا كان المفتاح Enter او المسافة
لاحظ اننا نكتب اول رقم 0 تم نقطتين تم اخر رقم اي من 0 الى الرقم 9

يمكن استخدام الثوابت واختيارها للاسم بدل الارقام مثلا المفتاح Enter رقمه 13 والثابت له vk_Return

وهنا قائمة بكل الارقام للمفاتيح والتوابث لها
https://www.mods.com.au/budapi_docs/Virt...0Codes.htm

في الوحدة Windows.WindowsAPi يمكننا ان نجدها ايضا

كود :
{ Virtual Keys, Standard Set }

  {$EXTERNALSYM VK_LBUTTON}

  VK_LBUTTON = vkLButton; {1}

  {$EXTERNALSYM VK_RBUTTON}

  VK_RBUTTON = vkRButton; {2}

  {$EXTERNALSYM VK_CANCEL}

  VK_CANCEL = vkCancel; {3}

  {$EXTERNALSYM VK_MBUTTON}

  VK_MBUTTON = vkMButton; {4}  { NOT contiguous with L & RBUTTON }

  {$EXTERNALSYM VK_XBUTTON1}

  VK_XBUTTON1 = vkXButton1; {5}

  {$EXTERNALSYM VK_XBUTTON2}

  VK_XBUTTON2 = vkXButton2; {6}

  {$EXTERNALSYM VK_BACK}

  VK_BACK = vkBack; {8}

  {$EXTERNALSYM VK_TAB}

  VK_TAB = vkTab; {9}

  {$EXTERNALSYM VK_CLEAR}

  VK_CLEAR = vkClear; {12}

  {$EXTERNALSYM VK_RETURN}

  VK_RETURN = vkReturn; {13}

  {$EXTERNALSYM VK_SHIFT}

  VK_SHIFT = vkShift; { $10, 16}

  {$EXTERNALSYM VK_CONTROL}

  VK_CONTROL = vkControl; {17}

  {$EXTERNALSYM VK_MENU}

  VK_MENU = vkMenu; {18}

  {$EXTERNALSYM VK_PAUSE}

  VK_PAUSE = vkPause; {19}

  {$EXTERNALSYM VK_CAPITAL}

  VK_CAPITAL = vkCapital; {20}

  {$EXTERNALSYM VK_KANA }

  VK_KANA = vkKana; {21}

  {$EXTERNALSYM VK_HANGUL }

  VK_HANGUL = vkHangul; {22}

  {$EXTERNALSYM VK_JUNJA }

  VK_JUNJA = vkJunja; {23}

  {$EXTERNALSYM VK_FINAL }

  VK_FINAL = vkFinal; {24}

  {$EXTERNALSYM VK_HANJA }

  VK_HANJA = vkHanja; {25}

  {$EXTERNALSYM VK_KANJI }

  VK_KANJI = vkKanji; {26}

  {$EXTERNALSYM VK_CONVERT }

  VK_CONVERT = vkConvert; {28}

  {$EXTERNALSYM VK_NONCONVERT }

  VK_NONCONVERT = vkNonConvert; {29}

  {$EXTERNALSYM VK_ACCEPT }

  VK_ACCEPT = vkAccept; {30}

  {$EXTERNALSYM VK_MODECHANGE }

  VK_MODECHANGE = vkModeChange; {31}

  {$EXTERNALSYM VK_ESCAPE}

  VK_ESCAPE = vkEscape; {27}

  {$EXTERNALSYM VK_SPACE}

  VK_SPACE = vkSpace; { $20}

  {$EXTERNALSYM VK_PRIOR}

  VK_PRIOR = vkPrior; {33}

  {$EXTERNALSYM VK_NEXT}

  VK_NEXT = vkNext; {34}

  {$EXTERNALSYM VK_END}

  VK_END = vkEnd; {35}

  {$EXTERNALSYM VK_HOME}

  VK_HOME = vkHome; {35}

  {$EXTERNALSYM VK_LEFT}

  VK_LEFT = vkLeft; {37}

  {$EXTERNALSYM VK_UP}

  VK_UP = vkUp; {38}

  {$EXTERNALSYM VK_RIGHT}

  VK_RIGHT = vkRight; {39}

  {$EXTERNALSYM VK_DOWN}

  VK_DOWN = vkDown; {40}

  {$EXTERNALSYM VK_SELECT}

  VK_SELECT = vkSelect; {41}

  {$EXTERNALSYM VK_PRINT}

  VK_PRINT = vkPrint; {42}

  {$EXTERNALSYM VK_EXECUTE}

  VK_EXECUTE = vkExecute; {43}

  {$EXTERNALSYM VK_SNAPSHOT}

  VK_SNAPSHOT = vkSnapShot; {44}

  {$EXTERNALSYM VK_INSERT}

  VK_INSERT = vkInsert; {45}

  {$EXTERNALSYM VK_DELETE}

  VK_DELETE = vkDelete; {46}

  {$EXTERNALSYM VK_HELP}

  VK_HELP = vkHelp; {47}

{ VK_0 thru VK_9 are the same as ASCII '0' thru '9' ($30 - $39) }

{ VK_A thru VK_Z are the same as ASCII 'A' thru 'Z' ($41 - $5A) }

  {$EXTERNALSYM VK_LWIN}

  VK_LWIN = vkLWin; {91}

  {$EXTERNALSYM VK_RWIN}

  VK_RWIN = vkRWin; {92}

  {$EXTERNALSYM VK_APPS}

  VK_APPS = vkApps; {93}

  {$EXTERNALSYM VK_SLEEP}

  VK_SLEEP = vkSleep; {95}

  {$EXTERNALSYM VK_NUMPAD0}

  VK_NUMPAD0 = vkNumpad0; {96}

  {$EXTERNALSYM VK_NUMPAD1}

  VK_NUMPAD1 = vkNumpad1; {97}

  {$EXTERNALSYM VK_NUMPAD2}

  VK_NUMPAD2 = vkNumpad2; {98}

  {$EXTERNALSYM VK_NUMPAD3}

  VK_NUMPAD3 = vkNumpad3; {99}

  {$EXTERNALSYM VK_NUMPAD4}

  VK_NUMPAD4 = vkNumpad4; {100}

  {$EXTERNALSYM VK_NUMPAD5}

  VK_NUMPAD5 = vkNumpad5; {101}

  {$EXTERNALSYM VK_NUMPAD6}

  VK_NUMPAD6 = vkNumpad6; {102}

  {$EXTERNALSYM VK_NUMPAD7}

  VK_NUMPAD7 = vkNumpad7; {103}

  {$EXTERNALSYM VK_NUMPAD8}

  VK_NUMPAD8 = vkNumpad8; {104}

  {$EXTERNALSYM VK_NUMPAD9}

  VK_NUMPAD9 = vkNumpad9; {105}

  {$EXTERNALSYM VK_MULTIPLY}

  VK_MULTIPLY = vkMultiply; {106}

  {$EXTERNALSYM VK_ADD}

  VK_ADD = vkAdd; {107}

  {$EXTERNALSYM VK_SEPARATOR}

  VK_SEPARATOR = vkSeparator; {108}

  {$EXTERNALSYM VK_SUBTRACT}

  VK_SUBTRACT = vkSubtract; {109}

  {$EXTERNALSYM VK_DECIMAL}

  VK_DECIMAL = vkDecimal; {110}

  {$EXTERNALSYM VK_DIVIDE}

  VK_DIVIDE = vkDivide; {111}

  {$EXTERNALSYM VK_F1}

  VK_F1 = vkF1; {112}

  {$EXTERNALSYM VK_F2}

  VK_F2 = vkF2; {113}

  {$EXTERNALSYM VK_F3}

  VK_F3 = vkF3; {114}

  {$EXTERNALSYM VK_F4}

  VK_F4 = vkF4; {115}

  {$EXTERNALSYM VK_F5}

  VK_F5 = vkF5; {116}

  {$EXTERNALSYM VK_F6}

  VK_F6 = vkF6; {117}

  {$EXTERNALSYM VK_F7}

  VK_F7 = vkF7; {118}

  {$EXTERNALSYM VK_F8}

  VK_F8 = vkF8; {119}

  {$EXTERNALSYM VK_F9}

  VK_F9 = vkF9; {120}

  {$EXTERNALSYM VK_F10}

  VK_F10 = vkF10; {121}

  {$EXTERNALSYM VK_F11}

  VK_F11 = vkF11; {122}

  {$EXTERNALSYM VK_F12}

  VK_F12 = vkF12; {123}

  {$EXTERNALSYM VK_F13}

  VK_F13 = vkF13; {124}

  {$EXTERNALSYM VK_F14}

  VK_F14 = vkF14; {125}

  {$EXTERNALSYM VK_F15}

  VK_F15 = vkF15; {126}

  {$EXTERNALSYM VK_F16}

  VK_F16 = vkF16; {127}

  {$EXTERNALSYM VK_F17}

  VK_F17 = vkF17; {128}

  {$EXTERNALSYM VK_F18}

  VK_F18 = vkF18; {129}

  {$EXTERNALSYM VK_F19}

  VK_F19 = vkF19; {130}

  {$EXTERNALSYM VK_F20}

  VK_F20 = vkF20; {131}

  {$EXTERNALSYM VK_F21}

  VK_F21 = vkF21; {132}

  {$EXTERNALSYM VK_F22}

  VK_F22 = vkF22; {133}

  {$EXTERNALSYM VK_F23}

  VK_F23 = vkF23; {134}

  {$EXTERNALSYM VK_F24}

  VK_F24 = vkF24; {135}

  {$EXTERNALSYM VK_NUMLOCK}

  VK_NUMLOCK = vkNumLock; {144}

  {$EXTERNALSYM VK_SCROLL}

  VK_SCROLL = vkScroll; {145}

{ VK_L & VK_R - left and right Alt, Ctrl and Shift virtual keys.

  Used only as parameters to GetAsyncKeyState() and GetKeyState().

  No other API or message will distinguish left and right keys in this way. }

  {$EXTERNALSYM VK_LSHIFT}

  VK_LSHIFT = vkLShift; {160}

  {$EXTERNALSYM VK_RSHIFT}

  VK_RSHIFT = vkRShift; {161}

  {$EXTERNALSYM VK_LCONTROL}

  VK_LCONTROL = vkLControl; {162}

  {$EXTERNALSYM VK_RCONTROL}

  VK_RCONTROL = vkRControl; {163}

  {$EXTERNALSYM VK_LMENU}

  VK_LMENU = vkLMenu; {163}

  {$EXTERNALSYM VK_RMENU}

  VK_RMENU = vkRMenu; {165}

  {$EXTERNALSYM VK_BROWSER_BACK}

  VK_BROWSER_BACK = 166;

  {$EXTERNALSYM VK_BROWSER_FORWARD}

  VK_BROWSER_FORWARD = 167;

  {$EXTERNALSYM VK_BROWSER_REFRESH}

  VK_BROWSER_REFRESH = 168;

  {$EXTERNALSYM VK_BROWSER_STOP}

  VK_BROWSER_STOP = 169;

  {$EXTERNALSYM VK_BROWSER_SEARCH}

  VK_BROWSER_SEARCH = 170;

  {$EXTERNALSYM VK_BROWSER_FAVORITES}

  VK_BROWSER_FAVORITES = 171;

  {$EXTERNALSYM VK_BROWSER_HOME}

  VK_BROWSER_HOME = 172;

  {$EXTERNALSYM VK_VOLUME_MUTE}

  VK_VOLUME_MUTE = 173;

  {$EXTERNALSYM VK_VOLUME_DOWN}

  VK_VOLUME_DOWN = 174;

  {$EXTERNALSYM VK_VOLUME_UP}

  VK_VOLUME_UP = 175;

  {$EXTERNALSYM VK_MEDIA_NEXT_TRACK}

  VK_MEDIA_NEXT_TRACK = 176;

  {$EXTERNALSYM VK_MEDIA_PREV_TRACK}

  VK_MEDIA_PREV_TRACK = 177;

  {$EXTERNALSYM VK_MEDIA_STOP}

  VK_MEDIA_STOP = 178;

  {$EXTERNALSYM VK_MEDIA_PLAY_PAUSE}

  VK_MEDIA_PLAY_PAUSE = 179;

  {$EXTERNALSYM VK_LAUNCH_MAIL}

  VK_LAUNCH_MAIL = 180;

  {$EXTERNALSYM VK_LAUNCH_MEDIA_SELECT}

  VK_LAUNCH_MEDIA_SELECT = 181;

  {$EXTERNALSYM VK_LAUNCH_APP1}

  VK_LAUNCH_APP1 = 182;

  {$EXTERNALSYM VK_LAUNCH_APP2}

  VK_LAUNCH_APP2 = 183;

  {$EXTERNALSYM VK_OEM_1}

  VK_OEM_1 = 186;

  {$EXTERNALSYM VK_OEM_PLUS}

  VK_OEM_PLUS = 187;

  {$EXTERNALSYM VK_OEM_COMMA}

  VK_OEM_COMMA = 188;

  {$EXTERNALSYM VK_OEM_MINUS}

  VK_OEM_MINUS = 189;

  {$EXTERNALSYM VK_OEM_PERIOD}

  VK_OEM_PERIOD = 190;

  {$EXTERNALSYM VK_OEM_2}

  VK_OEM_2 = 191;

  {$EXTERNALSYM VK_OEM_3}

  VK_OEM_3 = 192;

  {$EXTERNALSYM VK_OEM_4}

  VK_OEM_4 = 219;

  {$EXTERNALSYM VK_OEM_5}

  VK_OEM_5 = 220;

  {$EXTERNALSYM VK_OEM_6}

  VK_OEM_6 = 221;

  {$EXTERNALSYM VK_OEM_7}

  VK_OEM_7 = 222;

  {$EXTERNALSYM VK_OEM_8}

  VK_OEM_8 = 223;

  {$EXTERNALSYM VK_OEM_102}

  VK_OEM_102 = 226;

  {$EXTERNALSYM VK_PACKET}

  VK_PACKET = 231;

  {$EXTERNALSYM VK_PROCESSKEY}

  VK_PROCESSKEY = vkProcessKey; {229}

  {$EXTERNALSYM VK_ATTN}

  VK_ATTN = vkAttn; {246}

  {$EXTERNALSYM VK_CRSEL}

  VK_CRSEL = vkCrsel; {247}

  {$EXTERNALSYM VK_EXSEL}

  VK_EXSEL = vkExsel; {248}

  {$EXTERNALSYM VK_EREOF}

  VK_EREOF = vkErEof; {249}

  {$EXTERNALSYM VK_PLAY}

  VK_PLAY = vkPlay; {250}

  {$EXTERNALSYM VK_ZOOM}

  VK_ZOOM = vkZoom; {251}

  {$EXTERNALSYM VK_NONAME}

  VK_NONAME = vkNoName; {252}

  {$EXTERNALSYM VK_PA1}

  VK_PA1 = vkPA1; {253}

  {$EXTERNALSYM VK_OEM_CLEAR}

  VK_OEM_CLEAR = vkOemClear; {254}

كود :
if Key in ['a'..'z'] + ['A'..'Z'] then Key := #0

هنا الحروف الكبيرة والصغيرة لاحظ اننا نكتب الحرف اول تم الحرف الاخير يعني من اول حرف الى اخر خرف باللغة

كود :
if Key in ['a'..'z', 'A'..'Z'] then

    Key := #0

او بهذا الشكل

إقتباس :
كود :
if HiWord(GetKeyState(vk_PageUp)) <> 0 then ShowMessage('PageUp - DOWN') else ShowMessage('PageUp - UP') ;

لبعض المفاتيح الخاصة مثل المفتاح TAB او غيره يمكننا استخدام هذه الطريقة في الكشف .

كود :
if NOT (key IN ['0'..'9', '-', #13, #8]) then begin

key := #0;

exit;

end;

هنا شرطين منع نفس السابق مع علامة (-)

كود :
if (key = '-') and (Length(Edit1.Text) > 0) then

key := #0;

هنا منع علامة (-) فقط بحال كانت الاداة تحتوي على اكثر من حرف يعني يمكنك ادخالها فقط اول مرة في البداية

كود :
if Key = 'أ' then

    Key := 'ا'

هنا نستبدل الحرف (أ) عليه همزة بحرف بدون همزة لمنع ادخال حروف مختلفة يمكنك استبدال اي حروف مثل الألف والهمزة والياء المكسورة والتاء المربوطة

إنشاء معرف فريد

Wed, 07 Aug 2019 14:00:31 +0000

كود :
procedure TForm1.Button1Click(Sender: TObject);

var

  MyGuid0, MyGuid1 : TGUID;

begin

  { Create a new GUID from the string representation. }

  MyGuid0 := StringToGUID('{00020400-0000-0000-C000-000000000046}');

  Memo1.Lines.Add('The GUID is: ' + GUIDToString(MyGuid0));

  {

  Accessing GUID's internal fields

  Using the Format function to obtain the same output as GUIDToString

  }

  Memo1.Lines.Add(Format('GUID using formatting is: ' +

       '{%0.8X-%0.4X-%0.4X-%0.2X%0.2X-%0.2X%0.2X%0.2X%0.2X%0.2X%0.2X}',

       [MyGuid0.D1, MyGuid0.D2, MyGuid0.D3,

       MyGuid0.D4[0], MyGuid0.D4[1], MyGuid0.D4[2], MyGuid0.D4[3],

       MyGuid0.D4[4], MyGuid0.D4[5], MyGuid0.D4[6], MyGuid0.D4[7]]));

  { Autogenerate a random GUID at run time. }

  if CreateGUID(MyGuid1) <> 0 then

     Memo1.Lines.Add('Creating GUID failed!')

  else

     Memo1.Lines.Add('The generated guid is: ' + GUIDToString(MyGuid1));

  { Generating second random GUID. }

  CreateGUID(MyGuid0);

  { Testing if two guids are equal. }

  if IsEqualGUID(MyGuid0, MyGuid1) then

     Memo1.Lines.Add('This cannot happen! CreateGUID guarantees that ' +

                     '2 randomly generated GUIDs cannot be equal!');

end;

النتيجة

كود :
The GUID is:

{00020400-0000-0000-C000-000000000046}

GUID using formatting is: 

{00020400-0000-0000-C000-000000000046}

The generated guid is: 

{D1CCAB8F-F534-4034-8CF5-619101F03B9D}

الحصول على سيريال المادربورد

Wed, 07 Aug 2019 13:54:17 +0000

كود :
function  GetSerialMotherBoard: String;

var

  a, b, c, d: LongWord;

begin

  asm

    push EAX

    push EBX

    push ECX

    push EDX

    mov eax, 1

    db $0F, $A2

    mov a, EAX

    mov b, EBX

    mov c, ECX

    mov d, EDX

    pop EDX

    pop ECX

    pop EBX

    pop EAX

  end;

  result := inttohex(a, 8) + '-' +

            inttohex(b, 8) + '-' +

            inttohex(c, 8) + '-' +

            inttohex(d, 8);

end;

او هذا باستخدام WMI Win32_BaseBoard Class
تحتاج الى جلب المكتبة Microsoft WMIScripting Library

كود :
program GetWMI_MotherBoardInfo;

{$APPTYPE CONSOLE}

uses

  ActiveX,

  Variants,

  SysUtils,

  WbemScripting_TLB in '..\..\..\Documents\RAD Studio\5.0\Imports\WbemScripting_TLB.pas';//

Function  GetMotherBoardSerial:string;

var

  WMIServices : ISWbemServices;

  Root        : ISWbemObjectSet;

  Item        : Variant;

begin

  WMIServices := CoSWbemLocator.Create.ConnectServer('.', 'root\cimv2','', '', '', '', 0, nil);

  Root  := WMIServices.ExecQuery('Select SerialNumber From Win32_BaseBoard','WQL', 0, nil);

  Item := Root.ItemIndex(0);

  Result:=VarToStr(Item.SerialNumber);

end;

begin

  try

    CoInitialize(nil);

    Writeln('Serial MotherBoard '+GetMotherBoardSerial);

    Readln;

    CoUninitialize;

  except

    on E:Exception do

    Begin

        CoUninitialize;

        Writeln(E.Classname, ': ', E.Message);

        Readln;

    End;

  end;

end.

او هذا باستخدام OLEVariant IBindCtx Interface and IMoniker Interface

كود :
program GetWMI_MotherBoardSerial;

{$APPTYPE CONSOLE}

uses

  SysUtils

  ,ActiveX

  ,ComObj

  ,Variants;

function GetMotherBoardSerial: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

  Result:='';

  objWMIService := GetWMIObject('winmgmts:\\localhost\root\cimv2');

  colItems      := objWMIService.ExecQuery('SELECT SerialNumber FROM Win32_BaseBoard','WQL',0);

  oEnum         := IUnknown(colItems._NewEnum) as IEnumVariant;

  if oEnum.Next(1, colItem, iValue) = 0 then

  Result:=VarToStr(colItem.SerialNumber);

end;

begin

 try

    CoInitialize(nil);

    try

      Writeln('Serial MotherBoard '+GetMotherBoardSerial);

      Readln;

    finally

    CoUninitialize;

    end;

 except

    on E:Exception do

    Begin

        Writeln(E.Classname, ': ', E.Message);

        Readln;

    End;

  end;

end.

برنامج خاص بي لانشاء الاكواد

Sun, 28 Jul 2019 13:21:23 +0000

السورس كود للبرنامج اضعته فيما ضاع من برامج وبدأت في تصميمه من جديد
طبعا لازال ينقصه الكثير فقط برمجت هذا الان وبعد ان احصل على المزيد من الوقت سوف اكمله
لازال يحتاج الى الكثير من شروط التحقق
واضافة المزيد من الشرح ومن الخيارات
واضافة الحفظ كملف PDF او الطباعة او تكبير وتصغير المستند وغيرها من الامور
كما البرنامج الذي ضاع كان فيه كل شئ من التحقق عند الرغبة في الحذف او التعديل حيث يكتب رسائل التحقق ويقدم الكثير من الدوال والاجراءات المهمة
الان هو للاتصال بقواعد بيانات FireBird سوف اضيف له امكانية الاتصال بالـ SqlServer وايضا Access وامكانية وضع الحقول يدويا لقواعد بيانات اخرى متنوعة

  1.jpg (الحجم : 139.01 ك ب / التحميلات : 125)

  2.jpg (الحجم : 49.46 ك ب / التحميلات : 125)

  3.jpg (الحجم : 43.32 ك ب / التحميلات : 125)

لتحميل نسخة غير كاملة الان

كود :
http://www.mediafire.com/file/vfrwlqewgcaobzf/FasterCode.rar/file

برنامج خاص بي للاكواد

Fri, 26 Jul 2019 10:04:24 +0000

السلام عليكم

اذا تذكرون اخبرتكم عن برنامج لي ضاع السورس كود له فقط اليومين السابقين بالصدفة وجدت نسخة قديمة بدون سورس كود في احد مواقع الرفع الخاصة بي
النسخة قديمة جدا وكنت اجريت عليها تحديثات كثيرة
ولكنها تفي بالغرض
به بعض المخاطر مثل عدم ظهور رسالة تنبيه عند حذف كود ولكن ليس مجلد فرعي
يجب اخذ نسخة من قاعدة البيانات وتجربته حتى يتم فهمه جيدا
ايقونة المجلد الاصفر لانشاء مجلد رئيسي ، لاحظ رئيسي وليس فرعي
ايقونة الممحاة هي لمسح اي مجلد او شيفرة ولها رسالة تنبيه
ايقونة الخطوط على اليمين لانشاء كود فرعي لاي مجلد تقف عليه
وايقونة الحفظ التي جنبها لحفظ الكود الذي تكتبه وعلامة الخطاء لالغاء التغييرات

في النسخة الحديثة الغيت كثير من التعقيد وجمعت الكل تحت برمجة ازرار واحدة
عندما تريد انشاء كود او مجلد او مجلد فرعي سوف ينشئه باسم افتراضي انقر عليه وغير اسمه لما تريد

1.jpg (الحجم : 133.55 ك ب / التحميلات : 86)

لاجل البحث انقر على هذا الزر واكتب ماتريد البحث عنه الزر الذي امام حقل البحث هو البحث عن الكلمة التالية في الكود وعن الكلمة التي تبحث عنها

2.jpg (الحجم : 203.35 ك ب / التحميلات : 83)

يوما ما ان شاء الله سوف اعيد البرمجة ونتشارك السورس كود معا اما الان البرنامج لمن يريد ان يجرب

كود :
http://www.mediafire.com/file/k5ns6wyjwdmjslu/Debug.rar/file

برنامج يحتوي على اكواد دلفي و مصنفة مع خاصية البحث

Thu, 20 Jun 2019 13:10:16 +0000

22.jpg (الحجم : 164.23 ك ب / التحميلات : 212)

للتحميل من هنا

Tips.rar (الحجم : 1.65 م ب / التحميلات : 260)

الحقيقة كان عندي برنامج افضل منه من برمجتي الخاصة
برمجته على Lazrus وقواعد بيانات Sqlite ولكنه ضاع مني وضاع السورس كود
ساحاول اعادة برمجته من جديد بقى فقط الصور منه التي لازالت على بعض السيرفرات حيث حذفوا الملف التنفيذي والصور لازالت باقية اسمه AMMQ

747a8a733e8d6d2.jpg (الحجم : 245.27 ك ب / التحميلات : 209)

474bf73026bae6d.jpg (الحجم : 160.09 ك ب / التحميلات : 208)

كل ما يخص الملفات والمجلدات

Wed, 19 Jun 2019 22:38:28 +0000

Check if a directory is empty

كود :
// This function returns true if Directory is an empty directory

function DirectoryIsEmpty(Directory: string): Boolean;

var

  SR: TSearchRec;

  i: Integer;

begin

  Result := False;

  FindFirst(IncludeTrailingPathDelimiter(Directory) + '*', faAnyFile, SR);

  for i := 1 to 2 do

    if (SR.Name = '.') or (SR.Name = '..') then

      Result := FindNext(SR) <> 0;

  FindClose(SR);

end;

// --------

// Example:

// --------

procedure TForm1.Button1Click(Sender: TObject);

begin

  if DirectoryIsEmpty('C:\test') then

    Label1.Caption := 'empty'

  else

    Label1.Caption := 'not empty';

end;

Check if a file is in use

كود :
function IsFileInUse(FileName: TFileName): Boolean;

var

  HFileRes: HFILE;

begin

  Result := False;

  if not FileExists(FileName) then Exit;

  HFileRes := CreateFile(PChar(FileName),

                         GENERIC_READ or GENERIC_WRITE,

                         0,

                         nil,

                         OPEN_EXISTING,

                         FILE_ATTRIBUTE_NORMAL,

                         0);

  Result := (HFileRes = INVALID_HANDLE_VALUE);

  if not Result then

    CloseHandle(HFileRes);

end;

// Example

procedure TForm1.Button1Click(Sender: TObject);

begin

  if IsFileInUse('c:\Programs\delphi6\bin\delphi32.exe') then

    ShowMessage('File is in use.');

  else

    ShowMessage('File not in use.');

end;

Check if a file is on a local drive

كود :
// Check if a file is on a local drive

function IsOnLocalDrive(aFileName: string): Boolean;

var

  aDrive: string;

begin

  aDrive := ExtractFileDrive(aFileName);

  if (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or

     (GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then

    Result := True

  else

    Result := False;

end;

// Example

procedure TForm1.Button1Click(Sender: TObject);

begin

  if OpenDialog1.Execute then

    if IsOnLocalDrive(OpenDialog1.FileName) then

      ShowMessage(OpenDialog1.FileName + ' is on a local drive.');

end;

Change file attributes

كود :
{

 To set a file's attributes, pass the name of the file and

 the attributes you want to the FileSetAttr function.

}

{

  To hide a file:

}

procedure TForm1.Button1Click(Sender: TObject);

begin

  FileSetAttr('C:\YourFile.ext', faHidden);

end;

{

  Other Files Attributes:

}

{

  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:

}

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

{

  To remove write protection on a file:

}

if (FileGetAttr(FileName) and faReadOnly) > 0

 then FileSetAttr(FileName, FileGetAttr(FileName) xor faReadOnly);

{

  Re-Set write protection:

}

FileSetAttr(FileName, FileGetAttr(FileName) or faReadOnly);

Get a file's date

كود :
// Get a file's date

function GetFileDateTime(const FileName: TFileName): TDateTime;

var

  FStruct: TOFSTRUCT;

  wndFile: Integer;

begin

  wndFile := OpenFile(PChar(FileName), FStruct, OF_SHARE_DENY_NONE);

  Result  := FileDateToDateTime(FileGetDate(wndFile));

  CloseHandle(wndFile);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

  if Opendialog1.Execute then

    label1.Caption := DateTimeToStr(GetFileDateTime(Opendialog1.FileName));

end;

GetFileModifyDate

كود :
function GetFileModifyDate(FileName: string): TDateTime;

var

  h: THandle;

  Struct: TOFSTRUCT;

  lastwrite: Integer;

  t: TDateTime;

begin

  h := OpenFile(PChar(FileName), Struct, OF_SHARE_DENY_NONE);

  try

    if h <> HFILE_ERROR then

    begin

      lastwrite := FileGetDate(h);

      Result    := FileDateToDateTime(lastwrite);

    end;

  finally

    CloseHandle(h);

  end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

  if Opendialog1.Execute then

    label1.Caption := FormatDateTime('dddd, d. mmmm yyyy hh:mm:ss',

      GetFileModifyDate(Opendialog1.FileName));

end;

Move a file in the recycle bin

كود :
// Move a file in the recycle bin

uses ShellAPI;

function DeleteFileWithUndo(sFileName: string): Boolean;

var

  fos: TSHFileOpStruct;

begin

  FillChar(fos, SizeOf(fos), 0);

  with fos do

  begin

    wFunc  := FO_DELETE;

    pFrom  := PChar(sFileName);

    fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;

  end;

  Result := (0 = ShFileOperation(fos));

end;

Rename a directory

كود :
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;

Copy / move / delete whole directory

كود :
// Copy / move / delete whole directory

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;

Copy Files to the Windows clipboard

كود :
uses

  ShlObj, ClipBrd;

procedure CopyFilesToClipboard(FileList: string);

var

  DropFiles: PDropFiles;

  hGlobal: THandle;

  iLen: Integer;

begin

  iLen := Length(FileList) + 2;

  FileList := FileList + #0#0;

  hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT,

    SizeOf(TDropFiles) + iLen);

  if (hGlobal = 0) then raise Exception.Create('Could not allocate memory.');

  begin

    DropFiles := GlobalLock(hGlobal);

    DropFiles^.pFiles := SizeOf(TDropFiles);

    Move(FileList[1], (PChar(DropFiles) + SizeOf(TDropFiles))^, iLen);

    GlobalUnlock(hGlobal);

    Clipboard.SetAsHandle(CF_HDROP, hGlobal);

  end;

end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

  CopyFilesToClipboard('C:\Bootlog.Txt'#0'C:\AutoExec.Bat');

end;

{

  Separate the files with a #0.

}

Encrypt/ decrypt files or strings

كود :
// Encrypt/ decrypt files or strings

unit EZCrypt;

{modeled by Ben Hochstrasser(bhoc@surfeu.ch) after some code snippet from borland}

interface

uses Windows, Classes;

type

  TWordTriple = Array[0..2] of Word;

function FileEncrypt(InFile, OutFile: String; Key: TWordTriple): boolean;

function FileDecrypt(InFile, OutFile: String; Key: TWordTriple): boolean;

function TextEncrypt(const s: string; Key: TWordTriple): string;

function TextDecrypt(const s: string; Key: TWordTriple): string;

function MemoryEncrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

function MemoryDecrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

implementation

function MemoryEncrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

var

  pIn, pOut: ^byte;

  i : Cardinal;

begin

  if SrcSize = TargetSize then

  begin

    pIn := Src;

    pOut := Target;

    for i := 1 to SrcSize do

    begin

      pOut^ := pIn^ xor (Key[2] shr 8);

      Key[2] := Byte(pIn^ + Key[2]) * Key[0] + Key[1];

      inc(pIn);

      inc(pOut);

    end;

    Result := True;

  end else

    Result := False;

end;

function MemoryDecrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

var

  pIn, pOut: ^byte;

  i : Cardinal;

begin

  if SrcSize = TargetSize then

  begin

    pIn := Src;

    pOut := Target;

    for i := 1 to SrcSize do

    begin

      pOut^ := pIn^ xor (Key[2] shr 8);

      Key[2] := byte(pOut^ + Key[2]) * Key[0] + Key[1];

      inc(pIn);

      inc(pOut);

    end;

    Result := True;

  end else

    Result := False;

end;

function TextCrypt(const s: string; Key: TWordTriple; Encrypt: Boolean): string;

var

  bOK: Boolean;

begin

  SetLength(Result, Length(s));

  if Encrypt then

    bOK := MemoryEncrypt(PChar(s), Length(s), PChar(Result), Length(Result), Key)

  else

    bOK := MemoryDecrypt(PChar(s), Length(s), PChar(Result), Length(Result), Key);

  if not bOK then Result := '';

end;

function FileCrypt(InFile, OutFile: String; Key: TWordTriple; Encrypt: Boolean): boolean;

var

  MIn, MOut: TMemoryStream;

begin

  MIn := TMemoryStream.Create;

  MOut := TMemoryStream.Create;

  Try

    MIn.LoadFromFile(InFile);

    MOut.SetSize(MIn.Size);

    if Encrypt then

      Result := MemoryEncrypt(MIn.Memory, MIn.Size, MOut.Memory, MOut.Size, Key)

    else

      Result := MemoryDecrypt(MIn.Memory, MIn.Size, MOut.Memory, MOut.Size, Key);

    MOut.SaveToFile(OutFile);

  finally

    MOut.Free;

    MIn.Free;

  end;

end;

function TextEncrypt(const s: string; Key: TWordTriple): string;

begin

  Result := TextCrypt(s, Key, True);

end;

function TextDecrypt(const s: string; Key: TWordTriple): string;

begin

  Result := TextCrypt(s, Key, False);

end;

function FileEncrypt(InFile, OutFile: String; Key: TWordTriple): boolean;

begin

  Result := FileCrypt(InFile, OutFile, Key, True);

end;

function FileDecrypt(InFile, OutFile: String; Key: TWordTriple): boolean;

begin

  Result := FileCrypt(InFile, OutFile, Key, False);

end;

كل ما يخص SqlServer

Wed, 19 Jun 2019 22:21:16 +0000

كود :
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;

Create tables on MS SQL Server

كود :
procedure TLocal.CreateTables(WindowsSecurity: Boolean; Username, Password: String);

var

  ConnectionString: String;

begin

  if WindowsSecurity then

    ConnectionString := 'Provider=SQLOLEDB.1;' +

                        'Integrated Security=SSPI;' +

                        'Persist Security Info=False;' +

                        'Initial Catalog=test'

  else

    ConnectionString := 'Provider=SQLOLEDB.1;' +

                        'Password=' + Password + ';' +

                        'Persist Security Info=True;' +

                        'User ID=' + Username + ';' +

                        'Initial Catalog=test';

  try

    try

      ADOConnection.ConnectionString := ConnectionString;

      ADOConnection.LoginPrompt := False;

      ADOConnection.Connected := True;

      ADOQuery.Connection := ADOConnection;

      ADOQuery.SQL.Clear;

      with ADOQuery.SQL do

      begin

        Add('create table Klijent(');

        Add('JMBG     char(13) not null,');

        Add('Ime      char(30) not null,');

        Add('Adresa   char(30) not null,');

        Add('Telefon  char(15) not null,');

        Add('Primanja numeric(6,2) not null,');

        Add('primary key (JMBG))');

      end;

      ADOQuery.ExecSQL;

      ADOQuery.SQL.Clear;

      with ADOQuery.SQL do

      begin

        Add('create table Kredit(');

        Add('Sifra    numeric not null,');

        Add('Tip      char(15) unique not null,');

        Add('Kamata   numeric not null,');

        Add('primary key (Sifra))');

      end;

      ADOQuery.ExecSQL;

      ADOQuery.SQL.Clear;

      with ADOQuery.SQL do

      begin

        Add('create table Operator(');

        Add('JMBG     char(13) unique not null,');

        Add('Ime      char(30) not null,');

        Add('Sifra    char(30) not null,');

        Add('Adresa   char(30) not null,');

        Add('Telefon  char(15) not null,');

        Add('Prioritet smallint not null check (Prioritet>0),');

        Add('primary key (JMBG))');

      end;

      ADOQuery.ExecSQL;

      ADOQuery.SQL.Clear;

      with ADOQuery.SQL do

      begin

        Add('create table Kreditiranja (');

        Add('Sifra          numeric not null,');

        Add('Sifra_kredita  numeric not null,');

        Add('Datum          datetime,');

        Add('Iznos_kredita  numeric(10,2) check (Iznos_kredita>0),');

        Add('Broj_rata      numeric,');

        Add('JMBG_klijenta  char(13),');

        Add('JMBG_operatora char(13),');

        Add('primary key(Sifra),');

        Add('foreign key(Sifra_kredita) references Kredit(Sifra) on delete cascade on update cascade,');

        Add('foreign key(JMBG_klijenta) references Klijent(JMBG) on delete cascade on update cascade,');

        Add('foreign key(JMBG_operatora) references Operator(JMBG) on delete cascade on update cascade)');

      end;

      ADOQuery.ExecSQL;

      ADOQuery.SQL.Clear;

      with ADOQuery.SQL do

      begin

        Add('create table Rata (');

        Add('Broj_rate    numeric not null,');

        Add('Broj_sifre   numeric not null,');

        Add('Datum        datetime,');

        Add('Iznos_rate   numeric(10,2) check (Iznos_rate>0),');

        Add('primary key (Broj_rate),');

        Add('foreign key (Broj_sifre) references Kreditiranja(Sifra) on delete cascade on update cascade)');

      end;

      ADOQuery.ExecSQL;

      MessageDlg('Tabele su uspjesno kreirane.', mtInformation, [mbOK], 0);

    except

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

    end;

  finally

    ADOConnection.Connected := False;

  end;

end;

Delete a User from adatabase in Sql Server

كود :
procedure TForm1.Button1Click(Sender: TObject);

begin

  ADOCommand1.CommandText := 'Use DataBaseName';

  ADOCommand1.Execute;

  ADOCommand1.CommandText := 'Exec SP_DropUser ' + QuotedStr('Username');

  ADOCommand1.Execute;

end;

Get List of Database in Sql Server

كود :
procedure TForm1.Button1Click(Sender: TObject);

begin

  ADOQuery1.SQL.Add('Exec SP_DATABASES');

  ADOQuery1.Active := True;

end;

Get List of Tables in Sql Server

كود :
procedure TForm1.Button1Click(Sender: TObject);

begin

  ADOQuery1.SQL.Add('Exec SP_Tables');

  ADOQuery1.Active := True;

end;

موقع غني جدا بشرح كل ما يتعلق بباسكال من دوال ومتغيرات واجراءات وما الى ذلك

Mon, 17 Jun 2019 16:45:28 +0000

موقع مهم جدا جدا

444.jpg (الحجم : 207.83 ك ب / التحميلات : 85)

رابط الموقع

http://www.delphibasics.co.uk/

اكود للتعامل مع الوقت والتاريخ فى بيئة Delphi

Sun, 16 Jun 2019 13:32:32 +0000

السلام عليكم ورحمة الله وبركاته

بمناسبة فتح القسم احببت مشاركة كود بسيط

حتى من يقوم ببداء التعلم فى Delphi

يتمكن من الاستفادة من تلك الاكواد

اظهار تاريخ والوقت

كود :
Label1.Caption := DateTimeToStr(Now);

اظهار الوقت فقط

كود :
Label2.Caption := TimeToStr(Time);

اظهار تاريخ فقط

كود :
Label3.Caption := DateToStr(Date);

تحياتى لكم جميعاً

وتمنياتى لكم التوفيق