|
| | | |
 • III.6. API - Przelicznik Twip / Piksel •
- 6.1 Jak pobrać rozdzielczość pionową i rozdzielczość poziomą kontekstu urządzenia (HDC)
oraz przeliczyć Piksel na Twipy i Twip na Piksel ?
- 6.2 Jak otworzyć plik tekstowy za pomocą systemowego Notatnika, ustawić kursor
na końcu tekstu i na bieżąco śledzić zmiany wpisywanego tekstu ?
- 6.3 Jak osadzić systemowy Kalkulator w formularzu i pobrać za pomocą przycisku otrzymany wynik działania ?
- 6.4 Jak pobrać z systemowego Kalkulatora wynik działania ?
| | | | |
 |
| | |
|
6.1 Jak pobrać rozdzielczość pionową i rozdzielczość poziomą kontekstu urządzenia (HDC)
oraz przeliczyć Piksel na Twipy i Twip na Piksel ?
- Twip
- TWentieth of an Inch Point, TWentIeth of a PostScript Point, TWentIeth of a Point
- • jednostka miary równa 1/120 punktu albo 1/1440 cala. Na centymetr przypada 567 twipów.
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
' w argumentach ByRef zwraca:
' rozdzielczość poziomo (lDpiRetX) kontektsu urządzenia HDC
' rozdzielczość pionowo (lDpiRetY) kontektsu urządzenia HDC
Public Sub zbGetDPI(hWind As Long, _
Optional lDpiRetX As Long, _
Optional lDpiRetY As Long)
Dim lHDC As Long
' pobierz kontekst urządzenia
lHDC = GetDC(hWind)
' pobierz rozdzielczość poziomo
lDpiRetX = GetDeviceCaps(lHDC, LOGPIXELSX)
' pobierz rozdzielczość pionowo
lDpiRetY = GetDeviceCaps(lHDC, LOGPIXELSY)
' zwolnij kontekst urządzenia
lHDC = ReleaseDC(hWind, lHDC)
End Sub
' w argumentach ByRef zwraca:
' przelicznik piksel na twipy poziomo (snPixTwipsRetX)
' przelicznik piksel na twipy pionowo (snPixTwipsRetY)
Public Sub zbGetPix2Twips(hWind As Long, _
Optional snPixTwipsRetX As Single, _
Optional snPixTwipsRetY As Single)
Dim lHDC As Long
' pobierz kontekst urządzenia
lHDC = GetDC(hWind)
' pobierz rozdzielczość poziomo i oblicz przelicznik piksel na twipy
snPixTwipsRetX = 1440 / GetDeviceCaps(lHDC, LOGPIXELSX)
' pobierz rozdzielczość pionowo i oblicz przelicznik piksel na twipy
snPixTwipsRetY = 1440 / GetDeviceCaps(lHDC, LOGPIXELSY)
' zwolnij kontekst urządzenia
lHDC = ReleaseDC(hWind, lHDC)
End Sub
' w argumentach ByRef zwraca:
' przelicznik Twip na piksel poziomo (snTwipsPixRetX)
' przelicznik Twip na piksel pionowo (snTwipsPixRetY)
Public Sub zbGetTwip2Pix(hWind As Long, _
Optional snTwipsPixRetX As Single, _
Optional snTwipsPixRetY As Single)
Dim lHDC As Long
' pobierz kontekst urządzenia
lHDC = GetDC(hWind)
' pobierz rozdzielczość poziomo i oblicz przelicznik twip na piksel
snTwipsPixRetX = GetDeviceCaps(lHDC, LOGPIXELSX) / 1440
' pobierz rozdzielczość pionowo i oblicz przelicznik twip na piksel
snTwipsPixRetY = GetDeviceCaps(lHDC, LOGPIXELSY) / 1440
' zwolnij kontekst urządzenia
lHDC = ReleaseDC(hWind, lHDC)
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim lDpiX As Long
Dim lDpiY As Long
Dim snPix2TwipsX As Single
Dim snPix2TwipsY As Single
Dim snTwip2PixX As Single
Dim snTwip2PixY As Single
Call zbGetDPI(Application.hWndAccessApp, lDpiX, lDpiY)
Debug.Print "Rozdzielczość poziomo: "; lDpiX; " pikseli/cal"
Debug.Print "Rozdzielczość pionowo: "; lDpiX; " pikseli/cal"
Debug.Print String(50, "=")
Call zbGetPix2Twips(hWndAccessApp, snPix2TwipsX, snPix2TwipsY)
Debug.Print "Przelicznik piksel na twip (poziomo) = "; snPix2TwipsX
Debug.Print "Przelicznik piksel na twip ( (pionowo) = "; snPix2TwipsX
Debug.Print String(50, "=")
Call zbGetTwip2Pix(hWndAccessApp, snTwip2PixX, snTwip2PixY)
Debug.Print "Przelicznik twip na piksel (poziomo) = "; snTwip2PixX
Debug.Print "Przelicznik twip na piksel (pionowo) = "; snTwip2PixY
Debug.Print String(50, "=")
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
6.2 Jak otworzyć plik tekstowy za pomocą systemowego Notatnika, ustawić kursor
na końcu tekstu i na bieżąco śledzić zmiany wpisywanego tekstu ?
' W oparciu o przykład: PIDtoHwnd
Private Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal hwnd As Long, _
lpdwProcessId As Long) As Long
Private Declare Function GetWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal wCmd As Long) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal Msg As Long, _
wParam As Any, _
lParam As Any) As Long
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_GETTEXT = &HD
Private Const WM_SETTEXT = &HC
Private Const EM_SETSEL = &HB1
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccessas As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcId 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 btnTest_Click()
Dim sPath As String
Dim sCmdLine As String
Dim lShellPID As Long
Dim lProcID As Long
Dim hProc As Long
Dim hWind As Long
Dim hChild As Long
Dim sOldText As String
Dim sNewText As String
Dim sTmpText As String
Dim lLenText As Long
Dim lCompText As Long
Dim lRetWait As Long
Dim lRet As Long
Dim ff As Long
Const MY_TIME_WAIT As Long = 100
Const MY_FILE_NAME As String = "\~TestTmp.txt"
Const MY_FILE_TEXT As String = " Wpisz coś i zamknij Notatnik !"
sPath = Environ$("TMP") & MY_FILE_NAME
If Len(Dir(sPath)) > 0 Then Kill sPath
' utwórz plik
ff = FreeFile
Open sPath For Binary As FreeFile
Put ff, , MY_FILE_TEXT
Close ff
' i otwórz plik za pomocą Notatnika
sCmdLine = Environ$("WINDIR") & "\Notepad.exe " & sPath
lShellPID = Shell(sCmdLine, vbNormalFocus)
' pobieraj kolejno uchwyty okien (dzieci) pulpitu
hWind = GetWindow(GetDesktopWindow(), GW_CHILD)
Do While hWind <> 0
' pobierz PID okna hNext i porównaj z PID'em Shella
lRet = GetWindowThreadProcessId(hWind, lProcID)
If lProcID = lShellPID Then Exit Do
hWind = GetWindow(hWind, GW_HWNDNEXT)
Loop
' nie znaleziono okna
If hWind = 0 Then
MsgBox "Nie znaleziono okna Notatnika", vbExclamation
Exit Sub
End If
If lShellPID <> 0 Then
hProc = OpenProcess(SYNCHRONIZE, True, lShellPID)
hChild = GetWindow(hWind, GW_CHILD)
' odczytaj tekst w oknie Notatnika
lLenText = SendMessage(hChild, WM_GETTEXTLENGTH, _
ByVal 0&, ByVal 0&)
sOldText = String(lLenText + 1, vbNullChar)
lRet = SendMessage(hChild, WM_GETTEXT, _
ByVal lLenText + 1, ByVal sOldText)
sOldText = Left$(sOldText, lRet)
' ustaw kursor na końcu tekstu
SendMessage hChild, EM_SETSEL, _
ByVal lLenText, ByVal lLenText
Do
' czekaj na zakończenie procesu
lRetWait = WaitForSingleObject(hProc, MY_TIME_WAIT)
' odczytuj na bieżąco tekst w oknie Notatnika
lLenText = SendMessage(hChild, WM_GETTEXTLENGTH, _
ByVal 0&, ByVal 0&)
lLenText = lLenText + 1
sNewText = String(lLenText, vbNullChar)
lRet = SendMessage(hChild, WM_GETTEXT, _
ByVal lLenText, ByVal sNewText)
sNewText = Left$(sNewText, lRet)
' sprawdzaj czy w trakcie działania pętli okno zostało zamknięte
If IsWindow(hChild) <> 0 Then
lCompText = StrComp(sNewText, sOldText, _
vbBinaryCompare)
If lCompText <> 0 Then
If StrComp(sTmpText, sNewText, _
vbBinaryCompare) <> 0 Then
Debug.Print sNewText
End If
End If
sTmpText = sNewText
End If
DoEvents
Loop Until lRetWait = 0
CloseHandle hProc
End If
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
6.3 Jak osadzić systemowy Kalkulator w formularzu i pobrać za pomocą przycisku otrzymany wynik działania ?
ΔΔΔ | | | | |
|
|
| | |
|
6.4 Jak pobrać z systemowego Kalkulatora wynik działania ?
<cyt>
Coś to SetParent przestało działać ... :(
a'2003 + win 2003 server
--
KN
</cyt>
Cytat powyższy odnośi się do przykładu poprzedniego:
(6.3 Jak osadzić systemowy Kalkulator w formularzu ....),
który właśnie korzysta z funkcji API SetParent (...)
Ponieważ nie zawsze działa SetParent, to dlatego powstał ten przykład jako prostsza wersja i nie korzystajaca z tej funkcji.
ΔΔΔ | | | | |
|
| |
