Sistem hakkında bilgi toplamak

 
'Projeye eklenmesi gerekenler
' Drive List Box (DriveNAME)
' Dir List Box (dirNAME)
' File List Box (fileFILENAMES)
' 8 label:
' lbDVNAME, lbLBNAME, lbDVTYPE, lbTDSKSPC, lbDSKFRSPC, lbCRNTDR, lbWINDR,
' lbPRGCRNTDR
' 1 modül

Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

'formun adını frmDRIVES olarak düzenleyin

Private Sub dirNAME_Change()
fileFILENAMES.Path = dirNAME.Path
End Sub

Private Sub DriveNAME_Change()
On Error GoTo FindError
dirNAME.Path = DriveNAME.Drive
Call DisplayDriveNAME
Call DisplaydriveLABEL
Call DisplayDriveTYPE
Call DisplayTotalDiskSPACE
Call DisplayDiskFreeSPACE
Call DisplayWindowDIRECTORY
Call DisplayCurrentDIR
Call DisplayProgramCurrentDIR
Exit Sub
FindError:
MsgBox Err.Description, vbOKOnly + vbCritical, "Error Found"
Call DisplayDriveNAME
Call DisplaydriveLABEL
Call DisplayDriveTYPE
Call DisplayTotalDiskSPACE
Call DisplayDiskFreeSPACE
Call DisplayWindowDIRECTORY
Call DisplayCurrentDIR
Call DisplayProgramCurrentDIR
End Sub

Private Sub FileNAME_Click()
lbFLNAME.Caption = UCase(Left(FileName.FileName, (InStr(1, FileName.FileName, "."))))
lbFLEXT.Caption = UCase(Right(FileName.FileName, 3))
Call DisplayCurrentDirectory
End Sub


Private Sub Form_Load()
frmDRIVES.Height = 5220
frmDRIVES.Width = 7665
frmDRIVES.Left = 2325
frmDRIVES.Caption = "works on drives by Created By Ali Farooq"
Call DisplayDriveNAME
Call DisplaydriveLABEL
Call DisplayDriveTYPE
Call DisplayTotalDiskSPACE
Call DisplayDiskFreeSPACE
Call DisplayWindowDIRECTORY
Call DisplayCurrentDIR
Call DisplayProgramCurrentDIR
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If ((frmDRIVES.Height > 5220) Or (frmDRIVES.Width > 7665)) Then
frmDRIVES.Height = 5220
frmDRIVES.Width = 7665
frmDRIVES.Left = 2325
ElseIf ((frmDRIVES.Height < 5220) Or (frmDRIVES.Width < 7665)) Then
frmDRIVES.Height = 5220
frmDRIVES.Width = 7665
frmDRIVES.Left = 2325
End If
End Sub

Sub DisplayDriveNAME()
lbDVNAME.Caption = UCase(Left(DriveNAME.Drive, 2))
End Sub

Sub DisplaydriveLABEL()
lbLBNAME.Caption = Mid(DriveNAME.Drive, 4, 13)
If lbLBNAME.Caption = "" Then
lbLBNAME.Caption = "No Label Defined"
End If
End Sub

Sub DisplayDriveTYPE()
Dim Dname, GDT As String
Dname = Left(DriveNAME.Drive, 2) & "\"
GDT = GetDriveType(Dname)
If GDT = 0 Then
lbDVTYPE.Caption = "Unable To Determine The Drive Type"
ElseIf GDT = 1 Then
lbDVTYPE.Caption = "There is no root Directory"
ElseIf GDT = 2 Then 'DRIVE_REMOVABLE
lbDVTYPE.Caption = "Removable Disk(Like Floppy, Flash Disk)"
ElseIf GDT = 3 Then 'DRIVE_FIXED
lbDVTYPE.Caption = "Fixed Drive (Like C:, D:, E: etc)"
ElseIf GDT = 4 Then 'DRIVE_REMOTE
lbDVTYPE.Caption = "Drive Remote (NetWork Drive)"
ElseIf GDT = 5 Then 'DRIVE_CDROM
lbDVTYPE.Caption = "CDROM Drive"
ElseIf GDT = 6 Then 'DRIVE_RAMDISK
lbDVTYPE.Caption = "Drive is a RAM drive"
End If
End Sub

Sub DisplayTotalDiskSPACE()
On Error Resume Next
Dim Dname As String
Dim GTDFS As Long
Dim Sectors As Long, Bytes As Long, FreeClusters As Long, TotalClusters As Long
Dname = Left(DriveNAME.Drive, 2) & "\"
GTDFS = GetDiskFreeSpace(Dname, Sectors, Bytes, FreeClusters, TotalClusters)
lbTDSKSPC.Caption = Sectors * Bytes * TotalClusters
End Sub

Sub DisplayDiskFreeSPACE()
On Error Resume Next
Dim Dname As String
Dim GDFS As Long
Dim Sectors As Long, Bytes As Long, FreeClusters As Long, TotalClusters As Long
Dname = Left(DriveNAME.Drive, 2) & "\"
GDFS = GetDiskFreeSpace(Dname, Sectors, Bytes, FreeClusters, TotalClusters)
lbDSKFRSPC.Caption = Sectors * Bytes * FreeClusters
End Sub

Sub DisplayWindowDIRECTORY()
Dim Dname, GWD As String
Dim Buffers As String * 255
Dname = Left(DriveNAME.Drive, 2) & "\"
GWD = GetWindowsDirectory(Buffers, 255)
lbWINDR.Caption = Buffers
End Sub

Sub DisplayCurrentDIR()
lbCRNTDR.Caption = Left(UCase(DriveNAME.Drive), 2) + "\"
End Sub

Sub DisplayProgramCurrentDIR()
lbPRGCRNTDR.Caption = App.Path
End Sub

Sub DisplayCurrentDirectory()
lbCRNTDR.Caption = dirNAME.Path + "\" + FileName.FileName
End Sub

Yorum Yapabilmek İçin Üye Girişi Yapmanız Gerekmektedir.

sistem hakkında bilgi toplamak