MyDesign | Kod Arşivi - Anasayfaya Dön   No banner in farm
Anasayfa Araştır Forum Gelişmiş Arama Siteniz İçin En Hit İçerikler RSS İçerik Ekle Scriptler Destekleyenler Kadromuz Reklam İletişim Giriş Sayfası Yap  Sık Kullanılanlara Ekle
Bu Kategorinin En Yeni Kodları:


Bu Kategorinin En Çok Görüntülenen Kodları:






Arama:
Gelişmiş Arama


No banner in farm



En Çok Görüntülenen Kodlar:


Üye Girişi:
 Üye Ol



Anasayfa > VisualBasic > Kodlar

BIOS Bilgisi

Bios'un versiyon, tarih, telif gibi bilgilerini gösterir

Kategori : VisualBasic
Gönderen : LonG
Telif :
Tarih : 26 Kasım 2005
Örnek Dosya : �ndir
Okunma Sayısı : 8992
Puan
: 7,8 / 10 (4 Oy)
Puan Verin :
Google Bookmarks  del.icio.us  Digg  Yahoo! MyWeb  Windows Live  Furl
 
 
'// ---------- Form Kodları
Dim BD As BiosData

Private Sub Combo1_Click()
   Select Case Combo1.ListIndex
          Case 0
               Label1 = BD.SystemBiosDate
          Case 1
               Label1.Caption = BD.SystemBiosVersion
          Case 2
               Label1 = BD.SystemBiosCopyRight
          Case 3
               Label1 = BD.SystemBiosExtraInfo
          Case 4
               Label1 = BD.VideoBiosDate
          Case 5
               Label1 = BD.VideoBiosVersion
          Case 6
               Label1 = BD.VideoBiosCopyRight
   End Select
End Sub

Private Sub Form_Load()
  Caption = "Bios Information"
  Set BD = New BiosData
  With Combo1
      .AddItem "SystemBiosDate"
      .AddItem "SystemBiosVersion"
      .AddItem "SystemBiosCopyRight"
      .AddItem "SystemBiosExtraInfo"
      .AddItem "VideoBiosDate"
      .AddItem "VideoBiosVersion"
      .AddItem "VideoBiosCopyRight"
  End With
  Combo1.ListIndex = 0
End Sub



'// ---------- Module1 Modülü Kodları
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long

Public Declare Function CopyStringA Lib "kernel32" Alias "lstrcpyA" (ByVal NewString As String, ByVal OldString As Long) As Long
Public Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long

Private 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
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal numBytes As Long)

Private Const KEY_READ = &H20019

Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_MULTI_SZ = 7

Private Const ERROR_MORE_DATA = 234
Private Const ERROR_SUCCESS = 0&

Private Const MAX_SIZE = 2048
Public Const HKLM = &H80000002
 
Public Function IsWindowsNT() As Boolean
   Dim verinfo As OSVERSIONINFO
   verinfo.dwOSVersionInfoSize = Len(verinfo)
   If (GetVersionEx(verinfo)) = 0 Then Exit Function
   If verinfo.dwPlatformId = 2 Then IsWindowsNT = True
End Function

Public Function StrFromPtrA(ByVal lpszA As Long) As String
   Dim s As String
   s = String(lstrlenA(lpszA), Chr$(0))
   CopyStringA s, ByVal lpszA
   StrFromPtrA = TrimNULL(s)
End Function

Private Function TrimNULL(ByVal str As String) As String
    If InStr(str, Chr$(0)) > 0& Then
        TrimNULL = Left$(str, InStr(str, Chr$(0)) - 1&)
    Else
        TrimNULL = str
    End If
End Function

