Üçüncü kod iyileştirme :
Ağ Ve İnternet Bileşenleri YOK, sadece sistem bilgileri :
Kod: Tümünü seç
Set objWMIService = GetObject("winmgmts:\\.\root\CIMV2") ' More user-friendly WMI connection
Set objNetwork = CreateObject("Wscript.Network")
Set wshShell = CreateObject("WScript.Shell")
strComputerName = wshShell.ExpandEnvironmentStrings("%COMPUTERNAME%")
Set oShell = WScript.CreateObject("WScript.Shell")
proc_arch = oShell.ExpandEnvironmentStrings("%PROCESSOR_ARCHITECTURE%")
Set oEnv = oShell.Environment("SYSTEM")
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\.\root\CIMV2")
Set colMB = objWMIService.ExecQuery("Select * from Win32_BaseBoard")
Set colProcessors = objWMIService.ExecQuery("Select * from Win32_Processor")
Set colDrives = objWMIService.ExecQuery("Select * from Win32_DiskDrive")
' Total RAM calculation
Set obj = objWMIService.ExecQuery("Select * from Win32_PhysicalMemory")
TotalRam = 0
ramDetails = ""
i = 1
For Each obj2 In obj
memTmp1 = obj2.capacity / 1024 / 1024
TotalRam = TotalRam + memTmp1
ramSpeed = obj2.Speed
ramType = ""
If ramSpeed >= 1600 And ramSpeed < 2133 Then
ramType = "DDR3"
ElseIf ramSpeed >= 2133 And ramSpeed < 2933 Then
ramType = "DDR4"
ElseIf ramSpeed >= 2933 Then
ramType = "DDR5"
Else
ramType = "Unknown"
End If
ramDetails = ramDetails & "Slot " & i & ": " & Int(memTmp1 / 1024) & " GB, Hız: " & obj2.Speed & " MHz, Tür: " & ramType & vbCrLf
i = i + 1
Next
' Processor architecture
Set colItems = objWMIService.ExecQuery("Select Architecture from Win32_Processor")
For Each objItem in colItems
If objItem.Architecture = 0 Then
strArchitecture = "x86"
ElseIf objItem.Architecture = 9 Then
strArchitecture = "x64"
End If
Next
' Graphics Card information
On Error Resume Next
Set colItemsx = objWMIService.ExecQuery("SELECT * FROM Win32_VideoController")
Dim tStr
tStr = ""
' Get display card information
For Each objItem in colItemsx
tStr = tStr & "Model : " & objItem.Description & vbCrLf
' Get memory size
Dim memSize
memSize = objItem.AdapterRAM / 1024 / 1024 ' in MB
' Check the memory size
If InStr(LCase(objItem.Description), "intel") > 0 Then
' If internal graphics, we can dynamically take the memory from system RAM
If memSize < 128 Then
memSize = 128 ' Default memory for integrated graphics is 128 MB
End If
Else
' For external graphics, check the AdapterRAM value
If memSize < 1024 Then
' If memory is less than 1 GB, probably an incorrect value is returned
memSize = 4096 ' Default memory for external graphics is 4096 MB (4 GB)
End If
End If
Next
On Error GoTo 0
' Operating system information
Set dtmInstallDate = CreateObject("WbemScripting.SWbemDateTime")
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colOperatingSystems
fthx = getmydat(objOperatingSystem.InstallDate)
Exit For
Next
Function getmydat(wmitime)
dtmInstallDate.Value = wmitime
getmydat = dtmInstallDate.GetVarDate
End Function
' Get disk information and check types
Dim diskInfo
diskInfo = "Disk Summary: " & vbCrLf
' If colDrives is not empty, proceed with processing
If colDrives.Count > 0 Then
For Each objDrive In colDrives
If Not objDrive Is Nothing Then
' Check if the disk is ready
On Error Resume Next ' Temporarily ignore errors
Dim driveType, diskSize
' Try to get disk size
diskSize = objDrive.Size
If Err.Number = 0 Then
' If size data is available
If objDrive.IsReady Then
driveType = GetDriveMediaType(objDrive)
diskInfo = diskInfo & objDrive.DeviceID & " - " & driveType & " - Capacity: " & _
FormatNumber(diskSize / 1024 / 1024 / 1024, 2) & " GB" & vbCrLf
Else
diskInfo = diskInfo & objDrive.DeviceID & " - " & "Disk is not ready" & vbCrLf
End If
Else
diskInfo = diskInfo & objDrive.DeviceID & " - " & "Disk size cannot be retrieved" & vbCrLf
End If
On Error GoTo 0 ' Reset error handling
End If
Next
Else
diskInfo = diskInfo & "Disk information not found." & vbCrLf
End If
' Function to determine the disk type (HDD/SSD/NVMe/USB)
Function GetDriveMediaType(DiskDrive)
On Error Resume Next
Dim mediaType
If Not DiskDrive Is Nothing Then
' Identify NVMe disks by model name
If InStr(1, LCase(DiskDrive.Model), "nvme") > 0 Or InStr(1, LCase(DiskDrive.Model), "nvm") > 0 Then
mediaType = "NVMe"
' Identify SSD disks by "ssd" or "sd" in the model name
ElseIf InStr(1, LCase(DiskDrive.Model), "ssd") > 0 Or InStr(1, LCase(DiskDrive.Model), "sd") > 0 Then
mediaType = "SSD"
' Identify USB disks by "usb" in the interface type
ElseIf InStr(1, LCase(DiskDrive.InterfaceType), "usb") > 0 Then
mediaType = "USB"
' Default to HDD for other disks
Else
mediaType = "HDD"
End If
Else
mediaType = "Unknown"
End If
On Error GoTo 0
GetDriveMediaType = mediaType
End Function
' Get the system collection
Set SystemSet = objWMIService.ExecQuery("SELECT * FROM Win32_OperatingSystem")
' Gather information (only one loop for system, processor, and motherboard)
For Each System in SystemSet
For Each objProcessor in colProcessors
For Each bbType In colMB
MbVendor = bbType.Manufacturer
MbModel = bbType.Product
tMessage = "Operating System : " & System.Caption & vbNewLine & _
"OS Version : " & System.Version & vbNewLine & _
"Windows Architecture : " & strArchitecture & vbNewLine & _
"Username : " & objNetwork.UserName & vbNewLine & _
"Computer Name : " & strComputerName & vbNewLine & _
"Last Format Date : " & fthx & vbNewLine & _
"--------------------------------------------------------------------------------------" & vbNewLine & _
"Motherboard Manufacturer : " & MbVendor & vbNewLine & _
"Motherboard Model : " & MbModel & vbNewLine & _
"Processor : " & objProcessor.Manufacturer & vbNewLine & _
"Processor Model : " & objProcessor.Name & vbNewLine & _
"CPU Architecture : " & strArchitecture & vbNewLine & _
"Total RAM : " & Int(TotalRam / 1024) & " GB" & vbNewLine & _
"RAM Slots : " & vbNewLine & ramDetails & vbNewLine & _
"Graphics Card(s) : " & vbNewLine & tStr & _
"--------------------------------------------------------------------------------------" & vbNewLine & _
diskInfo
Exit For ' Only run this loop once for each section
Next
Exit For
Next
Exit For
Next
' Display using WshShell.Popup
Set WshShell = CreateObject("WScript.Shell")
WshShell.Popup tMessage, 0, "Hardware Information | by Abdullah ERTÜRK", 4096
' Tarih formatını ayarlama
Dim currentDate
currentDate = Now
Dim formattedDate
formattedDate = Year(currentDate) & "_" & Right("0" & Month(currentDate), 2) & "_" & Right("0" & Day(currentDate), 2)
' Dosya yolunu belirleme (Masaüstü)
Dim desktopPath
desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Sistem Bilgileri_" & formattedDate & ".txt"
' Dosyayı oluşturma ve yazma
Dim fso, outputFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set outputFile = fso.CreateTextFile(desktopPath, True)
' Bilgileri dosyaya yazma
outputFile.WriteLine tMessage
outputFile.Close
' Kullanıcıya bilgi verme
WshShell.Popup "Sistem bilgileri " & desktopPath & " konumuna kaydedildi.", 0, "Bilgi", 64
yazmazsam ayıp olur 
