|
| | | |
 • III.3. API - System: dysk logiczny •
- 3.10 Jak pobrać listę dysków logicznych w systemie ?
- 3.11 Jak pobrać pojemności i ilość wolnego miejsca na dyskach logicznych ?
- 3.12 Jak pobrać system plików na dysku ?
- 3.13 Jak pobrać wielkość klastra dysku - system plików NTFS ?
- 3.14 Jak pobrać wielkość klastra dysku - system plików FAT ?
- 3.15 Jak pobrać nazwę użytkownika i nazwę domeny ?
- 3.16 Jak pobrać SID (Security Identifier) użytkownika ?
- 3.17 Jak pobrać nazwę i rozmiar papieru obsługiwanego przez drukarkę ?
- 3.18 Ciąg dalszy rozważań: Jak pobrać wielkość klastra dysku ?
- <<• idź do str. 1 •>>
| | | | |
 |
| | |
|
3.10 Jak pobrać listę dysków logicznych w systemie ?
' • Metoda I
Private Declare Function GetLogicalDriveStrings Lib "kernel32" _
Alias "GetLogicalDriveStringsA" _
(ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
' przy błędzie zwraca 0, przy powodzeniu ilość dysków logicznych, a w argumencie ByRef aDriversRet() tablicę nazw dysków logicznych
Private Function zbGetDriversName_1( _
aDriversRet() As String) As Long
Dim sDriversRet As String
Dim lRet As Long
Const MY_MAX_LENGHT As Long = 256
' przygotuj bufor
sDriversRet = String(MY_MAX_LENGHT, vbNullChar)
' pobierz oznaczenia dysków logicznych
lRet = GetLogicalDriveStrings(MY_MAX_LENGHT, sDriversRet)
If lRet > 0 Then
sDriversRet = Left$(sDriversRet, lRet - 1)
' rozdziel pobrane dane w/m znaku vbNullChar
aDriversRet() = Split(sDriversRet, vbNullChar)
zbGetDriversName_1 = UBound(aDriversRet) + 1
End If
End Function
' • Metoda II
' przy błędzie zwraca 0, przy powodzeniu ilość dysków logicznych, a w argumencie ByRef aDriversRet() tablicę nazw dysków logicznych
Private Function zbGetDriversName_2( _
aDriversRet() As String) As Long
Dim aDrv() As Byte
Dim lRet As Long
Dim lCount As Long
Dim i As Long
Const MY_DRIVERS_NAME As String = _
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
' przygotuj pomocniczą tabelę oznaczeń dysków
aDrv() = StrConv(MY_DRIVERS_NAME, vbFromUnicode)
' pobierz maskę bitową reprezentującą dostępne dyski
lRet = GetLogicalDrives
For i = 0 To Len(MY_DRIVERS_NAME) - 1
If (lRet And 2 ^ i) <> 0 Then
ReDim Preserve aDriversRet(0 To lCount)
aDriversRet(lCount) = Chr$(aDrv(i)) & ":\"
lCount = lCount + 1
End If
Next
zbGetDriversName_2 = lCount
End Function
' • Metoda III
' przy błędzie zwraca ciąg zerowej długości, przy powodzeniu ciąg znaków bedących
' literowymi oznaczeniami dostępnych dysków logicznych
Private Function zbAvailableDrives() As String
Dim lBitMask As Long
Dim i As Integer
Const ASCI_A As Long = 65 ' Asc("A")
lBitMask = GetLogicalDrives
For i = 0 To Asc("Z") - ASCI_A
If (lBitMask And 2 ^ i) <> 0 Then
zbAvailableDrives = zbAvailableDrives & Chr$(ASCI_A + i)
End If
Next
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim aDriversLog() As String
Dim aDriversRet() As Byte
Dim lRet As Long
Dim i As Long
' • Metoda I
lRet = zbGetDriversName_1(aDriversLog())
Debug.Print "zbGetDriversName_1"
For i = 0 To lRet - 1
Debug.Print aDriversLog(i); " ";
Next
' • Metoda II
Debug.Print
Debug.Print "zbGetDriversName_2"
lRet = zbGetDriversName_2(aDriversLog())
For i = 0 To lRet - 1
Debug.Print aDriversLog(i); " ";
Next
' • Metoda III
Debug.Print
Debug.Print "zbAvailableDrives"
aDriversRet = StrConv(zbAvailableDrives, vbFromUnicode)
For i = LBound(aDriversRet) To UBound(aDriversRet)
Debug.Print Chr$(aDriversRet(i)) & ":\ ";
Next
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.11 Jak pobrać pojemności i ilość wolnego miejsca na dyskach logicznych ?
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" _
Alias "GetDiskFreeSpaceExA" _
(ByVal lpRootPathName As String, _
lpFreeBytesAvailableToCaller As Currency, _
lpTotalNumberOfBytes As Currency, _
lpTotalNumberOfFreeBytes As Currency) As Long
' przy powodzeniu zwraca wartość różną od ZERA, a w argumentach ByRef zwraca wartości określonych argumentów, przy niepowodzeniu zwraca ZERO
Private Function zbGetDiskSpace(sDirName As String, _
Optional curAvailableBytesRet As Currency, _
Optional curTotalBytesRet As Currency, _
Optional curTotalFreeBytesRet As Currency) As Long
Dim lRet As Long
' pobierz dane o pojemności dysku
lRet = GetDiskFreeSpaceEx(sDirName, _
curAvailableBytesRet, _
curTotalBytesRet, _
curTotalFreeBytesRet)
If lRet > 0 Then
curAvailableBytesRet = curAvailableBytesRet * 10000
curTotalBytesRet = curTotalBytesRet * 10000
curTotalFreeBytesRet = curTotalFreeBytesRet * 10000
End If
zbGetDiskSpace = lRet
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim curAvailableBytes As Currency
Dim curTotalBytes As Currency
Dim curTotalFreeBytes As Currency
Dim aDriversLog() As String
Dim lCount As Long
Dim lRet As Long
Dim i As Long
Const MY_FORMAT As String = "###,###,###,##0"
lCount = zbGetDriversName_1(aDriversLog())
For i = 0 To lCount - 1
lRet = zbGetDiskSpace(aDriversLog(i), curAvailableBytes, _
curTotalBytes, curTotalFreeBytes)
If lRet = 0 Then
Debug.Print "Dysk: "; aDriversLog(i); " jest niedostępny"
Else
Debug.Print "Dysk: "; aDriversLog(i)
Debug.Print "Pojemność:", , Format$(curTotalBytes, _
MY_FORMAT); " bajtów"
Debug.Print "Zajęte miejsce :", _
Format$((curTotalBytes - curTotalFreeBytes), _
MY_FORMAT); " bajtów"
Debug.Print "Wolne miejsce:", _
Format$(curTotalFreeBytes, _
MY_FORMAT); " bajtów"
Debug.Print "Dostępne miejsce:", _
Format$(curAvailableBytes, _
MY_FORMAT); " bajtów"
End If
Debug.Print String(55, "=")
Next
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.12 Jak pobrać system plików na dysku ?
Private Declare Function GetVolumeInformation Lib "kernel32" _
Alias "GetVolumeInformationA" _
(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, _
lpVolumelNoSerNumber As Long, _
lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
' zwraca nazwę systemu plików dysku sDriveName (FAT lub NTFS) przy błędzie zwraca ciąg zerowej długości
Public Function zbFileSystemName(sDriveName As String) As String
Dim sBff As String * 255
Dim sDrive As String * 1
sDrive = sDriveName
' sprawdź, czy oznaczenie dysku jest na liście dostępnych dysków
If InStr(1, zbAvailableDrives, sDrive, vbTextCompare) = 0 Then
Call GetVolumeInformation(sDrive & ":\", "", Len(sBff), _
0&, 0&, 0&, sBff, Len(sBff))
zbFileSystemName = Left$(sBff, _
InStr(sBff, vbNullChar) - 1)
End If
End Function
ΔΔΔ | | | | |
|
|
| | |
|
3.13 Jak pobrać wielkość klastra dysku - system plików NTFS ?
' -------------------------------------------------------------------------
' Per semplicita' il codice e' tutto in un modulo .bas
' e, una volta lanciato, mostra una messagebox
' con il valore cercato.
' -------------------------------------------------------------------------
Private Const GENERIC_READ = &H80000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const INVALID_HANDLE_VALUE = -1
'// File System Control command for getting NTFS information
Private Const FSCTL_GET_VOLUME_INFORMATION = &H90064
Private Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
'<BraZby w celu zgodności z Acc'97>
#If False Then
'// Io Status block (see NTDDK.H)
Private Enum NTSTATUS
STATUS_SUCCESS = &H0&
STATUS_BUFFER_OVERFLOW = &H80000005
STATUS_INVALID_PARAMETER = &HC000000D
STATUS_BUFFER_TOO_SMALL = &HC0000023
STATUS_ALREADY_COMMITTED = &HC0000021
STATUS_INVALID_DEVICE_REQUEST = &HC0000010
End Enum
#End If
Private Const STATUS_SUCCESS = &H0&
Private Const STATUS_BUFFER_OVERFLOW = &H80000005
Private Const STATUS_INVALID_PARAMETER = &HC000000D
Private Const STATUS_BUFFER_TOO_SMALL = &HC0000023
Private Const STATUS_ALREADY_COMMITTED = &HC0000021
Private Const STATUS_INVALID_DEVICE_REQUEST = &HC0000010
'</BraZby>
Private Type IO_STATUS_BLOCK
'</BraZby>
'status As NTSTATUS
status As Long
'</BraZby>
Information As Long
End Type
'// NTFS volume information
Private Type NTFS_VOLUME_DATA_BUFFER
SerialNumber As LARGE_INTEGER
NumberOfSectors As LARGE_INTEGER
TotalClusters As LARGE_INTEGER
FreeClusters As LARGE_INTEGER
Reserved As LARGE_INTEGER
BytesPerSector As Long
BytesPerCluster As Long
BytesPerMFTRecord As Long
ClustersPerMFTRecord As Long
MFTLength As LARGE_INTEGER
MFTStart As LARGE_INTEGER
MFTMirrorStart As LARGE_INTEGER
MFTZoneStart As LARGE_INTEGER
MFTZoneEnd As LARGE_INTEGER
End Type
' --------- API Win32
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Sub memcpy Lib "kernel32" _
Alias "RtlMoveMemory" _
(ByRef dst As Any, _
ByRef src As Any, _
ByVal size As Long)
Private Declare Function CreateFile Lib "kernel32" _
Alias "CreateFileA" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
' ------------ API NT
Private Declare Function NtFsControlFile Lib "ntdll" _
(ByVal FileHandle As Long, _
ByVal hEvent As Long, _
ByRef UserApcRoutine As Any, _
ByRef UserApcContext As Any, _
ByRef UserIoStatus As IO_STATUS_BLOCK, _
ByVal FsControlCode As Long, _
ByRef InputBuffer As Any, _
ByVal InputBufferLength As Long, _
ByRef OutputBuffer As Any, _
ByVal OutputBufferLength As Long) As Long
Private Function GetNTFSInfo( _
ByVal DriveLetter As String, _
ByRef VolumeInfo As _
NTFS_VOLUME_DATA_BUFFER) As Boolean
Dim volumeName As String: volumeName = "\\.\A:"
Dim volumeHandle As Long
Dim ioStatus As IO_STATUS_BLOCK
'<BraZby>
Dim status As Long
'Dim status As NTSTATUS
'</BraZby>
'// open the volume
Mid(volumeName, 5, 1) = DriveLetter
volumeHandle = CreateFile(volumeName, GENERIC_READ, _
FILE_SHARE_READ Or FILE_SHARE_WRITE, _
ByVal 0&, OPEN_EXISTING, ByVal 0&, ByVal 0&)
If (volumeHandle = INVALID_HANDLE_VALUE) Then
Exit Function
End If
'// Query the volume information
status = NtFsControlFile(volumeHandle, _
ByVal 0&, ByVal 0&, ByVal 0&, ioStatus, _
FSCTL_GET_VOLUME_INFORMATION, _
ByVal 0&, 0, VolumeInfo, Len(VolumeInfo))
GetNTFSInfo = (status = STATUS_SUCCESS)
'// Close the volume
CloseHandle volumeHandle
End Function '// GetNTFSInfo
Public Function GetNTFSClusterSize( _
ByVal a_DriveLetter As String) As Long
Dim VolumeInfo As NTFS_VOLUME_DATA_BUFFER
If (GetNTFSInfo(a_DriveLetter, VolumeInfo)) Then
GetNTFSClusterSize = VolumeInfo.BytesPerCluster
End If
End Function '// GetNTFSClusterSize
ΔΔΔ | | | | |
|
|
| | |
|
3.14 Jak pobrać wielkość klastra dysku - system plików FAT ?
grupa: it.comp.lang.visual-basic
wątek: Cluster size
autor: hal1961
' --------- costanti
Private Const FILE_FLAG_DELETE_ON_CLOSE = &H4000000
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VWIN32_DIOC_DOS_DRIVEINFO = 6
' --------- strutture
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' Maintenance string for PSS usage
End Type
'// holds the register values before and after the call to get the cluster size
Private Type tagDIOC_REGISTERS
reg_EBX As Long
reg_EDX As Long
reg_ECX As Long
reg_EAX As Long
reg_EDI As Long
reg_ESI As Long
reg_Flags As Long
End Type
'// the structure returned by VWIN32_DIOC_DOS_DRIVEINFO
Private Type tagExtGetDskFreSpcStruc
ExtFree_Size As Long
ExtFree_Level As Long
ExtFree_SectorsPerCluster As Long
ExtFree_BytesPerSector As Long
ExtFree_AvailableClusters As Long
ExtFree_TotalClusters As Long
ExtFree_AvailablePhysSectors As Long
ExtFree_TotalPhysSectors As Long
ExtFree_AvailableAllocationUnits As Long
ExtFree_TotalAllocationUnits As Long
ExtFree_Rsvd(0 To 1) As Long
End Type
' --------- funzioni API Win32
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Sub memcpy Lib "kernel32" _
Alias "RtlMoveMemory" _
(ByRef dst As Any, _
ByRef src As Any, _
ByVal size As Long)
Private Declare Function CreateFile Lib "kernel32" _
Alias "CreateFileA" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByRef lpSecurityAttributes As Any, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" _
(ByVal hDevice As Long, _
ByVal dwIoControlCode As Long, _
ByRef lpInBuffer As Any, _
ByVal nInBufferSize As Long, _
ByRef lpOutBuffer As Any, _
ByVal nOutBufferSize As Long, _
ByRef lpBytesReturned As Long, _
ByRef lpOverlapped As Any) As Long
Private Declare Function GetDiskFreeSpace Lib "kernel32" _
Alias "GetDiskFreeSpaceA" _
(ByVal lpRootPathName As String, _
ByRef lpSectorsPerCluster As Long, _
ByRef lpBytesPerSector As Long, _
ByRef lpNumberOfFreeClusters As Long, _
ByRef lpTotalNumberOfClusters As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(ByRef lpVersionInformation As _
OSVERSIONINFO) As Long
' ---------- variabili interne
Private m_strDrive As String
Private Function LoWord(DWord As Long) As Integer
If DWord And &H8000& Then ' &H8000& = &H00008000
LoWord = DWord Or &HFFFF0000
Else
LoWord = DWord And &HFFFF&
End If
End Function '// LoWord
'/////////////////////////////////////////////////////////////////////////////
'// SetDrive
'// --------
'// Sets the current drive to strDrive. strDrive should be in the form of
'// C:\ for the class to get the cluster size on drive C. In order to get the
'// cluster size of the drive, you should either pass the drive to the constructor
'// or call this function before calling GetClusterSize().
'//
'// Returns: true if the string is a valid path format (does not check to see
'// if the drive is valid), otherwise false.
'/////////////////////////////////////////////////////////////////////////////
Public Function SetDrive(ByVal strDrive As String) As Boolean
If (Len(strDrive) <> 3) Then Exit Function
If (False = (Mid$(strDrive, 1, 1) Like "[A-Z]")) Then Exit Function
If (Mid$(strDrive, 2, 1) <> ":") Then Exit Function
If (Mid$(strDrive, 3, 1) <> "\") Then Exit Function
m_strDrive = strDrive
SetDrive = True
End Function '// SetDrive
'/////////////////////////////////////////////////////////////////////////////
'// GetClusterSize
'// --------------
'// Determines the cluster size for the current drive, which is set either using
'// SetDrive or the second constructor. It uses the DeviceIoControl to set and
'// poll the registers to execute Int 21h Function 7303h which is only valid
'// if the system is running OSR2 or greater.
'/////////////////////////////////////////////////////////////////////////////
Public Function GetClusterSize() As Long
If (Len(m_strDrive) = 0) Then Exit Function
Dim OSR2 As Boolean '//Running OSR2 or not
Dim os As OSVERSIONINFO
Dim SectorsPerCluster As Long
Dim BytesPerSector As Long
'// determine the OS version
os.dwOSVersionInfoSize = Len(os)
GetVersionEx os
If (os.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS) Then
'// is it OSR2 or newer?
If (LoWord(os.dwBuildNumber) > 1000) Then
OSR2 = True
End If
End If
'//If it's not OSR2, this is easy
If (Not OSR2) Then
GetDiskFreeSpace m_strDrive, SectorsPerCluster, _
BytesPerSector, ByVal 0&, ByVal 0&
GetClusterSize = SectorsPerCluster * BytesPerSector
Exit Function
End If
'// otherwise, use the int 21h function
Dim hDevice As Long
Dim reg As tagDIOC_REGISTERS
Dim spcstruc As tagExtGetDskFreSpcStruc
Dim bResult As Long
Dim cb As Long
Dim sz(0 To 3) As Byte ', strAscii As String * 4
'strAscii = StrConv(m_strDrive, vbFromUnicode) & vbNullChar
'sz() = strAscii
memcpy sz(0), ByVal m_strDrive, UBound(sz()) + 1
spcstruc.ExtFree_Level = 0 '//Must initialize before using the structure
hDevice = CreateFile("\\\\.\\vwin32", 0&, 0&, ByVal 0&, 0&, FILE_FLAG_DELETE_ON_CLOSE, 0&)
'// initialize the registers to call the correct function
reg.reg_EDI = VarPtr(spcstruc)
reg.reg_ECX = Len(spcstruc)
reg.reg_EDX = StrPtr(m_strDrive)
reg.reg_EAX = &H7303
reg.reg_Flags = &H1
'// copies the structure into the registers, performs the function,
'// and returns the new registers in the structure
bResult = DeviceIoControl(hDevice, VWIN32_DIOC_DOS_DRIVEINFO, _
reg, Len(reg), reg, Len(reg), cb, ByVal 0&)
CloseHandle hDevice
'// check the error status
If ((False = bResult) Or (reg.reg_Flags & &H1)) Then
Exit Function
End If
GetClusterSize = spcstruc.ExtFree_SectorsPerCluster * _
spcstruc.ExtFree_BytesPerSector
End Function '// GetClusterSize
' przykładowe wywołanie:
Public Sub Main()
' Dim cs As CClusterSize
' Set cs = New CClusterSize
If SetDrive("C:\") Then
MsgBox "The cluster size of the disk C: is " & _
CStr(GetClusterSize()), vbInformation
End If
' Set cs = Nothing
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.15 Jak pobrać nazwę użytkownika i nazwę domeny ?
' • Metoda I
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" _
(ByVal ProcessHandle As Long, _
ByVal DesiredAccess As Long, _
TokenHandle As Long) As Long
Private Declare Function GetTokenInformation Lib "advapi32.dll" _
(ByVal TokenHandle As Long, _
ByVal TokenInformationClass As Integer, _
TokenInformation As Any, _
ByVal TokenInformationLength As Long, _
ReturnLength As Long) As Long
Private Declare Function LookupAccountSid Lib "advapi32.dll" _
Alias "LookupAccountSidA" _
(ByVal lpSystemName As String, _
ByVal Sid As Long, _
ByVal Name As String, cbName As Long, _
ByVal ReferencedDomainName As String, _
cbReferencedDomainName As Long, _
peUse As Long) As Long
Const TOKEN_QUERY = 8&
Const TOKEN_USER = 1&
Const MY_MAX_LEN As Long = 260
Const MY_NEED_SIZE As Long = 512
Private Type SID_AND_ATTRIBUTES
Sid As Long
Attributes As Long
Need As String * MY_NEED_SIZE
End Type
' przy powodzeniu zwraca TRUE, a w argumentach ByRef nazwę użytkownika i nazwę domeny, przy niepowodzeniu zwraca FALSE
Public Function zbGetUserAndDomainAPI(sUserRet As String, _
sDomainRet As String) As Boolean
Dim hProcess As Long
Dim hToken As Long
Dim SA As SID_AND_ATTRIBUTES
Dim lRetLength As Long
Dim lUserLen As Long
Dim lDomainLen As Long
Dim lpSID As Long
hProcess = GetCurrentProcess()
If OpenProcessToken(hProcess, _
TOKEN_QUERY, hToken) = 0 Then
Exit Function
End If
Call GetTokenInformation(hToken, _
TOKEN_USER, 0&, 0&, lRetLength)
If GetTokenInformation(hToken, TOKEN_USER, _
SA, lRetLength, lRetLength) = 0 Then
Exit Function
End If
lUserLen = MY_MAX_LEN
lDomainLen = MY_MAX_LEN
sUserRet = String$(lUserLen, vbNullChar)
sDomainRet = String$(lDomainLen, vbNullChar)
If LookupAccountSid(vbNullString, SA.Sid, sUserRet, lUserLen, _
sDomainRet, lDomainLen, lpSID) = 0 Then
Exit Function
End If
sUserRet = Left$(sUserRet, lUserLen)
sDomainRet = Left$(sDomainRet, lDomainLen)
zbGetUserAndDomainAPI = True
End Function
' • Metoda II
' przy powodzeniu zwraca TRUE, a w argumentach ByRef nazwę użytkownika i nazwę domeny, przy niepowodzeniu zwraca FALSE
Public Function zbGetUserAndDomainWSH( _
sUserRet As String, _
sDomainRet As String) As Boolean
On Error GoTo ErrHandler
Dim oWshNet As Object
Set oWshNet = CreateObject("WScript.Network")
sUserRet = oWshNet.UserName
sDomainRet = oWshNet.UserDomain
Set oWshNet = Nothing
zbGetUserAndDomainWSH = True
ExitHere:
Exit Function
ErrHandler:
MsgBox "Błąd nr: " & Err.Number & vbNewLine & Err.Description
Resume ExitHere
End Function
' • Metoda III
' przy powodzeniu zwraca TRUE, a w argumentach ByRef nazwę użytkownika i nazwę domeny, przy niepowodzeniu zwraca FALSE
Public Function zbGetUserAndDomainENV( _
sUserRet As String, _
sDomainRet As String) As Boolean
On Error GoTo ErrHandler
sUserRet = Environ$("USERNAME")
If Len(sUserRet) = 0 Then Exit Function
sDomainRet = Environ$("USERDOMAIN")
If Len(sDomainRet) = 0 Then Exit Function
zbGetUserAndDomainENV = True
ExitHere:
Exit Function
ErrHandler:
MsgBox "Błąd nr: " & Err.Number & vbNewLine & Err.Description
Resume ExitHere
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sUser As String
Dim sDomain As String
If zbGetUserAndDomainAPI(sUser, sDomain) = True Then
Debug.Print "API: "; sUser & " | " & sDomain
End If
sUser = "": sDomain = ""
If zbGetUserAndDomainWSH(sUser, sDomain) = True Then
Debug.Print "WSH: "; sUser & " | " & sDomain
End If
sUser = "": sDomain = ""
If zbGetUserAndDomainENV(sUser, sDomain) = True Then
Debug.Print "ENV: "; sUser & " | " & sDomain
End If
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.16 Jak pobrać SID (Security Identifier) użytkownika ?
' zwraca Identyfikator zabezpieczeń SID (Security Identifier)
Public Function GetUserSID() As String
Dim oWshNet As Object
Dim oUserAccount As Object
Set oWshNet = CreateObject("WScript.Network")
On Error Resume Next
Set oUserAccount = GetObject("winmgmts://" & _
oWshNet.UserDomain & _
"/root/cimv2").Get( _
"Win32_UserAccount.Domain='" & _
oWshNet.ComputerName & "'" & _
",Name='" & _
oWshNet.UserName & "'")
If Err.Number = 0 Then
GetUserSID = oUserAccount.Sid
End If
Set oUserAccount = Nothing
On Error GoTo 0
Set oWshNet = Nothing
End Function
ΔΔΔ | | | | |
|
|
| | |
|
3.17 Jak pobrać nazwę i rozmiar papieru obsługiwanego przez drukarkę ?
Private Declare Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" _
(ByVal lpDeviceName As String, _
ByVal lpPort As String, _
ByVal iIndex As Long, _
lpOutput As Any, _
lpDevMode As Any) As Long
Private Type POINT
x As Long
y As Long
End Type
Private Const DC_PAPERS = 2
Private Const DC_PAPERSIZE = 3
Private Const DC_PAPERNAMES = 16
Public Sub zbGetPaper(sPrinterName As String)
On Error GoTo ErrHandler
Dim sPapers As String
Dim sPaperName As String
Dim ptPaperSize() As POINT
Dim iPaperNo() As Integer
Dim lRet As Long
Dim i As Integer
lRet = DeviceCapabilities(sPrinterName, vbNullString, _
DC_PAPERSIZE, ByVal 0&, ByVal 0&)
If lRet < 0 Then
Debug.Print "Błąd odczytu"
Else
ReDim ptPaperSize(lRet - 1)
ReDim iPaperNo(lRet - 1)
sPapers = Space$(lRet * 64)
lRet = DeviceCapabilities(sPrinterName, vbNullString, _
DC_PAPERSIZE, _
ByVal VarPtr(ptPaperSize(0)), ByVal 0&)
lRet = DeviceCapabilities(sPrinterName, vbNullString, _
DC_PAPERS, _
ByVal VarPtr(iPaperNo(0)), ByVal 0&)
lRet = DeviceCapabilities(sPrinterName, vbNullString, _
DC_PAPERNAMES, _
ByVal sPapers, ByVal 0&)
For i = 0 To lRet - 1
sPaperName = (Mid$(sPapers, ((i) * 64 + 1), 64))
sPaperName = _
Trim$(Left$(sPaperName, _
InStr(1, sPaperName, vbNullChar) - 1))
On Error Resume Next
Debug.Print i & ". " & sPaperName & "," & _
" H =" & ((ptPaperSize(i).y) / 100) & "cm" & _
" W = " & ((ptPaperSize(i).x) / 100) & "cm"
Next
End If
DoCmd.RunCommand acCmdDebugWindow
ExitHere:
Exit Sub
ErrHandler:
MsgBox "Błąd nr: " & Err.Number & vbNewLine & Err.Description
Resume ExitHere
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.18 Ciąg dalszy rozważań: Jak pobrać wielkość wielkość klastra ?
' W przykładach: Jak pobrać wielkość klastra dysku - system plików NTFS ? oraz Jak pobrać wielkość klastra dysku - system plików FAT ? przedstawiłem znalezione w sieci sposoby jak pobrać wielkości klastrów w obu systemach plików.
' Niestety, nie zawsze te przykłady działały w sposób zadowalajacy. Poniżej przedstawiam trzy prostsze metody pobranie wielkości klastra, ale równie zawodne jak dwie poprzednie.
' I dalej nie wiem jak na 100% pobrać wielkość klastra dysku !
' • Metoda I
grupa: microsoft.public.scripting.wsh
wątek: Allocation Units
przedstawił: McKirahan
' z drobnymi kosmetycznymi zmianami z mojej strony
Function AllocationUnitSize(ByVal DRV As String)
Dim objFSO
Dim objGDR
Dim strCTF
Dim objCTF
Dim intSIZ
Set objFSO = CreateObject("Scripting.FileSystemObject")
DRV = Left$(DRV, 1) & ":\"
Set objGDR = objFSO.GetDrive(DRV)
strCTF = DRV & objFSO.GetTempName()
Set objCTF = objFSO.CreateTextFile(strCTF)
intSIZ = objGDR.AvailableSpace
objCTF.WriteLine ""
intSIZ = intSIZ - objGDR.AvailableSpace
Set objCTF = Nothing
objFSO.DeleteFile (strCTF)
Set objFSO = Nothing
Set objGDR = Nothing
AllocationUnitSize = intSIZ
End Function
' • Metoda II
' metoda polega na pobraniu wolnego miejsca na dysku sDrive i utworzeniu na tym dysku małego pliku tymczasowego i ponownym pobraniu wolnego miejsca na dysku, różnica ilości wolnego miejsca powinna nam dać wielkość klastar.
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" _
Alias "GetDiskFreeSpaceExA" _
(ByVal lpRootPathName As String, _
lpFreeBytesAvailableToCaller As Currency, _
lpTotalNumberOfBytes As Currency, _
lpTotalNumberOfFreeBytes As Currency) As Long
Public Function zbClusterSize(ByVal sDrive As String) As Long
Dim curAvailableBytes As Currency
Dim curAvailableBytes2 As Currency
Dim sTmpFilePath As String
Dim sSysDrive As String
Dim lRet As Long
Dim ff As Integer
Const MY_TMP_FILE As String = "~tmp.tmp"
sDrive = Left$(sDrive, 1)
' na dysku systemowym zapisz plik w folderze plików tymczasowych
' bo możesz nie mieć uprawnień do zapisu na dysku systemowym
sSysDrive = Environ$("SYSTEMROOT")
If Len(sSysDrive) = 0 Then sSysDrive = Environ$("WINDIR")
sSysDrive = Left$(sSysDrive, 1)
If UCase(sSysDrive) = UCase(sDrive) Then
sTmpFilePath = Environ$("TEMP") & "\" & MY_TMP_FILE
Else
sTmpFilePath = sDrive & ":\" & MY_TMP_FILE
End If
If Len(sSysDrive) = 0 Then Exit Function
sDrive = sDrive & ":\"
' pobierz dane o ilości dostępnych bajtów przed zapisem pliku
lRet = GetDiskFreeSpaceEx(sDrive, curAvailableBytes, 0&, 0&)
ff = FreeFile
' zapisz 3 bajty w pliku
Open sTmpFilePath For Binary Access Write As #ff
Put #ff, , sDrive
Close #ff
' pobierz dane o ilości dostępnych bajtów po zapisaniu pliku
lRet = GetDiskFreeSpaceEx(sDrive, curAvailableBytes2, 0&, 0&)
' usuń plik tymczasowy
If Len(Dir(sTmpFilePath)) > 0 Then Kill sTmpFilePath
zbClusterSize = (curAvailableBytes - curAvailableBytes2) * 10000
End Function
' • Metoda III
grupa: microsoft.public.vb.general.discussion
wątek: Bytes per Sector
przedstawił: Mike Williams
Private 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
' z drobnymi kosmetycznymi zmianami z mojej strony
Public Function GetClusterSize(disk As String)
Dim sectorsPerCluster As Long
Dim bytesPerSector As Long
Dim free As Long
Dim total As Long
Dim retVal As Long
Dim bytesPerCluster As Long
retVal = GetDiskFreeSpace _
(disk, sectorsPerCluster, bytesPerSector, free, total)
bytesPerCluster = sectorsPerCluster * bytesPerSector
GetClusterSize = CCur(bytesPerCluster)
End Function
ΔΔΔ | | | | |
|
| |
