|
| | | |
 • III.3. API - System: niektóre dane •
- 3.1 Jak pobrać zmienne środowiskowe ?
- 3.2 Jak pobrać ścieżki folderów systemowych ?
- 3.3 Jak pobrać numer seryjny dysku, jego etykietę i system plików ?
- 3.4 Jak pobrać listę zainstalowanych drukarek ?
- 3.5 Jak synchroniczne sformatować dyskietkę ?
- 3.6 Jak pobrać niektóre kolory systemowe Windows ?
- 3.7 Jak zmienić wskaźnik myszy na inny systemowy wskaźnik ?
- 3.8 Jak załadować wskaźnik myszy z zasobów np. C:\Windows\Cursors ?
- 3.9 Jak sprawdzić wersję systemu operacyjnego ?
- <<• idź do str. 2 •>>
| | | | |
 |
| | |
|
3.1 Jak pobrać zmienne środowiskowe ?
Aby pobrać zmienne środowiskowe skorzystamy z funkcji Environ, która zwraca wartość typu String odpowiadającą wartości zmiennej otoczenia systemu operacyjnego (zmiennej środowiskowej).
' przykładowe wywołanie
Private Sub Test_Click()
Dim sEnvVariableName As String
Dim i As Long
Debug.Print UCase("Zmienne środowiskowe:")
Debug.Print String(100, "_")
' pobierz i drukuj kolejne zmienne środowiskowe
Do
i = i + 1
sEnvVariableName = Environ$(i)
If Len(sEnvVariableName) = 0 Then Exit Do
Debug.Print i & ". "; sEnvVariableName
Loop
Debug.Print String(100, "=")
Debug.Print: Debug.Print
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.2 Jak pobrać ścieżki folderów systemowych ?
Private Declare Function SHGetFolderPath Lib "shfolder.dll" _
Alias "SHGetFolderPathA" _
(ByVal hWndOwner As Long, _
ByVal nFolder As Long, _
ByVal hToken As Long, _
ByVal dwReserved As Long, _
ByVal lpszPath As String) As Long
Private Const SHGFP_TYPE_CURRENT = &H0
Private Const SHGFP_TYPE_DEFAULT = &H1
Private Const MY_MAX_PATH As Long = 512
' zwraca ścieżkę folderu systemowego, przy błędzie zwraca ciąg zerowej długości,
Private Function zbGetSysFolderPath(lCSIDL As Long) As String
Dim sPath As String
Dim lRet As Long
sPath = String(MY_MAX_PATH, vbNullChar)
lRet = SHGetFolderPath(0&, lCSIDL, 0&, _
SHGFP_TYPE_CURRENT, sPath)
If lRet = 0 Then
zbGetSysFolderPath = _
Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim aCSIDLName(1 To 57) As String
Dim aCSIDLValue(1 To 57) As Long
Dim sRet As String
Dim sTmp As String * 30
Dim i As Long
| aCSIDLName(1) = "CSIDL_DESKTOP": | aCSIDLValue(1) = &H0 |
| aCSIDLName(2) = "CSIDL_INTERNET": | aCSIDLValue(2) = &H1 |
| aCSIDLName(3) = "CSIDL_PROGRAMS": | aCSIDLValue(3) = &H2 |
| aCSIDLName(4) = "CSIDL_CONTROLS": | aCSIDLValue(4) = &H3 |
| aCSIDLName(5) = "CSIDL_PRINTERS": | aCSIDLValue(5) = &H4 |
| aCSIDLName(6) = "CSIDL_PERSONAL": | aCSIDLValue(6) = &H5 |
| aCSIDLName(7) = "CSIDL_FAVORITES": | aCSIDLValue(7) = &H6 |
| aCSIDLName(8) = "CSIDL_STARTUP": | aCSIDLValue(8) = &H7 |
| aCSIDLName(9) = "CSIDL_RECENT": | aCSIDLValue(9) = &H8 |
| aCSIDLName(10) = "CSIDL_SENDTO": | aCSIDLValue(10) = &H9 |
| aCSIDLName(11) = "CSIDL_BITBUCKET": | aCSIDLValue(11) = &HA |
| aCSIDLName(12) = "CSIDL_STARTMENU": | aCSIDLValue(12) = &HB |
| aCSIDLName(13) = "CSIDL_MYDOCUMENTS": | aCSIDLValue(13) = &HC |
| aCSIDLName(14) = "CSIDL_MYMUSIC": | aCSIDLValue(14) = &HD |
| aCSIDLName(15) = "CSIDL_MYVIDEO": | aCSIDLValue(15) = &HE |
| aCSIDLName(16) = "CSIDL_DESKTOPDIRECTORY": | aCSIDLValue(16) = &H10 |
| aCSIDLName(17) = "CSIDL_DRIVES": | aCSIDLValue(17) = &H11 |
| aCSIDLName(18) = "CSIDL_NETWORK": | aCSIDLValue(18) = &H12 |
| aCSIDLName(19) = "CSIDL_NETHOOD": | aCSIDLValue(19) = &H13 |
| aCSIDLName(20) = "CSIDL_FONTS": | aCSIDLValue(20) = &H14 |
| aCSIDLName(21) = "CSIDL_TEMPLATES": | aCSIDLValue(21) = &H15 |
| aCSIDLName(22) = "CSIDL_COMMON_STARTMENU": | aCSIDLValue(22) = &H16 |
| aCSIDLName(23) = "CSIDL_COMMON_PROGRAMS": | aCSIDLValue(23) = &H17 |
| aCSIDLName(24) = "CSIDL_COMMON_STARTUP": | aCSIDLValue(24) = &H18 |
| aCSIDLName(25) = "CSIDL_COMMON_DESKTOPDIRECTORY": | aCSIDLValue(25) = &H19 |
| aCSIDLName(26) = "CSIDL_APPDATA": | aCSIDLValue(26) = &H1A |
| aCSIDLName(27) = "CSIDL_PRINTHOOD": | aCSIDLValue(27) = &H1B |
| aCSIDLName(28) = "CSIDL_LOCAL_APPDATA": | aCSIDLValue(28) = &H1C |
| aCSIDLName(29) = "CSIDL_ALTSTARTUP": | aCSIDLValue(29) = &H1D |
| aCSIDLName(30) = "CSIDL_COMMON_ALTSTARTUP": | aCSIDLValue(30) = &H1E |
| aCSIDLName(31) = "CSIDL_COMMON_FAVORITES": | aCSIDLValue(31) = &H1F |
| aCSIDLName(32) = "CSIDL_INTERNET_CACHE": | aCSIDLValue(32) = &H20 |
| aCSIDLName(33) = "CSIDL_COOKIES": | aCSIDLValue(33) = &H21 |
| aCSIDLName(34) = "CSIDL_HISTORY": | aCSIDLValue(34) = &H22 |
| aCSIDLName(35) = "CSIDL_COMMON_APPDATA": | aCSIDLValue(35) = &H23 |
| aCSIDLName(36) = "CSIDL_WINDOWS": | aCSIDLValue(36) = &H24 |
| aCSIDLName(37) = "CSIDL_SYSTEM": | aCSIDLValue(37) = &H25 |
| aCSIDLName(38) = "CSIDL_PROGRAM_FILES": | aCSIDLValue(38) = &H26 |
| aCSIDLName(39) = "CSIDL_MYPICTURES": | aCSIDLValue(39) = &H27 |
| aCSIDLName(40) = "CSIDL_PROFILE": | aCSIDLValue(40) = &H28 |
| aCSIDLName(41) = "CSIDL_SYSTEMX86": | aCSIDLValue(41) = &H29 |
| aCSIDLName(42) = "CSIDL_PROGRAM_FILESX86": | aCSIDLValue(42) = &H2A |
| aCSIDLName(43) = "CSIDL_PROGRAM_FILES_COMMON": | aCSIDLValue(43) = &H2B |
| aCSIDLName(44) = "CSIDL_PROGRAM_FILES_COMMONX86": | aCSIDLValue(44) = &H2C |
| aCSIDLName(45) = "CSIDL_COMMON_TEMPLATES": | aCSIDLValue(45) = &H2D |
| aCSIDLName(46) = "CSIDL_COMMON_DOCUMENTS": | aCSIDLValue(46) = &H2E |
| aCSIDLName(47) = "CSIDL_COMMON_ADMINTOOLS": | aCSIDLValue(47) = &H2F |
| aCSIDLName(48) = "CSIDL_ADMINTOOLS": | aCSIDLValue(48) = &H30 |
| aCSIDLName(49) = "CSIDL_CONNECTIONS": | aCSIDLValue(49) = &H31 |
| aCSIDLName(50) = "CSIDL_COMMON_MUSIC": | aCSIDLValue(50) = &H35 |
| aCSIDLName(51) = "CSIDL_COMMON_PICTURES": | aCSIDLValue(51) = &H36 |
| aCSIDLName(52) = "CSIDL_COMMON_VIDEO": | aCSIDLValue(52) = &H37 |
| aCSIDLName(53) = "CSIDL_RESOURCES": | aCSIDLValue(53) = &H38 |
| aCSIDLName(54) = "CSIDL_RESOURCES_LOCALIZED": | aCSIDLValue(54) = &H39 |
| aCSIDLName(55) = "CSIDL_COMMON_OEM_LINKS": | aCSIDLValue(55) = &H3A |
| aCSIDLName(56) = "CSIDL_CDBURN_AREA": | aCSIDLValue(56) = &H3B |
| aCSIDLName(57) = "CSIDL_COMPUTERSNEARME": | aCSIDLValue(57) = &H3D |
For i = 1 To 57
sRet = zbGetSysFolderPath(aCSIDLValue(i))
sTmp = aCSIDLName(i)
If Len(sRet) > 0 Then
Debug.Print Format(i, "00"); ". "; sTmp, sRet
Else
Debug.Print Format(i, "00"); ". "; sTmp, " <<= ERROR =>>"
End If
Next
Debug.Print String(100, "=")
Debug.Print: Debug.Print
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.3 Jak pobrać numer seryjny dysku, jego etykietę i system plików ?
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
' pobiera oznaczenie dysku, a w opcjonalnych argumentach ByRef zwraca numer seryjny dysku, nazwę woluminu oraz system plików, przy niepowodzeniu zwraca ZERO,
Public Function zbGetDiscInfo(sDriveName As String, _
Optional lNoSerRet As Long, _
Optional sVolNameRet As String, _
Optional sFatRet As String) As Long
Dim sDrive As String
Dim sAllDrives As String
Const MY_MAX_LENGTH As Long = 255
' pobierz wszystkie dostępne dyski w systemie
sAllDrives = UCase( zbAvailableDrives)
sDrive = UCase(Left$(sDriveName, 1))
' sprawdź, czy litera dysku jest prawidłowa
If InStr(1, sAllDrives, sDrive, vbBinaryCompare) = 0 Then
Exit Function
End If
sDrive = sDrive & ":\"
' przygotuj zmienne znakowe na przyjęcie zwracanych ByRef wartości
sVolNameRet = String$(MY_MAX_LENGTH, vbNullChar)
sFatRet = String$(MY_MAX_LENGTH, vbNullChar)
zbGetDiscInfo = GetVolumeInformation( _
sDrive, sVolNameRet, MY_MAX_LENGTH, _
lNoSerRet, 0&, 0&, sFatRet, MY_MAX_LENGTH)
' wytnij zbędne znaki vbNullChar na końcu zmiennych znakowych
sVolNameRet = Left$(sVolNameRet, _
InStr(1, sVolNameRet, vbNullChar) - 1)
sFatRet = Left$(sFatRet, InStr(1, sFatRet, vbNullChar) - 1)
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sDrive As String
Dim sVolName As String
Dim sFat As String
Dim lNoSer As Long
sDrive = Left$(CurDir, 3)
If zbGetDiscInfo(sDrive, lNoSer, sVolName, sFat) > 0 Then
MsgBox "Dysk " & sDrive & vbNewLine & _
"Etykieta dysku - " & sVolName & vbNewLine & _
"Numer seryjny dysku - " & Hex(Trim$(Str$(lNoSer))) & _
vbNewLine & "System plików - " & sFat
End If
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.4 Jak pobrać listę zainstalowanych drukarek ?
Private Declare Function lstrcpy Lib "kernel32" _
Alias "lstrcpyA" _
(ByVal lpString1 As String, _
ByVal lpString2 As String) As Long
Private Declare Function lstrlen Lib "kernel32" _
Alias "lstrlenA" _
(ByVal lpString As String) As Long
Private Declare Function EnumPrinters Lib "winspool.drv" _
Alias "EnumPrintersA" _
(ByVal flags As Long, _
ByVal name As String, _
ByVal Level As Long, _
pPrinterEnum As Long, _
ByVal cdBuf As Long, _
pcbNeeded As Long, _
pcReturned As Long) As Long
Private Type PRINTER_INFO_1
flags As Long
pDescription As String
pName As String
pComment As String
End Type
Private Const PRINTER_ENUM_DEFAULT = &H1
Private Const PRINTER_ENUM_LOCAL = &H2
Private Const PRINTER_ENUM_CONNECTIONS = &H4
Private Const PRINTER_ENUM_NAME = &H8
Private Const PRINTER_ENUM_REMOTE = &H10
Private Const PRINTER_ENUM_SHARED = &H20
Private Const PRINTER_ENUM_NETWORK = &H40
' przy powodzeniu zwraca wartość <> 0 i w tablicy ByRef aPrnRet() listę drukarek, przy błędzie zwraca ZERO
Private Function zbListPrinters(aPrnRet() As String, _
lPrinter As Integer) As Long
Dim lInfo() As Long
Dim pi1() As PRINTER_INFO_1
Dim lSizeBuff As Long
Dim lPrnCount As Long
Dim i As Integer
Dim lRet As Long
ReDim lInfo(256)
lRet = EnumPrinters(lPrinter, "", 1, _
lInfo(0), 256, lSizeBuff, lPrnCount)
' jeżeli za mały mały bufor to ustaw go na lSizeBuff
If lRet = 0 Then
ReDim lInfo(lSizeBuff)
lRet = EnumPrinters(lPrinter, "", 1, _
lInfo(0), lSizeBuff, lSizeBuff, lPrnCount)
End If
' lPrnCount = 0, gdy w systemie WinXP
' użyjemy lPrinter = PRINTER_ENUM_DEFAULT
If lRet <> 0 And lPrnCount > 0 Then
ReDim pi1(0 To lPrnCount - 1) As PRINTER_INFO_1
' tablica wszystkich drukarek
ReDim aPrnRet(0 To lPrnCount - 1)
' zapisz dane do tablicy
For i = 0 To lPrnCount - 1
pi1(i).pName = Space(lstrlen(lInfo(4 * i + 2)))
lRet = lstrcpy(pi1(i).pName, lInfo(4 * i + 2))
aPrnRet(i) = pi1(i).pName
Next
End If
zbListPrinters = i
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim aPrnLocal() As String
Dim lRet As Long
Dim i As Integer
' UWAGA! Win XP nie obsługuje
' lPrinter = PRINTER_ENUM_DEFAULT
lRet = zbListPrinters(aPrnLocal, PRINTER_ENUM_LOCAL)
If lRet > 0 Then
For i = 0 To UBound(aPrnLocal)
Debug.Print (i + 1) & ". " & aPrnLocal(i)
Next
Else
Debug.Print "Błąd odczytu drukarki !"
End If
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.5 Jak synchroniczne sformatować dyskietkę ?
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccessas As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcId As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal hwnd As Long, _
lpdwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal Handle As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Const INFINITE = &HFFFF
Private Const SYNCHRONIZE = &H100000
Private Sub zbFormatA(sDisk As String, fQuickly As Boolean)
On Error GoTo Err_Handler
Dim sCmdLine As String
Dim ff As Integer
Dim sTmpFile As String
Dim sNO As String
If Len(sDisk) = 0 Or Left(UCase(sDisk), 1) <> "A" Then Exit Sub
If MsgBox("Czy chcesz sformatować dysk " & _
sDisk & ":\", vbExclamation + _
vbOKCancel + vbDefaultButton2) = vbCancel Then Exit Sub
DoCmd.Hourglass True
' sprawdź, czy jest dyskietka
sCmdLine = Dir(sDisk & ":", vbHidden + vbReadOnly + _
vbSystem + vbNormal + vbArchive + vbDirectory)
' sprawdzaj dalej
If Len(sCmdLine) = 0 Then
' pusta dyskietka - próba zapisu
ff = FreeFile
Open sDisk & ":\xyz" For Binary Access Write As #ff
Put #ff, , sCmdLine
Close #ff
Else
' jest plik lub folder - próba zmiany atrybutu
SetAttr sDisk & ":\" & sCmdLine, vbNormal
End If
sTmpFile = Environ$("TEMP") & "\~MyTxt.txt"
If Dir(sTmpFile) <> "" Then Kill sTmpFile
ff = FreeFile
sNO = vbNewLine & vbNewLine & "N" & vbNewLine
Open sTmpFile For Binary Access Write As #ff
Put #ff, , sNO
Close #ff
If fQuickly = True Then
' formatowanie szybkie
sCmdLine = "Format A: /q < " & sTmpFile
Else
' formatowanie pełne
sCmdLine = "Format A: < " & sTmpFile
End If
' uruchom w sposób niewidoczny dla użytkownika
zbSynchroProc Shell(Environ$("COMSPEC") & " /c " & _
sCmdLine, vbHide)
DoCmd.Hourglass False
If Dir(sTmpFile) <> "" Then Kill sTmpFile
MsgBox "Zakończono formatowanie dysku: " & UCase(sDisk)
Err_Exit:
Exit Sub
Err_Handler:
DoCmd.Hourglass False
Select Case Err.Number
Case 71
MsgBox "Sprawdź, czy dyskietka znajduje się w stacji: " & _
UCase(sDisk) & ":\"
Case 70, 75
MsgBox "Dyskietka w stacji: " & UCase(sDisk) & ":\" & _
vbNewLine & "jest chroniona przed zapisem."
Case Else
MsgBox Err.Description
End Select
Resume Err_Exit
End Sub
Private Sub zbSynchroProc(lProcID As Long)
Dim hProc As Long
Dim lWindowStyle As Long
Dim lRetWait As Long
If lProcID <> 0 Then
hProc = OpenProcess(SYNCHRONIZE, True, lProcID)
lRetWait = WaitForSingleObject(hProc, INFINITE)
CloseHandle hProc
End If
End Sub
' przykładowe wywołanie:
Private Sub btnFormatA_Click()
' tzw. szybkie formatowanie dyskietki
Call zbFormatA("A", True)
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.6 Jak pobrać niektóre kolory systemowe Windows ?
Private Declare Function GetSysColor Lib "user32" _
(ByVal nIndex As Long) As Long
Private Const COLOR_SCROLLBAR = 0
Private Const COLOR_BACKGROUND = 1
Private Const COLOR_ACTIVECAPTION = 2
Private Const COLOR_INACTIVECAPTION = 3
Private Const COLOR_MENU = 4
Private Const COLOR_WINDOW = 5
Private Const COLOR_WINDOWFRAME = 6
Private Const COLOR_MENUTEXT = 7
Private Const COLOR_WINDOWTEXT = 8
Private Const COLOR_CAPTIONTEXT = 9
Private Const COLOR_ACTIVEBORDER = 10
Private Const COLOR_INACTIVEBORDER = 11
Private Const COLOR_APPWORKSPACE = 12
Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_HIGHLIGHTTEXT = 14
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNSHADOW = 16
Private Const COLOR_GRAYTEXT = 17
Private Const COLOR_BTNTEXT = 18
Private Const COLOR_INACTIVECAPTIONTEXT = 19
Private Const COLOR_BTNHIGHLIGHT = 20
Private Const COLOR_2NDACTIVECAPTION = 27
Private Const COLOR_2NDINACTIVECAPTION = 28
Private Function zbGetSysCol(lIndex As Long) As Long
bGetSysCol = GetSysColor(lIndex)
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim vCol As Variant
Dim i As Long
vCol = Array("COLOR_SCROLLBAR", 0, _
"COLOR_BACKGROUND", 1, _
"COLOR_ACTIVECAPTION", 2, _
"COLOR_INACTIVECAPTION", 3, _
"COLOR_MENU", 4, _
"COLOR_WINDOW", 5, _
"COLOR_WINDOWFRAME", 6, _
"COLOR_MENUTEXT", 7, _
"COLOR_WINDOWTEXT", 8, _
"COLOR_CAPTIONTEXT", 9, _
"COLOR_ACTIVEBORDER", 10, _
"COLOR_INACTIVEBORDER", 11, _
"COLOR_APPWORKSPACE", 12, _
"COLOR_HIGHLIGHT", 13, _
"COLOR_HIGHLIGHTTEXT", 14, _
"COLOR_BTNFACE", 15, _
"COLOR_BTNSHADOW", 16, _
"COLOR_GRAYTEXT", 17, _
"COLOR_BTNTEXT", 18, _
"COLOR_INACTIVECAPTIONTEXT", 19, _
"COLOR_BTNHIGHLIGHT", 20, _
"COLOR_2NDACTIVECAPTION", 27, _
"COLOR_2NDINACTIVECAPTION", 28)
For i = LBound(vCol) To UBound(vCol) Step 2
Debug.Print vCol(i + 1),
Debug.Print vCol(i) & " = " & zbGetSysCol(CLng(vCol(i + 1)))
Next
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.7 Jak zmienić wskaźnik myszy na inny systemowy wskaźnik ?
Private Declare Function GetCursor Lib "user32" () As Long
Private Declare Function SetCursor Lib "user32" _
(ByVal hCursor As Long) As Long
Private Declare Function LoadCursor Lib "user32" _
Alias "LoadCursorA" _
(ByVal hInstance As Long, _
ByVal lpCursorName As Any) As Long
' systemowe kursory
Private Const IDC_ARROW As Long = 32512
Private Const IDC_IBEAM As Long = 32513
Private Const IDC_WAIT As Long = 32514
Private Const IDC_CROSS As Long = 32515
Private Const IDC_UPARROW As Long = 32516
Private Const IDC_SIZE As Long = 32640
Private Const IDC_ICON As Long = 32641
Private Const IDC_SIZENWSE As Long = 32642
Private Const IDC_SIZENESW As Long = 32643
Private Const IDC_SIZEWE As Long = 32644
Private Const IDC_SIZENS As Long = 32645
Private Const IDC_SIZEALL As Long = 32646
Private Const IDC_NO As Long = 32648
Private Const IDC_APPSTARTING As Long = 32650
' uchwyty kursorów
Private hCursorNew As Long
Private hCursorOld As Long
' wciśnij lewy przycisk myszy nad przyciskiem btnTest, przytrzymaj go w stanie wciśniętym i popatrz na kursor !
Private Sub btnTest_MouseDown(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
If Button = acLeftButton Then
hCursorNew = LoadCursor(0&, IDC_NO)
hCursorOld = SetCursor(hCursorNew)
End If
End Sub
Private Sub btnTest_MouseUp(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
If Button = acLeftButton And hCursorOld <> 0 Then
Call SetCursor(hCursorOld)
End If
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.8 Jak załadować wskaźnik myszy z zasobów np. C:\Windows\Cursors ?
Private Declare Function LoadCursorFromFile Lib "user32" _
Alias "LoadCursorFromFileA" _
(ByVal lpFileName As String) As Long
Private Declare Function DestroyCursor Lib "user32" _
(ByVal hCursor As Long) As Long
Private Declare Function SetCursor Lib "user32" _
(ByVal hCursor As Long) As Long
Private hCursorNew As Long
Private hCursorOld As Long
Private Const MY_CURSOR_PATH As String = _
"C:\Windows\Cursors\hnwse.cur"
' wciśnij lewy przycisk myszy nad przyciskiem btnTest, przytrzymaj go w stanie wciśniętym i popatrz na kursor !
Private Sub btnTest_MouseDown(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
If Button = acLeftButton And hCursorNew > 0 Then
hCursorOld = SetCursor(hCursorNew)
End If
End Sub
Private Sub btnTest_MouseUp(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
If Button = acLeftButton And hCursorNew > 0 Then
Call SetCursor(hCursorOld)
End If
End Sub
' załaduj kursor
Private Sub Form_Load()
' upewnij się, czy kursor istnieje
If Len(Dir(MY_CURSOR_PATH)) = 0 Then Exit Sub
hCursorNew = LoadCursorFromFile(MY_CURSOR_PATH)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim lRet As Long
' najprawdopodobniej nie jest potrzebne (niezalecane)
' lRet = DestroyCursor(hCursorNew)
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
3.9 Jak sprawdzić wersję systemu operacyjnego ?
Private Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
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 Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Function zbGetOSVersion() As String
Dim OSInfo As OSVERSIONINFO
Dim sOSVer As String
OSInfo.dwOSVersionInfoSize = Len(OSInfo)
If GetVersionEx(OSInfo) = 0 Then Exit Function
Select Case OSInfo.dwPlatformId
Case VER_PLATFORM_WIN32s
sOSVer = "Win32s"
Case VER_PLATFORM_WIN32_WINDOWS
If (OSInfo.dwMajorVersion = 4 And _
OSInfo.dwMinorVersion = 0) Then
sOSVer = "Windows 95"
ElseIf (OSInfo.dwMajorVersion = 4 And _
OSInfo.dwMinorVersion = 10) Then
sOSVer = "Windows 98"
ElseIf (OSInfo.dwMajorVersion = 4 And _
OSInfo.dwMinorVersion = 90) Then
sOSVer = "Windows Me"
End If
Case VER_PLATFORM_WIN32_NT
If (OSInfo.dwMajorVersion <= 4) Then
sOSVer = "Windows NT"
ElseIf OSInfo.dwMajorVersion = 5 And _
OSInfo.dwMinorVersion = 0 Then
sOSVer = "Windows 2000"
ElseIf OSInfo.dwMajorVersion = 5 And _
OSInfo.dwMinorVersion = 1 Then
sOSVer = "Windows XP"
End If
End Select
zbGetOSVersion = sOSVer
End Function
ΔΔΔ | | | | |
|
| |