Public Function GetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
    ByVal ValueName As String, Optional DefaultValue As Variant) As Variant
    Dim handle As Long
    Dim resLong As Long
    Dim resString As String
    Dim resBinary() As Byte
    Dim length As Long
    Dim retVal As Long
    Dim valueType As Long
    GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then
        Exit Function
    End If
    length = MAX_SIZE
    ReDim resBinary(0 To length - 1) As Byte
    retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)
    If retVal = ERROR_MORE_DATA Then
        ReDim resBinary(0 To length - 1) As Byte
        retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)
    End If
    Select Case valueType
        Case REG_DWORD
            CopyMemory resLong, resBinary(0), 4
            GetRegistryValue = resLong
        Case REG_SZ, REG_EXPAND_SZ
            resString = Space$(length - 1)
            CopyMemory ByVal resString, resBinary(0), length - 1
            GetRegistryValue = resString
        Case REG_BINARY
            If length <> UBound(resBinary) + 1 Then
                ReDim Preserve resBinary(0 To length - 1) As Byte
            End If
            GetRegistryValue = resBinary()
        Case REG_MULTI_SZ
            resString = Space$(length - 2)
            CopyMemory ByVal resString, resBinary(0), length - 2
            GetRegistryValue = resString
        Case Else
            RegCloseKey handle
    End Select
    RegCloseKey handle
End Function



'// ---------- BiosData Sınıfı Kodları
Dim isNT As Boolean

Public Property Get VideoBiosDate() As String
    If isNT Then
       VideoBiosDate = GetRegistryValue(HKLM, "Hardware\Description\System", "VideoBiosDate", "")
    Else
'       VideoBiosDate = Mid(StrFromPtrA(&HC00A8), 1, 8) '-Date build
       VideoBiosDate = Mid(StrFromPtrA(&HC00A8), 9, 8) '-Date revision
    End If
End Property

Public Property Get VideoBiosVersion() As String
    Dim s As String
    If isNT Then
       s = GetRegistryValue(HKLM, "Hardware\Description\System", "VideoBiosVersion", "")
    Else
       s = StrFromPtrA(&HC0048)
       s = Left(s, InStr(1, s, vbCrLf) - 1)
       s = s & vbCrLf & "ChipType: " & GetRegistryValue(HKLM, "System\CurrentControlSet\Services\Class\Display\0000\INFO", "ChipType", "")
    End If
    VideoBiosVersion = s
End Property

Public Property Get VideoBiosCopyRight() As String
    Dim s As String
    If isNT Then
       s = "Unavailable on NT"
    Else
       s = StrFromPtrA(&HC0048)
       s = Mid$(s, InStr(1, s, vbCrLf) + 2)
    End If
    VideoBiosCopyRight = s
End Property

Public Property Get SystemBiosDate() As String
    If isNT Then
       SystemBiosDate = GetRegistryValue(HKLM, "Hardware\Description\System", "SystemBiosDate", "")
    Else
       SystemBiosDate = StrFromPtrA(&HFFFF5)
    End If
End Property

Public Property Get SystemBiosCopyRight() As String
    If isNT Then
       SystemBiosCopyRight = "Unvailable on NT"
    Else
       SystemBiosCopyRight = StrFromPtrA(&HFE091)
    End If
End Property

Public Property Get SystemBiosVersion() As String
    Dim vAns As Variant
    
    If isNT Then
        On Error Resume Next
      SystemBiosVersion = CDate(GetRegistryValue(HKLM, "Hardware\Description\System", "SystemBiosVersion", ""))
        If Err.Number > 0 Then SystemBiosVersion = "Unavailable"
        
    Else
      SystemBiosVersion = StrFromPtrA(&HFE061)
    End If
End Property

Public Property Get SystemBiosExtraInfo() As String
    If isNT Then
       SystemBiosExtraInfo = "Unvailable on NT"
    Else
       SystemBiosExtraInfo = StrFromPtrA(&HFEC71)
    End If
End Property

Private Sub Class_Initialize()
   isNT = IsWindowsNT
End Sub
 
 

BIOS Bilgisi için yazılan yorumlar

ygz79   { 12 Mart 2010 }
nasıl yapılıyor açıklayın ben yapamadım

satlihan   { 23 Haziran 2009 }
biosdata compenenti nasıl yükleyebiriz.

Yorum ekleyin

Anasayfa > VisualBasic > Kodlar > BIOS Bilgisi
Kategoriler:


Forum:



Bağlantılar:



    En Son Yorumlanan İçerikler:


    Murat Yavuz | Site Haritası | Gizlilik Bildirimi | 35.171.146.16 | 0,12 Saniye
    © Copyright 2004-2019 MyDesign | Kod Arşivi. Tüm Hakları Saklıdır.
    MyDesign | Kod Arşivi, en iyi görünüm için, 1024x768 ve üzeri çözünürlük tavsiye eder.