Postup:
Otevřete nový
formulář a nový modul.
Do modulu deklarujte následující
funkce:
Declare
Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long) As Long
Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal
hdc As Long, ByVal x As Long, ByVal Y As Long, ByVal lpString As String,
ByVal nCount As Long) As Long
* každá deklarace musí
být napsána celá na samostatné řádce
Na událost Click formuláře
vložte následující kód:
Private Sub
Form_Click()
Const OEM_FIXED_FONT = 10
Const PIXEL = 3
Dim hOEM As
Long 'Ukazatel
na OEM Font Object
Dim Y, H
As Single
Dim PreviousObject As Long
'uložení
scale módu aby se později nechal obnovit
Saved% =
Form1.ScaleMode
'změna scale módu
Form1.ScaleMode
= PIXEL
'Zjištění šířky
znaku a odsazení
H = Form1.TextHeight(Chr$(200))
- 1
'Zjištění ukazatele
na požadovaný font
hOEM =
GetStockObject(OEM_FIXED_FONT)
'Výběr
objektu respondujícího s fontem
PreviousObject
= SelectObject(Form1.hdc, hOEM)
'Pokud úspěšnost,
pak tisk sady
If
PreviousObject Then
'nastavení okrajů
Edge$ =
" "
'inicializace výstupní
polohy
xMark = 10
yMark = 10
'nastavení
kurzoru a tisk horního okraje
Form1.CurrentX
= xMark
Form1.CurrentY = yMark
T$ = " " + Edge$ + " "
ret% = TextOut(Form1.hdc, yMark, xMark, T$, Len(T$))
'Cyklus
pro 256 znaků, začátek od 0
For Row%
= 0 To 15
'příprava levého
okraje
T$ = Mid$(Edge$,
(Row% * 2) + 1, 2)
'vytvoření řetězce
znaků
For
Col% = 0 To 15
Ch = (Row% * 16) + Col%
T$ = T$ + Chr$(Ch) + " "
Next
'příprava
pravého okraje
T$ = T$ +
Mid$(Edge$, (Row% * 2) + 1, 2)
'příprava pro
zobrazení na dalším řádku
xMark
= xMark + H
'tisk
řetězce znaků
ret%
= TextOut(Form1.hdc, yMark, xMark, T$, Len(T$))
Next
'příprava
pro tisk na dalším řádku
xMark
= xMark + H
'tisk
spodního okraje
T$
= " " + Edge$ + " "
ret% = TextOut(Form1.hdc, yMark, xMark, T$, Len(T$))
'obnovení původního
fontu
hOEM
= SelectObject(Form1.hdc, PreviousObject)
Else
'výběr
objektu nebyl úspěšný
MsgBox
"Nemohu nalézt OEM Fonty", 48
End If
'reset scale módu
Form1.ScaleMode
= Saved%
End Sub
Spusťe aplikaci. Po
kliknutí na formulář se na něm vypíše sada ASCII znaků.
|