Tisk ASCII tabulky

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ů.

Zpět

Autor: The Bozena

iReklama.cz - nový reklamní systém
iReklama.cz - nový reklamní systém