Tekst informacyjny o polityce Cookies Close   
    
 
         
• Strona główna
• 1. Linki
• 3. Kontakt: e-Mail
 
         
• 1. Baza danych
• 2. Tabele i kwerendy
• 3. Formularze
• 4. Raporty
• 5. Moduły i makra
• 6. Obsługa błędów
 
    

II.   VBA 

    
• 1. Okna Accessa
• 2. Okna Formularzy
• 3.Okna Dialogowe
• 4. Tekst
• 5. Liczby
• 6. Pliki
• 7. Inne
 
    

III.   API 

    
• 1. Ogólnie o API
• 2. Funkcje API
• 3. System
• 4. Praca z oknami
• 5. Okna dialogowe
• 6. API - Inne
 
         
• 1. Bitmapy 24 Bit
• 2. GDI i HDC
• 3. Kody kreskowe
• 4. Formant Image
• 5. FreeImage.dll
 
    

V.   Inne 

    
• 1. Shell i MsDOS
• 2. Kontrolki
• 3. ६ԼҚ ਸ
• 4. Unikod

 
Odwiedzin:

Logo AccessFAQ• 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 ?

grupa: pl.comp.bazy-danych.msaccess
na podstawie wątku: Łapczywą łapkę, ktoś ma?
przedstawił: Zbigniew Bratko



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

 ΔΔΔ