معرفة الرقم الحقيقى ورقم الموديل للهارديك ارجو التقييم

[wehadyxp 1]

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

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

drive_infor.rar

[بو يوسف الراشد 0]

بارك الله فيك وجزاك الله خير على هذا المثال الرائع

[wehadyxp 1]

اين الردود

[zahrah 4,313]

بارك الله فيك اخي الكريم wehadyxp

مثال اكثر من رائع

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

فهل من الممكن شرح آلية الكود فيما لو اردنا تطويره او تنقيحه طالما انك شخصيا قمت بكتابة هذا الكود ؟

[ekseer 134]

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

أخي wehadyxp بارك الله فيك على هذا المثال الرائع

طبعا التحويل تم لدي على أكمل وجه ولم يحدث أي مشكلة .. ياليت الاخوان من جرب يخبرنا هل عمل المثال على جميع الاجهزة

أرى أن المثال فيه جهد مميز ورائع .. وياليت تشرح لنا آلية عمل الكود لو أمكن سطرا سطرا وفقك الله

أخيرا دعواتي لك بالتوفيق أخي wehadyxp ولجميع الاخوة والاخوات والسلام :)

[abs_2000 2]

مشكووووووووووور

انا ظهر عندي تمام 100%

[wehadyxp 1]

سوف اضع الكود مع الشرح خلال يوم وايضا جارى الان تطويرة لقراءة رقم المعالج والمازر بورد ولكن المحاولات حتى الان لم تكتمل

[publicsoft 0]

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

Option Explicit
Private Sub Command1_Click()

Dim m_objCPUSet As SWbemObjectSet
Dim m_objWMINameSpace As SWbemServices
Dim oCpu As SWbemObject 'WMI Object, in this case, local CPUs

Set m_objWMINameSpace = GetObject("winmgmts:")
Set m_objCPUSet = m_objWMINameSpace.InstancesOf("Win32_Processor")

'I use the foir loop because I could
'not retrieve the first object normally
For Each oCpu In m_objCPUSet
	Text1 = oCpu.processorid
	Exit For
Next

Set oCpu = Nothing
Set m_objCPUSet = Nothing
Set m_objWMINameSpace = Nothing


End Sub

Private Sub Text1_GotFocus()
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
End Sub

هذا الكود يقوم بإظهار رقم البروسيسور ولكن يظهر احرف مع الارقام هل يمكنك لو سمحت ان تقومبتعديل هذا الكود حتى يظهرارقام فقط اي ان تعدل في النتيجة ويظهر في النهاية ارقام فقط مع الشكر

ممكن لو سمحت ترسل لي هذا التعديل على الاميل

الخاص بي

[email protected]

[email protected]

تم تعديل 25 Dec 2006 بواسطه المبرمج2003

[wehadyxp 1]

الكود معمول اصلا بلغة الفجول بيسك 6 vb6وقد وضعت برنامج فى المشاركة السابق وقمت بتعديلة على الاكسس

ياريت تضع مثلا

تم تعديل 25 Dec 2006 بواسطه wehadyxp

[wehadyxp 1]

هذا هو اصل الكود ولكن كان معمول على listbox وايضا بة امكانية اذا كان هناك اكثر من هاردسك على الجهاز ولدى امثلة بلغة الفاجول بيسك تظهر كافة مكونات الكمبيوتر وارقامها وموديلاتها والامر يحتاج بعض الوقت للتعديل على الاكسس واليكم اصل الكود

Option Explicit


Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const CREATE_NEW = 1
Private Const INVALID_HANDLE_VALUE = -1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const IDENTIFY_BUFFER_SIZE = 512
Private Const OUTPUT_DATA_SIZE = IDENTIFY_BUFFER_SIZE + 16

'GETVERSIONOUTPARAMS contains the data returned
'from the Get Driver Version function
Private Type GETVERSIONOUTPARAMS
   bVersion	   As Byte 'Binary driver version.
   bRevision	  As Byte 'Binary driver revision
   bReserved	  As Byte 'Not used
   bIDEDeviceMap  As Byte 'Bit map of IDE devices
   fCapabilities  As Long 'Bit mask of driver capabilities
   dwReserved(3)  As Long 'For future use
End Type

