Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Aralık 2008 Cumartesi

PC Informations




UserForm1

'Add Tools on userForm1: Image1, Label1, ComboBox1, ListBox1
Option Explicit
'Ortak Tanımlamalar

Dim No As Double
Dim Bulgu As String
Dim Yongalar As Object
Dim BilgisayarAdı As String
'ComputerName

Dim SektörAdı As String 'RootName
Dim SınıfAdı As String 'ClassName
Dim İşletimSistemiYongaları As Object 'Windows Management Instrumentation (WMI)
Dim İşletimSistemiYongalarıKartı As Object 'Windows Management Instrumentation (WMIB)
'MotherBoard
Dim AnaKartYongası As Object 'MotherBoard (MB)
'
WMI

Dim Programlar As Variant
Dim YüklüBileşenProgramları
'
BIOS

Dim BIOSBilgisi As Variant
'
Video Controller
Dim EkranKartıBilgisi As Variant
'
Pointing (Mouse) Devices Information

Dim MouseBilgisi As Variant
Dim CPUBilgisi As Variant
'
Network Adapter

Dim AğBilgisi As Variant
S'ys
Dim SistemParçası As Object
'
Operating System (OS)
Dim OS As Object

Private Sub UserForm_Initialize()
On Error Resume Next
Application.Visible = False
Application.VBE.MainWindow.Visible = False
Me.Caption = "[PBİD®] PC Informations"
With TextBox1
.MultiLine = True
.ScrollBars = fmScrollBarsVertical
End With
Call ListeHazırla
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End Sub
Private Sub ComboBox1_Click()
On Error Resume Next
No = ComboBox1.ListIndex
Select Case No
Case Is = 0
Call AnakartBilgileri
Case Is = 1
Call YüklüWindowsBileşenProgramları
Case Is = 2
Call TemelGirişÇıkışSistemiBilgileri
Case Is = 3
Call EkranKartıBilgileri
Case Is = 4
Call FareBilgileri
Case Is = 5
Call AğBağdaştırıcıları
Case Is = 6
Call SistemBilgileri
Case Is = 7
Call İşletimSistemiBilgileri
Case Is = 8
'Call ""
End Select
End Sub
Sub ListeHazırla()
On Error Resume Next
With ComboBox1
.AddItem "Mother Board Information"
.AddItem "Windows Management Instrumentation (WMI)"
.AddItem "Basic Input/Output System (BIOS) Information"
.AddItem "Video Controller Information"
.AddItem "Pointing (Mouse) Devices Information"
.AddItem "Network Adapter Information"
.AddItem "Sys Information"
.AddItem "Operating System (OS) Information"
End With
End Sub
Sub AnakartBilgileri() 'Mother Board Information
On Error Resume Next
BilgisayarAdı = "."
SektörAdı = "Root\CimV2"
SınıfAdı = "Win32_BaseBoard"
Set İşletimSistemiYongaları = GetObject("winmgmts:\\" & BilgisayarAdı & "\" & SektörAdı)
Set İşletimSistemiYongalarıKartı = İşletimSistemiYongaları.ExecQuery("Select * from " & SınıfAdı)
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each AnaKartYongası In İşletimSistemiYongalarıKartı
If VBA.Len(VBA.Trim(AnaKartYongası.Manufacturer)) = 0 Then
Bulgu = "Üretici Firma" & VBA.Chr(9) & "---" & vbCrLf
Else
Bulgu = "Üretici Firma" & VBA.Chr(9) & AnaKartYongası.Manufacturer & vbCrLf
End If
If VBA.Len(VBA.Trim(AnaKartYongası.SerialNumber)) = 0 Then
Bulgu = Bulgu & "Seri Numarası" & VBA.Chr(9) & "---"
Else
Bulgu = Bulgu & "Seri Numarası" & VBA.Chr(9) & AnaKartYongası.SerialNumber
End If
'MsgBox "ANA KART BİLGİLERİ" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & VBA.String(70, "-") & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbInformation, "[PBİD®] MotherBoard (MB)"
TextBox1.Text = Bulgu
TextBox1.SetFocus
Next
End Sub
Sub YüklüWindowsBileşenProgramları() 'Windows Management Instrumentation (WMI)
On Error Resume Next
Bulgu = ""
BilgisayarAdı = "."
Set Yongalar = GetObject("Winmgmts:" & "{ImpersonationLevel=Impersonate}!\\" & BilgisayarAdı & "\Root\CimV2")
Set YüklüBileşenProgramları = Yongalar.ExecQuery("Select * from Win32_Product")
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each Programlar In YüklüBileşenProgramları
Bulgu = Bulgu & "Program" & VBA.Chr(9) & Programlar.name & vbCrLf
Bulgu = Bulgu & "Versiyon" & VBA.Chr(9) & Programlar.Version & vbCrLf
Bulgu = Bulgu & "Üretici" & VBA.Chr(9) & Programlar.Vendor & vbCrLf
Bulgu = Bulgu & "Kurulum" & VBA.Chr(9) & VBA.left(Programlar.InstallDate, 4) & "/" & VBA.Mid(Programlar.InstallDate, 5, 2) & "/" & VBA.Mid(Programlar.InstallDate, 7, 2) & vbCrLf
Bulgu = Bulgu & VBA.String(157, "-") & vbCrLf
Next
'MsgBox "MSI İLE YÜKLENMİŞ PROGRAMLAR" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
TextBox1.Text = BulguTextBox1.SetFocus
End Sub
Sub TemelGirişÇıkışSistemiBilgileri() 'Basic Input/Output System (BIOS) Information
On Error Resume Next
Bulgu = ""
Set Yongalar = GetObject("WinMgmts:").InstancesOf("Win32_Bios")
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each BIOSBilgisi In Yongalar
Bulgu = Bulgu & "Üretici Firma" & VBA.Chr(9) & BIOSBilgisi.Manufacturer & vbCrLf
Bulgu = Bulgu & "BIOS Seri Numarası" & VBA.Chr(9) & BIOSBilgisi.SerialNumber & vbCrLf
Bulgu = Bulgu & String(157, "-") & vbCrLf
Next
'MsgBox "BIOS BİLGİLERİ" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Basic Input/Output System (BIOS) Information"
TextBox1.Text = Bulgu
TextBox1.SetFocus
End Sub
Sub EkranKartıBilgileri() 'Video Controller Information
On Error Resume Next
Bulgu = ""
Set Yongalar = GetObject("WinMgmts:").InstancesOf("Win32_VideoController")
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each EkranKartıBilgisi In Yongalar
Bulgu = Bulgu & "Üretici Firma" & VBA.Chr(9) & EkranKartıBilgisi.AdapterCompatibility & "(" & EkranKartıBilgisi.Caption & ")" & vbCrLf
Bulgu = Bulgu & "Yatay Çözünürlük" & VBA.Chr(9) & EkranKartıBilgisi.CurrentHorizontalResolution & vbCrLf
Bulgu = Bulgu & "Dikey Çözünürlük" & VBA.Chr(9) & EkranKartıBilgisi.CurrentVerticalResolution & vbCrLf
Bulgu = Bulgu & "Renk Kalitesi" & VBA.Chr(9) & EkranKartıBilgisi.CurrentBitsPerPixel & " bps" & vbCrLf
Bulgu = Bulgu & "Video Modu" & VBA.Chr(9) & EkranKartıBilgisi.VideoModeDescription & vbCrLf
Bulgu = Bulgu & "İşlemci" & VBA.Chr(9) & VBA.Chr(9) & EkranKartıBilgisi.VideoProcessor & vbCrLf
Bulgu = Bulgu & String(157, "-") & vbCrLf
Next
'MsgBox "EKRAN KARTI BİLGİLERİ" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Video Controller Information"
TextBox1.Text = Bulgu
TextBox1.SetFocus
End Sub
Sub FareBilgileri() 'Pointing (Mouse) Devices Information
On Error Resume Next
Bulgu = ""
Set Yongalar = GetObject("WinMgmts:").InstancesOf("win32_PointingDevice")
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each MouseBilgisi In Yongalar
Bulgu = Bulgu & "İşlemci" & VBA.Chr(9) & VBA.Chr(9) & Trim(CPUBilgisi.name) & vbCrLf
Bulgu = Bulgu & "Ad" & VBA.Chr(9) & VBA.Chr(9) & MouseBilgisi.name & vbCrLf
Bulgu = Bulgu & "Üretici" & VBA.Chr(9) & VBA.Chr(9) & MouseBilgisi.Manufacturer & vbCrLf
Bulgu = Bulgu & "Buton Adedi" & VBA.Chr(9) & MouseBilgisi.NumberOfButtons & vbCrLf
Bulgu = Bulgu & String(157, "-") & vbCrLf
Next
'MsgBox "MOUSE BİLGİLERİ" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Pointing (Mouse) Devices Information"
TextBox1.Text = Bulgu
TextBox1.SetFocus
End Sub
Sub AğBağdaştırıcıları() 'Network Adapter Information
On Error Resume Next
Bulgu = ""
Set Yongalar = GetObject("WinMgmts:").InstancesOf("Win32_NetworkAdapter")
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each AğBilgisi In Yongalar
Bulgu = Bulgu & "Üretici Firma" & VBA.Chr(9) & AğBilgisi.Manufacturer & vbCrLf
Bulgu = Bulgu & "Adı" & VBA.Chr(9) & VBA.Chr(9) & AğBilgisi.name & vbCrLf
Bulgu = Bulgu & "Tip" & VBA.Chr(9) & VBA.Chr(9) & AğBilgisi.AdapterType & vbCrLf
Bulgu = Bulgu & String(157, "-") & vbCrLf
Next
'MsgBox "AĞ BAĞDAŞTIRICILARI BİLGİLERİ" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Network Adapter Information"
TextBox1.Text = Bulgu
TextBox1.SetFocus
End Sub
Sub SistemBilgileri() 'Sys Information
On Error Resume Next
Bulgu = ""
Set Yongalar = GetObject("Winmgmts:").InstancesOf("Win32_ComputerSystem")
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each SistemParçası In Yongalar
Bulgu = Bulgu & "Ad" & VBA.Chr(9) & VBA.Chr(9) & SistemParçası.name & vbCrLf
Bulgu = Bulgu & "Tip" & VBA.Chr(9) & VBA.Chr(9) & SistemParçası.SystemType & vbCrLf
Bulgu = Bulgu & "Üretici" & VBA.Chr(9) & VBA.Chr(9) & SistemParçası.Manufacturer & vbCrLf
Bulgu = Bulgu & "Model" & VBA.Chr(9) & VBA.Chr(9) & SistemParçası.Model & vbCrLf
Bulgu = Bulgu & "RAM" & VBA.Chr(9) & VBA.Chr(9) & SistemParçası.TotalPhysicalMemory \ 1024000 & " Mb" & vbCrLf
Bulgu = Bulgu & "Domain" & VBA.Chr(9) & VBA.Chr(9) & SistemParçası.Domain & vbCrLf
Bulgu = Bulgu & "Kayıtlı Kullanıcı" & VBA.Chr(9) & SistemParçası.Username & vbCrLf
Bulgu = Bulgu & String(157, "-") & vbCrLf
Next
'MsgBox "SİSTEM BİLGİLERİ" & vbCrLf & VBA.String(70, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Sys Information"
Set Yongalar = Nothing
TextBox1.Text = BulguTextBox1.SetFocus
End Sub
Sub İşletimSistemiBilgileri() 'Operating System (OS) Information
On Error Resume Next
Bulgu = ""
BilgisayarAdı = "."
SektörAdı = "Root\CimV2"
SınıfAdı = "Win32_OperatingSystem"
Set İşletimSistemiYongaları = GetObject("Winmgmts:\\" & BilgisayarAdı & "\" & SektörAdı)
Set İşletimSistemiYongalarıKartı = İşletimSistemiYongaları.ExecQuery("Select * from " & SınıfAdı)
If Err.Number <> 0 Then
MsgBox "WMI yüklenmemiş! Programdan çıkılacak..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Windows Management Instrumentation (WMI)"
Exit Sub
On Error GoTo 0
End If
For Each OS In İşletimSistemiYongalarıKartı
Bulgu = Bulgu & "Üretici Firma" & VBA.Chr(9) & VBA.Chr(9) & OS.Manufacturer & vbCrLf
Bulgu = Bulgu & "Kayitli Kullanici" & VBA.Chr(9) & VBA.Chr(9) & OS.RegisteredUser & vbCrLf
Bulgu = Bulgu & "Windows Seri Numarasi" & VBA.Chr(9) & OS.SerialNumber & vbCrLf
Bulgu = Bulgu & "Windows Versiyonu ID" & VBA.Chr(9) & OS.Version & vbCrLf
Bulgu = Bulgu & "Windows Versiyonu" & VBA.Chr(9) & VBA.Chr(9) & OS.name & vbCrLf
Bulgu = Bulgu & "Güncelleme" & VBA.Chr(9) & VBA.Chr(9) & OS.CSDVersion & vbCrLf
Bulgu = Bulgu & VBA.Mid(VBA.Str(OS.name), 1, VBA.InStr(1, VBA.Str(OS.name), "") - 1) & vbCrLf
Bulgu = Bulgu & "Windows kurulum tarihi" & VBA.Chr(9) & VBA.left(OS.InstallDate, 4) & "/" & VBA.Mid(OS.InstallDate, 5, 2) & "/" & VBA.Mid(OS.InstallDate, 7, 2) & vbCrLf
Bulgu = Bulgu & String(157, "-") & vbCrLf
Next
'MsgBox "İŞLETİM SİSTEMİ BİLGİLERİ" & vbCrLf & VBA.String(130, "-") & vbCrLf & Bulgu & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Operating System (OS) Information"
TextBox1.Text = Bulgu
TextBox1.SetFocus
End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul