انا شاكر لك جدا اخى اوس
كنت اتمنى ان اجد عدد كبير ممن حملوا البرنامج بأن يجيبونى عن رايهم
ولكن الظاهر إن محدش حمل البرنامج غيرك يا اوس اوس
وَقُل رَّبِّ زِدْنِي عِلْماً
برنامج VBCODE
مغلقرائج
أخي العزيز شكرا لك على هذه الشروح و البرامجة الرائعة أتمنى لك التقدم و النجاح.
أخوك : سعد
بسم الله الرحمن الرحيم
الاخ/ العزيز عرفة
السلام عليكم ورحمة الله وبركاته،،،
اولا اريد ان اتقدم لكم بجزيل الشكر على كل ماتقدمه من عمل للفائدة واسال الله العلى القدير ان يجعله فى ميزان حسناتك.
اخى العزيز اود منك ان تشرح لى كيفية جعل البرنامج ديموا اى يعمل لفترة معينة فقط ثم يطلب التسجيل من المستخدم اى نسخة تجريبية وياريت بالشرح الممل وهذا برنامج اضعه لك لتجعله يعمل نسخة تجريبية كمثال .
وشكرا مقدما
والسلام عليكم ورحمة الله وبركاته،،،
اخوكم/سالم
شكرا لكم حميعا وهذا ما كنت انتظرة مكنم فعلا
وبالنسبه للاخ salem001
انا حملت البرنامج وسأجعلة ديمو
وَقُل رَّبِّ زِدْنِي عِلْماً
من فضلكم أريد وصلة تحميل برنامج الفيجول بيسك وأنا أعتبر أن سؤالي سخيف لكن أنا من هواه البرمجة وأرجو من يعرف الوصلة يعرضها
وشكرا"
بسم الله الرحمن الرحيم
الاخ/ العزيز عرفة
السلام عليكم ورحمة الله وبركاته،،،
الف الف الف شكر على هذةالخدمة الطيبة التى قدمتها لى وبارك الله فيك وفى والديك وجزاك الله خيرا على كل حرف مما تكتبه لافائدة الزملاء والاصدقاء بالمنتدى وأسال الله ان يزيد بها ميزان حسناتك .
متأسف اخى العزيز على الرد المتاخر عليك .
مشكووووور اخى الكريم وفق الله لما تحبه وترضاه
والسلام عليكم ورحمة الله وبركاته،،،
اخوكم/سالم
salem001
(f)(f)(f)(f):):):):)(f)(f)(f)(f)
وعليكم السلام ورحمة الله وبركاته لكم جميعا ,,,
بارك الله فيك اخي الكريم arafa
واتمنى ان احصل على النسخه الخامسه من برنامج VBCODE
مجرد إقتراح لو تضع ملف UPDATE وتضع فيه الاكواد الجديده بدل ما يتم تحميل الملف من اول وجديد ومعروف ان الحجم وصل إلى 5.31 ميغا,,
والله الموفق ,,,
أخي العزيز arafa شكرا لك على هذه الجهود المبذولة و لكن لي عندك رجاء حار فأنا لا أملك سوى الاصدارين الأول و الثاني و أريد منك أن تضع الوصلات لبقية الأصدارات هنا لأنني لكثرة الوصلات ضعت و لم أستطيع تحميل أية وصلة مع العلم أنني أملك نظام ميلينيوم .
و شكرا لك .:)
أخوك : سعد (f)
عرفه ارجوك اشرح كيف تجعله ديمو
هل قرات موضوعى ؟
http://www.arabteam2000.com/vb/showthread....&threadid=24596
السلام عليكم جميعا
انا اسف على التأخير لبعض الظروف
اولا اخ iym بالنسبة لتحميل فيجوال بيسك كان هناك موضوع مشابهة بالمنتدى ابحث عنة وستجدة وستجد رابط تحميلة
ثانيا الاخ salem001 انا تحت امرك ولا شكر على واجب
ثالثا الاخ ابو نسرين لو كنت تريد تحميل برنامج VB CODE اخر اصدار ستجد الرابط فى توقيعى
وبمشيئة الله تعالى سيتم قريبا وضع أخر اصدار منة ولكن بعد ما تصوتو على هذا الموضوع الموجود رابطة بالاسفل
وأخير اخى osos.bg امهلنى فقط بعض الوقت لكى احضر الدرس وسأضع شرح بالكامل لكيفية عمل نسخة ديمو كما فى المثال
تحياتى لكم جميعا
ارجو الذهاب لهذا الرابط:
http://www.arabteam2000.com/vb/showthread....&threadid=24560
وَقُل رَّبِّ زِدْنِي عِلْماً
الأخ العزيز arafa لقد رديت على جميع الاستفسارات و لكن لم ترد على استفساري أرجو منك الرد لأنني في أمس الحاجة البرنامج و لقد قمت بالتصويت على البرنامج و هو رائع جدا و شكرا لك .
أخوك : سعد (f)
اقتباسكاتب الرسالة الأصلية : arafaالسلام عليكم
انا الان اطور البرنامج (( VB CODE v1.4.1 )) تطوير جديد
وجعلت البرنامج باللغتين العربية والانجليزية
وأدخلت بعض التعديلات الاخرى الطفيفة
وسيتم وضعة بالمنتدى قريبا...
ولمن لم يحمل الاصدار الثالث فعلية بتحميلة من هذا الرابط
http://w5s.com/arafa/vbcode.zip
وبعد تنصيب البرنامج علية بتحميل هذا الجزء الاخير ايضا وهو التحديث الاخير ثم نسخة ولصقة مكان القديم
هذا الرابط
http://www.arabteam2000.com/vb/attachment....=&postid=110739
تحياتى,,,
وَقُل رَّبِّ زِدْنِي عِلْماً
أخي العزيز arafa لقد قمت بتحميل البرنامج الاصدار الثالث و لكن لم أعرف كيف أقوم باللصق الذي تقصده و لذلك لم يعمل معي البرنامج لذلك أرجو منك التوضيح .
أخوك : سعد (f)
بعد تحميلك الاصدار الثالث حمل الملف دة كمان
http://www.arabteam2000.com/vb/atta...=&postid=110739
وبعد ذلك فك ضغطة وانسخ ما بداخل الملف والصقة مكان البرنامج القديم
واعتقد ان مسار البرنامج بعد تنصيبة (الاصدار الثالث) سيكون فى مجلد
program file
بالنسبة لعدم عمل البرنامج ارجو توضيح نوع المشكلة
وَقُل رَّبِّ زِدْنِي عِلْماً
عندما أنقر على البرنامج تظهر لي رسالة خطأ لا أعلم محتواها و شكرا لك على هذا الرد السريع و لكن أنا لنفرض أنني قمت بتنصيب البرنامج على القرص E و من ثم نزلت الملف و قمت بفك ضغطه فأين ألصقه أنا لم أفهم عليك و هنالك سؤال أخر أنا لم ألاحظ أي زيادة في الأكواد في الاصدار الثاني سوى تغيير بالشكل فهل بقية الاصدارات تغييرها في الشكل أم في الشكل و الأكواد . ومشكور على كل شيء أخي العزيز .
أخوك : سعد (f)
السلام عليكم
كيفية عمل نسخة ديمو من البرنامج ولا تكتمل خصائصها إلا بعد تسجيلها:مشروعنا يتكون من:
عدد 2 فورم + مود يول
أولا: افتح مشروع جديد أضف عدد 2 فورم جديد أضف مود يول
الفورم الأول ضع علية الآتي:
Frame1 وسمية frameRegister
3 مربعات نص : Text1 Text2 Text3
عدد 4 Label وسميهم كلاتى:
Label1 = مفتاح المنتج
Label2 = الاسم
Label3 = مفتاح التسجيل
Label4 = نسخة ديمو غير كاملة الخصائص
3 زر أمر وسميهم كلآتي:
CmdRegister= تسجيل
Command2= ديمو
Command3 = حول
وبهذا نكون وضعنا جميع الأدوات على الفورم الأول
نأتي للفورم الثاني ونضع علية الآتي:
Timer1 وخاصية Interval = 500
Label1 = نسخة ديمو غير كاملة الخصائص
Command1 = إنهاء البرنامج
وأخيرا افتح القائمة Tools واختار Menu Editor أضف التالي:
القائمة
تسجيل البرنامج
خروج
وأعتقد أن الكل يعرف كيفية عمل القائمة
وبذلك نكون انتهينا من وضع جميع الأدوات على الفورمين ونأتي الآن لوضع ألا كواد:
في حدث الزر cmdRegister ضع هذا الكود:
‘تسجيل البرنامج فى سجل الريجيسترى’
On Error Resume Next
Dim Reg As Boolean
Reg = RegistrationCode(Trim(Text2))
Select Case Reg
Case True:
Call CreateKey("HKEY_LOCAL_MACHINEtravelrelease")
If Text1 = "" Then
Call SetStringValue("HKEY_LOCAL_MACHINEtravelrelease", "Owner", "الحسام")
Else
Call SetStringValue("HKEY_LOCAL_MACHINEtravelrelease", "Owner", Text1)
End If
Call SetStringValue("HKEY_LOCAL_MACHINEtravelrelease", "PW", Text2)
Call SetStringValue("HKEY_LOCAL_MACHINEtravelrelease", "date", Date)
Call SetStringValue("HKEY_LOCAL_MACHINECreditint", "Award", "true")
'Case Else:
If Text2 = "" Then
Call SetStringValue("HKEY_LOCAL_MACHINEtravelrelease", "PW", Text2)
MsgBox "كلمة التسجيل غير صحيحة وسيتم فتح البرنامج", 0 + 16 + 524288, "!! تحــــذيــر "
Form2.Show
Unload Me
Else
MsgBox "كلمة التسجيل صحيحة", 0 + 64 + 524288, "تسجيل المنتج"
End If
End Select
Dim check As String
' تأكد من ان النسخة مسجلة
check = GetStringValue("HKEY_LOCAL_MACHINEtravelrelease", "PW")
If check = "error" Or check = "ERROR" Or check = "Error" Then
' النسخة لازالت مجانية
Dim d As Date
d = GetStringValue("HKEY_LOCAL_MACHINECreditint", "date")
If (Year(Date) = Year(d)) And (Month(Date) = Month(d)) And (Day(Date) - d <= 10) Then
frameRegister.Visible = True
Label4.Visible = True
cmdRegister.Visible = True
Text3.Text = GetStringValue("HKEY_LOCAL_MACHINECreditint", "IDpro")
'Else
'cmdRegister.Enabled = True
End If
Else
' النسخة مسجلة مسبقاً
Text1 = GetStringValue("HKEY_LOCAL_MACHINEtravelrelease", "Owner")
Form2.Command1.Visible = True
Form2.Label2.Visible = False
Form2.Timer1.Enabled = False
Form2.Reg.Enabled = False
frameRegister.Visible = False
Label4.Visible = False
cmdRegister.Visible = False
Timer1.Enabled = False
Command2.Caption = "نسخة مجانية"
Text3.Visible = False
Text1.Enabled = False
'Form2.Show
'Unload Me
End If
فى حدث الزر Command2 ضع الكود التالي:
‘ لفتح البرنامج فى حالة عدم تسجيلة
Form2.Show
Unload Form1
فى حدث الزر Command3 ضع الكود:
info = MsgBox("هذا البرنامج نسخة ديمو غير كاملة الخصائص ولكى تكون نسخة كاملة عليك بتسجيل البرنامج", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "نسخة ديمو ")
وفى حدث التحميل للفورم الاول نضع هذا الكود:
On Error Resume Next
Dim check As String
' تأكد من ان النسخة مسجلة
check = GetStringValue("HKEY_LOCAL_MACHINEtravelrelease", "PW")
If check = "error" Or check = "ERROR" Or check = "Error" Then
' النسخة لازالت مجانية
Dim d As Date
d = GetStringValue("HKEY_LOCAL_MACHINECreditint", "date")
If (Year(Date) = Year(d)) And (Month(Date) = Month(d)) And (Day(Date) - d <= 10) Then
frameRegister.Visible = True
Label4.Visible = True
cmdRegister.Visible = True
Text3.Text = GetStringValue("HKEY_LOCAL_MACHINECreditint", "IDpro")
'Else
'cmdRegister.Enabled = True
End If
Else
' النسخة مسجلة مسبقاً
Text1 = GetStringValue("HKEY_LOCAL_MACHINEtravelrelease", "Owner")
Form2.Command1.Visible = True
Form2.Label2.Visible = False
Form2.Timer1.Enabled = False
Form2.Reg.Enabled = False
frameRegister.Visible = False
Label4.Visible = False
cmdRegister.Visible = False
Timer1.Enabled = False
Command2.Caption = "نسخة مجانية"
Text1.Enabled = False
Form2.Show
Unload Me
End If
وفى الحدث الخاص بالاداة Timer1 ضع الكود:
Label4.Visible = Not Label4.Visible
نذهب الآن للفورم رقم 2 :
فى حدث التحميل للفورم نضع الكود:
Dim a
Dim serial As String
Dim id As String
a = GetStringValue("HKEY_LOCAL_MACHINECreditint", "Award")
If (Year(Date) = Year(d)) And (Month(Date) = Month(d)) And (Day(Date) - d <= 10) Then
End If
Select Case a
Case True:
'النسخة مسجلة
a = GetStringValue("HKEY_LOCAL_MACHINEtravelrelease", "Owner")
If a = "ERROR" Or a = "error" Or a = "Error" Then
Call SetStringValue("HKEY_LOCAL_MACHINECreditint", "Award", "false")
Else
DoEvents
End If
Case False:
'النسخة مستخدمة مجانا وغير مسجلة
Case Else:
'اول استخدام للنسخة
Call CreateKey("HKEY_LOCAL_MACHINECreditint")
Call SetStringValue("HKEY_LOCAL_MACHINECreditint", "Award", "false")
serial = DriveSerialNumber("C:") & DriveSerialNumber("d:") & Year(Date)
id = GenerateIDProduction(serial)
Call SetStringValue("HKEY_LOCAL_MACHINECreditint", "IDpro", id)
Call SetStringValue("HKEY_LOCAL_MACHINECreditint", "date", Date)
End Select
فى الحدث الخص بالاداة Timer1 :
Label1.Visible = Not Label1.Visible
فى الحدث الخاص لزر الامر Command1 :
end
افتح القائمة بأعلى الفورم واختار منها:
(تسجيل البرنامج) وفى الحدث الخاص بها ضع الكود:
Form1.Show
Unload me
وأخيرا افتح الموديول وضع به هذا الكود المسؤول عن عمل تسجيل للبرنامج في الريجيستري:
' متغيرين يستخدمان في التشفير وفك التشفير
Global c(11) As String
Global b(11) As String
Type FILETIME
lLowDateTime As Long
lHighDateTime As Long
End Type
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByRef lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Long, ByVal cbData As Long) As Long
Declare Function RegSetValueExB Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Byte, ByVal cbData As Long) As Long
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Public Declare Function SetWindowRgn Lib "User32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&
Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&
Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ
Dim hKey As Long, MainKeyHandle As Long
Dim rtn As Long, lBuffer As Long, sBuffer As String
Dim lBufferSize As Long
Dim lDataSize As Long
Dim ByteArray() As Byte
Const DisplayErrorMsg = False
Public Function DriveSerialNumber(ByVal Drive As String) As Long
'DriveSerialNumber("C:")الاستدعاء الامثل الدالة على الصورة
Dim lAns As Long
Dim lRet As Long
Dim sVolumeName As String, sDriveType As String
Dim sDrive As String
'إضافة علامة الجدر إن لم توجد في الادخال
sDrive = Drive
If Len(sDrive) = 1 Then
sDrive = sDrive & ":"
ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" Then
sDrive = sDrive & ""
End If
sVolumeName = String$(255, Chr$(0))
sDriveType = String$(255, Chr$(0))
lRet = GetVolumeInformation(sDrive, sVolumeName, _
255, lAns, 0, 0, sDriveType, 255)
'الخاصة بذلك api الحصول على رقم محرك الاقراص من خلال استدعاء دالة
DriveSerialNumber = lAns
End Function
Public Function GenerateIDProduction(number As String) As String
' توليد رقم منتج ليظهر لمستخدم البرنامج في شاشة حول
' Number تشفير كل جزء من الرقم
c(1) = Chr$(90 - (Mid(number, 1, 1)))
c(2) = Chr$(90 - (Mid(number, 2, 1)))
c(4) = Chr$(90 - (Mid(number, 4, 1)))
c(6) = Chr$(90 - (Mid(number, 6, 1)))
c(8) = Chr$(90 - (Mid(number, 8, 1)))
c(9) = Chr$(90 - (Mid(number, 9, 1)))
c(11) = Chr$(90 - (Mid(number, Len(number), 1)))
c(3) = Mid(number, 3, 1)
c(5) = Mid(number, 5, 1)
c(7) = Mid(number, 7, 1)
c(10) = Mid(number, 10, Len(number) - 10)
' اعادة تجميع الرقم المشفر
GenerateIDProduction = c(1) & c(2) & c(3) & c(4) & _
c(5) & c(6) & c(7) & c(8) & c(9) & _
c(10) & c(11)
End Function
Public Function GeneratePW(number As String) As String
' توليد كلمة مرور متوافقة مع رقم المنتج المولد مسبقا
On Error GoTo ERRHANDEL
c(1) = Chr$(Asc(Mid(number, 1, 1)) - 1)
c(2) = Chr$(Asc(Mid(number, 2, 1)) - 1)
c(4) = Chr$(Asc(Mid(number, 4, 1)) - 1)
c(6) = Chr$(Asc(Mid(number, 6, 1)) - 1)
c(8) = Chr$(Asc(Mid(number, 8, 1)) - 1)
c(9) = Chr$(Asc(Mid(number, 9, 1)) - 1)
c(11) = Chr$(Asc(Mid(number, Len(number), 1)) - 1)
If Mid(number, 3, 1) >= 2 Then
c(3) = (Mid(number, 3, 1)) - 1
Else
c(3) = Mid(number, 3, 1)
End If
If Mid(number, 5, 1) <= 8 Then
c(5) = (Mid(number, 5, 1)) + 1
Else
c(5) = Mid(number, 5, 1)
End If
c(7) = Mid(number, 7, 1)
c(10) = Mid(number, 10, Len(number) - 10)
GeneratePW = c(1) & c(2) & c(3) & c(4) & _
c(5) & c(6) & c(7) & c(8) & c(9) & _
c(10) & c(11)
Exit Function
ERRHANDEL:
GeneratePW = "ERROR"
End Function
Public Function RegistrationCode(number As String) As Boolean
On Error Resume Next
Dim code As String
c(1) = Chr$(Asc(Mid(number, 1, 1)) + 1)
b(1) = 90 - Asc(c(1))
c(2) = Chr$(Asc(Mid(number, 2, 1)) + 1)
b(2) = 90 - Asc(c(2))
c(4) = Chr$(Asc(Mid(number, 4, 1)) + 1)
b(4) = 90 - Asc(c(4))
c(6) = Chr$(Asc(Mid(number, 6, 1)) + 1)
b(6) = 90 - Asc(c(6))
c(8) = Chr$(Asc(Mid(number, 8, 1)) + 1)
b(8) = 90 - Asc(c(8))
c(9) = Chr$(Asc(Mid(number, 9, 1)) + 1)
b(9) = 90 - Asc(c(9))
c(11) = Chr$(Asc(Mid(number, Len(number), 1)) + 1)
b(11) = 90 - Asc(c(11))
If Mid(number, 3, 1) >= 1 Then
c(3) = (Mid(number, 3, 1)) + 1
Else
c(3) = Mid(number, 3, 1)
End If
b(3) = c(3)
If Mid(number, 5, 1) <= 9 Then
c(5) = (Mid(number, 5, 1)) - 1
Else
c(5) = Mid(number, 5, 1)
End If
b(5) = c(5)
c(7) = Mid(number, 7, 1)
b(7) = c(7)
c(10) = Mid(number, 10, Len(number) - 10)
b(10) = c(10)
code = b(1) & b(2) & b(3) & b(4) & b(5) & b(6) & b(7) _
& b(8) & b(9) & b(10) & b(11)
If Mid(code, 1, Len(code) - 4) = DriveSerialNumber("C:") & DriveSerialNumber("d:") Then
RegistrationCode = True
Else
RegistrationCode = False
End If
End Function
Function GetMainKeyHandle(MainKeyName As String) As Long
' الحصول على الاسم الرقم الدال على جدر المفتاح التفرعي المدخل
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Select Case MainKeyName
Case "HKEY_CLASSES_ROOT"
GetMainKeyHandle = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
GetMainKeyHandle = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
GetMainKeyHandle = HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
GetMainKeyHandle = HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
GetMainKeyHandle = HKEY_PERFORMANCE_DATA
Case "HKEY_CURRENT_CONFIG"
GetMainKeyHandle = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
GetMainKeyHandle = HKEY_DYN_DATA
End Select
End Function
Function ErrorMsg(lErrorCode As Long) As String
' دالة خاصة بعرض رسالة الخطأ بناءا على سبب حدوثها
Select Case lErrorCode
Case 1009, 1015
GetErrorMsg = "The Registry Database is corrupt!"
Case 2, 1010
GetErrorMsg = "Bad Key Name"
Case 1011
GetErrorMsg = "Can't Open Key"
Case 4, 1012
GetErrorMsg = "Can't Read Key"
Case 5
GetErrorMsg = "Access to this key is denied"
Case 1013
GetErrorMsg = "Can't Write Key"
Case 8, 14
GetErrorMsg = "Out of memory"
Case 87
GetErrorMsg = "Invalid Parameter"
Case 234
GetErrorMsg = "There is more data than the buffer has been allocated to hold."
Case Else
GetErrorMsg = "Undefined Error Code: " & Str$(lErrorCode)
End Select
End Function
Private Sub ParseKey(Keyname As String, Keyhandle As Long)
' التأكد من ادخال اسم المفتاح التفرعي بصورة صحيحة
rtn = InStr(Keyname, "") 'ترجع موقع علامة الجدر في اسم المفتاح التفرعي
If Left(Keyname, 5) <> "HKEY_" Or Right(Keyname, 1) = "" Then 'اذا كانت علامة الجدر هي اخر حرف في الاسم المدخل
MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + Keyname 'عرض رسالة خطأ في ادخال اسم المفتاح التفرعي
Exit Sub
ElseIf rtn = 0 Then 'اذا كان اسم المفتاح التفرعي لا يحتوي على علامة الجدر
Keyhandle = GetMainKeyHandle(Keyname)
Keyname = "" 'اترك اسم المفتاح فارغ
Else ' ادخال اسم المفتاح التفرعي صحيح
Keyhandle = GetMainKeyHandle(Left(Keyname, rtn - 1)) 'اعطني الاسم الكامل للمفتاح التفرعي المقصود
Keyname = Right(Keyname, Len(Keyname) - rtn)
End If
End Sub
Function CreateKey(SubKey As String)
' خلق مفتاح جديد
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegCreateKey(MainKeyHandle, SubKey, hKey) 'خلق المفتاح
If rtn = ERROR_SUCCESS Then 'اذا كان المفتاح التفرعي موجود اصلا
rtn = RegCloseKey(hKey) 'اغلق المفتاح
End If
End If
End Function
Function DeleteKey(Keyname As String)
Call ParseKey(Keyname, MainKeyHandle)
If MainKeyHandle Then
rtn = RegDeleteKey(MainKeyHandle, Keyname)
If rtn = ERROR_SUCCESS Then
rtn = RegDeleteKey(hKey, Keyname)
rtn = RegCloseKey(hKey)
End If
End If
End Function
Function SetStringValue(SubKey As String, Entry As String, Value As String)
' الكتابة في حقل بيانات قيمة المفتاح
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'فتح المفتاح التفرعي
If rtn = ERROR_SUCCESS Then 'اذا تمت عملية فتح المفتاح التفرعي بصورة صحيحة
rtn = RegSetValueEx(hKey, Entry, 0, REG_SZ, ByVal Value, Len(Value)) 'كون قيمة المفتاح وبياناتها
If Not rtn = ERROR_SUCCESS Then 'اذا حدث خطأ في وضع القيمة او بياناتها
If DisplayErrorMsg = True Then 'اذا اراد المستخدم عرض رسالة الخطأ
MsgBox ErrorMsg(rtn) 'اعرض رسالة الخطأ
End If
End If
rtn = RegCloseKey(hKey) 'اغلق المفتاح
Else 'اذا كان هناك خطأ في عملية فتح المفتاح التفرعي
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function
Function GetStringValue(SubKey As String, Entry As String)
'MainKeyHandle ستقوم هذه الدالة بفصل الاسم الخاص بالمفتاح المراد خلقه وترجيع الرقم الدال على جدر التفرع في المتغير
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'اذا كان المفتاح التفرعي مفتوح الان
sBuffer = Space(255) 'كون قناة فتح اخرى
lBufferSize = Len(sBuffer)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_SZ, sBuffer, lBufferSize) 'get the value from the registry
If rtn = ERROR_SUCCESS Then 'اذا كانت بيانات المفتاح تسترجع الان
rtn = RegCloseKey(hKey) 'اغلق المفتاح
sBuffer = Trim(sBuffer)
GetStringValue = Left(sBuffer, Len(sBuffer) - 1) 'قراءة بيانات قيمة المفتاح المعني
Else
GetStringValue = "Error" 'اذا حدث خطأ في قراءة بيانات قيمة المفتاح
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else 'اذا لم يتمكن من فتح المفتاح
GetStringValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function
وبذلك نكون قد انتهينا من شرح كيفية عمل تسجيل للبرنامج لنسخة ديمو غير كاملة الخصائص
تحياتى لكم جميعا
وَقُل رَّبِّ زِدْنِي عِلْماً
و لكن أنا لنفرض أنني قمت بتنصيب البرنامج على القرص E
أعتقد من الصح عدم تغير مسار البرنامج من القرص C:Program Files
الى القرص E
قد يحدث احيانا بعض الخطأ
وَقُل رَّبِّ زِدْنِي عِلْماً
أخي العزيز arafa لقد قمت بعمل نصيحتك و لكن الوصلة الخاصة بتحديث الاصدار الثالث لم تعمل لدي و أنا أريد الوصلة للاصدار الثالث مع تحديثه . أرجوك يا أخي و أنا أعرف بأنني قد أثقلت عليك و لكن تحملني .
أخوك : سعد (f)
أخي العزيز arafa لقد قمت بتحميل الملف و فك ضغطه ظهرت لي هذه الرسالة :
خطأ في بدء تشغيل البرنامج
لا يمكن بدء تشغيل الملف MSVBVM60.DLL
قم بالتدقيق في الملف لتحديد المشكلة .
أرجو الرد يا أخي العزيز
أخوك : سعد (f)
هناك خطأ بالملف MSVBVM60.DLL
علشان كدة مش عايز يعمل البرنامج
ممكن تحملة من على النت من جديد وتضعة بمجلد السيستم
لو استمرت المشكلة هذا ايميلى:
وَقُل رَّبِّ زِدْنِي عِلْماً
أخي العزيز ARAFA شكرا لك على الرد السريع و لكن من أين أقوم بتحميل هذا الملف و بصراحة أنا كنت أريد أن أطلب منك الايميل لنصبح أصدقاء أيضا خارج العمل و هاهي الفرصة أتت لوحدها أنا أشكرك من كل قلبي يا أخي العزيز .
أخوك : سعد (f)
أخي العزيز شكرا لك و على فكرة لقد أرسلت لك على الايميل .
أخوك : سعد (f)
هذا الموضوع مغلق.