'IDE registers
Private Type IDEREGS
   bFeaturesReg	 As Byte 'Used for specifying SMART "commands"
   bSectorCountReg  As Byte 'IDE sector count register
   bSectorNumberReg As Byte 'IDE sector number register
   bCylLowReg	   As Byte 'IDE low order cylinder value
   bCylHighReg	  As Byte 'IDE high order cylinder value
   bDriveHeadReg	As Byte 'IDE drive/head register
   bCommandReg	  As Byte 'Actual IDE command
   bReserved		As Byte 'reserved for future use - must be zero
End Type

'SENDCMDINPARAMS contains the input parameters for the
'Send Command to Drive function
Private Type SENDCMDINPARAMS
   cBufferSize	 As Long	 'Buffer size in bytes
   irDriveRegs	 As IDEREGS  'Structure with drive register values.
   bDriveNumber	As Byte	 'Physical drive number to send command to (0,1,2,3).
   bReserved(2)	As Byte	 'Bytes reserved
   dwReserved(3)   As Long	 'DWORDS reserved
   bBuffer()	  As Byte	  'Input buffer.
End Type

'Valid values for the bCommandReg member of IDEREGS.
Private Const IDE_ID_FUNCTION = &HEC			'Returns ID sector for ATA.
Private Const IDE_EXECUTE_SMART_FUNCTION = &HB0 'Performs SMART cmd.
												'Requires valid bFeaturesReg,
												'bCylLowReg, and bCylHighReg

'Cylinder register values required when issuing SMART command
Private Const SMART_CYL_LOW = &H4F
Private Const SMART_CYL_HI = &HC2

'Status returned from driver
Private Type DRIVERSTATUS
   bDriverError  As Byte		  'Error code from driver, or 0 if no error
   bIDEStatus	As Byte		  'Contents of IDE Error register
								  'Only valid when bDriverError is SMART_IDE_ERROR
   bReserved(1)  As Byte
   dwReserved(1) As Long
 End Type

Private Type IDSECTOR
   wGenConfig				 As Integer
   wNumCyls				   As Integer
   wReserved				  As Integer
   wNumHeads				  As Integer
   wBytesPerTrack			 As Integer
   wBytesPerSector			As Integer
   wSectorsPerTrack		   As Integer
   wVendorUnique(2)		   As Integer
   sSerialNumber(19)		  As Byte
   wBufferType				As Integer
   wBufferSize				As Integer
   wECCSize				   As Integer
   sFirmwareRev(7)			As Byte
   sModelNumber(39)		   As Byte
   wMoreVendorUnique		  As Integer
   wDoubleWordIO			  As Integer
   wCapabilities			  As Integer
   wReserved1				 As Integer
   wPIOTiming				 As Integer
   wDMATiming				 As Integer
   wBS						As Integer
   wNumCurrentCyls			As Integer
   wNumCurrentHeads		   As Integer
   wNumCurrentSectorsPerTrack As Integer
   ulCurrentSectorCapacity	As Long
   wMultSectorStuff		   As Integer
   ulTotalAddressableSectors  As Long
   wSingleWordDMA			 As Integer
   wMultiWordDMA			  As Integer
   bReserved(127)			 As Byte
End Type

'Structure returned by SMART IOCTL commands
Private Type SENDCMDOUTPARAMS
  cBufferSize   As Long		 'Size of Buffer in bytes
  DRIVERSTATUS  As DRIVERSTATUS 'Driver status structure
  bBuffer()	As Byte		  'Buffer of arbitrary length for data read from drive
End Type

'Vendor specific feature register defines
'for SMART "sub commands"
Private Const SMART_ENABLE_SMART_OPERATIONS = &HD8

'Status Flags Values
Public Enum STATUS_FLAGS
   PRE_FAILURE_WARRANTY = &H1
   ON_LINE_COLLECTION = &H2
   PERFORMANCE_ATTRIBUTE = &H4
   ERROR_RATE_ATTRIBUTE = &H8
   EVENT_COUNT_ATTRIBUTE = &H10
   SELF_PRESERVING_ATTRIBUTE = &H20
End Enum

'IOCTL commands
Private Const DFP_GET_VERSION = &H74080
Private Const DFP_SEND_DRIVE_COMMAND = &H7C084
Private Const DFP_RECEIVE_DRIVE_DATA = &H7C088

Private Type ATTR_DATA
   AttrID As Byte
   AttrName As String
   AttrValue As Byte
   ThresholdValue As Byte
   WorstValue As Byte
   StatusFlags As STATUS_FLAGS
End Type

Private Type DRIVE_INFO
   bDriveType As Byte
   SerialNumber As String
   Model As String
   FirmWare As String
   Cilinders As Long
   Heads As Long
   SecPerTrack As Long
   BytesPerSector As Long
   BytesperTrack As Long
   NumAttributes As Byte
   Attributes() As ATTR_DATA
End Type

Private Enum IDE_DRIVE_NUMBER
   PRIMARY_MASTER
   PRIMARY_SLAVE
   SECONDARY_MASTER
   SECONDARY_SLAVE
   TERTIARY_MASTER
   TERTIARY_SLAVE
   QUARTIARY_MASTER
   QUARTIARY_SLAVE
End Enum

Private Declare Function CreateFile Lib "kernel32" _
   Alias "CreateFileA" _
  (ByVal lpFileName As String, _
   ByVal dwDesiredAccess As Long, _
   ByVal dwShareMode As Long, _
   lpSecurityAttributes As Any, _
   ByVal dwCreationDisposition As Long, _
   ByVal dwFlagsAndAttributes As Long, _
   ByVal hTemplateFile As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" _
  (ByVal hObject As Long) As Long

Private Declare Function DeviceIoControl Lib "kernel32" _
  (ByVal hDevice As Long, _
   ByVal dwIoControlCode As Long, _
   lpInBuffer As Any, _
   ByVal nInBufferSize As Long, _
   lpOutBuffer As Any, _
   ByVal nOutBufferSize As Long, _
   lpBytesReturned As Long, _
   lpOverlapped As Any) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (hpvDest As Any, _
   hpvSource As Any, _
   ByVal cbCopy As Long)

Private Type OSVERSIONINFO
   OSVSize As Long
   dwVerMajor As Long
   dwVerMinor As Long
   dwBuildNumber As Long
   PlatformID As Long
   szCSDVersion As String * 128
End Type

Private Declare Function GetVersionEx Lib "kernel32" _
   Alias "GetVersionExA" _
  (LpVersionInformation As OSVERSIONINFO) As Long



Private Sub Form_Load()

   Command1.Caption = "Get Drive Info"

End Sub


Private Sub Command1_Click()

   Dim di As DRIVE_INFO
   Dim drvNumber As Long

   For drvNumber = PRIMARY_MASTER To QUARTIARY_SLAVE

	  di = GetDriveInfo(drvNumber)

	  List1.AddItem "Drive " & drvNumber

	  With di

		 Select Case .bDriveType
			Case 0
			   List1.AddItem vbTab & "[Not present]"
			Case 1
			   List1.AddItem vbTab & "Model:" & vbTab & Trim$(.Model)
			   List1.AddItem vbTab & "Serial No:" & vbTab & Trim$(.SerialNumber)
			Case 2
			   List1.AddItem vbTab & "[ATAPI drive - info not available]"
			Case Else
			   List1.AddItem vbTab & "[drive type not known]"
		 End Select

	  End With

   Next

End Sub


Private Function GetDriveInfo(drvNumber As IDE_DRIVE_NUMBER) As DRIVE_INFO

   Dim hDrive As Long
   Dim di As DRIVE_INFO

   hDrive = SmartOpen(drvNumber)

   If hDrive <> INVALID_HANDLE_VALUE Then

	  If SmartGetVersion(hDrive) = True Then

		 With di
			.bDriveType = 0
			.NumAttributes = 0
			ReDim .Attributes(0)
			.bDriveType = 1
		 End With

		 If SmartCheckEnabled(hDrive, drvNumber) Then

			If IdentifyDrive(hDrive, IDE_ID_FUNCTION, drvNumber, di) = True Then

			   GetDriveInfo = di

			End If   'IdentifyDrive
		 End If   'SmartCheckEnabled
	  End If   'SmartGetVersion
   End If   'hDrive <> INVALID_HANDLE_VALUE

   CloseHandle hDrive

End Function


Private Function IdentifyDrive(ByVal hDrive As Long, _
							   ByVal IDCmd As Byte, _
							   ByVal drvNumber As IDE_DRIVE_NUMBER, _
							   di As DRIVE_INFO) As Boolean

  'Function: Send an IDENTIFY command to the drive
  'drvNumber = 0-3
  'IDCmd = IDE_ID_FUNCTION or IDE_ATAPI_ID
   Dim SCIP As SENDCMDINPARAMS
   Dim IDSEC As IDSECTOR
   Dim bArrOut(OUTPUT_DATA_SIZE - 1) As Byte
   Dim cbBytesReturned As Long

   With SCIP
	  .cBufferSize = IDENTIFY_BUFFER_SIZE
	  .bDriveNumber = CByte(drvNumber)

	  With .irDriveRegs
		 .bFeaturesReg = 0
		 .bSectorCountReg = 1
		 .bSectorNumberReg = 1
		 .bCylLowReg = 0
		 .bCylHighReg = 0
		 .bDriveHeadReg = &HA0 'compute the drive number
		 If Not IsWinNT4Plus Then
			.bDriveHeadReg = .bDriveHeadReg Or ((drvNumber And 1) * 16)
		 End If
		 'the command can either be IDE
		 'identify or ATAPI identify.
		 .bCommandReg = CByte(IDCmd)
	  End With
   End With

   If DeviceIoControl(hDrive, _
					  DFP_RECEIVE_DRIVE_DATA, _
					  SCIP, _
					  Len(SCIP) - 4, _
					  bArrOut(0), _
					  OUTPUT_DATA_SIZE, _
					  cbBytesReturned, _
					  ByVal 0&) Then

	  CopyMemory IDSEC, bArrOut(16), Len(IDSEC)

	  di.Model = StrConv(SwapBytes(IDSEC.sModelNumber), vbUnicode)
	  di.SerialNumber = StrConv(SwapBytes(IDSEC.sSerialNumber), vbUnicode)

	  IdentifyDrive = True

	End If

End Function


Private Function IsWinNT4Plus() As Boolean

  'returns True if running Windows NT4 or later
   Dim osv As OSVERSIONINFO

   osv.OSVSize = Len(osv)

   If GetVersionEx(osv) = 1 Then

	  IsWinNT4Plus = (osv.PlatformID = VER_PLATFORM_WIN32_NT) And _
					 (osv.dwVerMajor >= 4)

   End If

End Function

Private Function SmartCheckEnabled(ByVal hDrive As Long, _
								   drvNumber As IDE_DRIVE_NUMBER) As Boolean

  'SmartCheckEnabled - Check if SMART enable
  'FUNCTION: Send a SMART_ENABLE_SMART_OPERATIONS command to the drive
  'bDriveNum = 0-3
   Dim SCIP As SENDCMDINPARAMS
   Dim SCOP As SENDCMDOUTPARAMS
   Dim cbBytesReturned As Long

   With SCIP

	  .cBufferSize = 0

	  With .irDriveRegs
		   .bFeaturesReg = SMART_ENABLE_SMART_OPERATIONS
		   .bSectorCountReg = 1
		   .bSectorNumberReg = 1
		   .bCylLowReg = SMART_CYL_LOW
		   .bCylHighReg = SMART_CYL_HI

		   .bDriveHeadReg = &HA0
			If Not IsWinNT4Plus Then
			   .bDriveHeadReg = .bDriveHeadReg Or ((drvNumber And 1) * 16)
			End If
		   .bCommandReg = IDE_EXECUTE_SMART_FUNCTION

	   End With

	   .bDriveNumber = drvNumber

   End With

   SmartCheckEnabled = DeviceIoControl(hDrive, _
									  DFP_SEND_DRIVE_COMMAND, _
									  SCIP, _
									  Len(SCIP) - 4, _
									  SCOP, _
									  Len(SCOP) - 4, _
									  cbBytesReturned, _
									  ByVal 0&)
End Function


Private Function SmartGetVersion(ByVal hDrive As Long) As Boolean

   Dim cbBytesReturned As Long
   Dim GVOP As GETVERSIONOUTPARAMS

   SmartGetVersion = DeviceIoControl(hDrive, _
									 DFP_GET_VERSION, _
									 ByVal 0&, 0, _
									 GVOP, _
									 Len(GVOP), _
									 cbBytesReturned, _
									 ByVal 0&)

End Function


Private Function SmartOpen(drvNumber As IDE_DRIVE_NUMBER) As Long

  'Open SMART to allow DeviceIoControl
  'communications and return SMART handle

   If IsWinNT4Plus() Then

	  SmartOpen = CreateFile("\\.\PhysicalDrive" & CStr(drvNumber), _
							 GENERIC_READ Or GENERIC_WRITE, _
							 FILE_SHARE_READ Or FILE_SHARE_WRITE, _
							 ByVal 0&, _
							 OPEN_EXISTING, _
							 0&, _
							 0&)

   Else

	  SmartOpen = CreateFile("\\.\SMARTVSD", _
							  0&, 0&, _
							  ByVal 0&, _
							  CREATE_NEW, _
							  0&, _
							  0&)
   End If

End Function


Private Function SwapBytes(b() As Byte) As Byte()

  'Note: VB4-32 and VB5 do not support the
  'return of arrays from a function. For
  'developers using these VB versions there
  'are two workarounds to this restriction:
  '
  '1) Change the return data type ( As Byte() )
  '   to As Variant (no brackets). No change
  '   to the calling code is required.
  '
  '2) Change the function to a sub, remove
  '   the last line of code (SwapBytes = b()),
  '   and take advantage of the fact the
  '   original byte array is being passed
  '   to the function ByRef, therefore any
  '   changes made to the passed data are
  '   actually being made to the original data.
  '   With this workaround the calling code
  '   also requires modification:
  '
  '	  di.Model = StrConv(SwapBytes(IDSEC.sModelNumber), vbUnicode)
  '
  '   ... to ...
  '
  '	  Call SwapBytes(IDSEC.sModelNumber)
  '	  di.Model = StrConv(IDSEC.sModelNumber, vbUnicode)

   Dim bTemp As Byte
   Dim cnt As Long

   For cnt = LBound(B) To UBound(B) Step 2
	  bTemp = b(cnt)
	  b(cnt) = b(cnt + 1)
	  b(cnt + 1) = bTemp
   Next cnt

   SwapBytes = b()

End Function

تم تعديل 25 Dec 2006 بواسطه المبرمج2003

[المبرمج2003 1]

ماشاء الله تبارك الله اخي wehadyxp

عملت بعض التعديلات على كود التحويل من حروف إلى ارقام (طبعا الكود للاخت زهرة عملت عليه تعديل بسييييييييييط :D )

الطريقة باختصار

تحويل جميع الحرف والارقام إلى ارقام آسكي

فمثلا رقم المعالج او المذربورد او الهاردسك = (ABB)

A :يقابله في جدول الاسكي 65

B :يقابله في جدول الأسكي 66

عند التحويل يصبح (656666)

حتى نضمن أقل احتمالية التكرار

طبعا المثال المرفق يظهر

1- رقم المعالج (سبق التنويه عليه وشرحته الاخت زهرة)

2-رقم المذربورد (لست متأكد هل هو الموديل أم الرقم اتمنى التجربة والتأكد)

3- رقم الهاردسك (موضوعنا اليوم)

الهاردسك

المعالج

المذربورد

هذه دالة التحويل

Function Str2Int(ByVal InStrng As Variant) As String

  Dim StrLn As Long
  Dim Cntr As Long
  Dim NewStr As String

  Str2Int = ""
  StrLn = Len(Nz(InStrng))
  If StrLn = 0 Then Exit Function
  NewStr = ""
  For Cntr = 1 To StrLn
	Select Case Mid(InStrng, Cntr, 1)
	Case "0" To "z"									  
	  NewStr = NewStr & Asc(Mid(InStrng, Cntr, 1)) - 45   
	End Select

 Next Cntr
 Str2Int = NewStr
 End Function

اتمنى الكل يشارك ولو برأيه حتى نصل إلى نتيجة مرضية

وتقبلوا تحيات اخوكم

ابو حسن

نسيت المرفق :D

-------

asdf.rar

تم تعديل 25 Dec 2006 بواسطه المبرمج2003

[zahrah 4,313]

تم اغلاق المشاركه وسيتم حذفها بعد قليل لأسباب تتعلق بالكود