Visual Basic

Je formulář v paměti?	Kód
Je ComboBox rozbalený?	Kód
Převody teplot	Kód
Přestupný rok	Kód
Má připojená myš kolečko?	Kód
Počet přeskočených řádků při pohybu kolečkem	Kód
Operace Drag and drop se soubory	Kód

Je formulář v paměti?

Funkce vrátí hodnotu True, pokud je formulář zadaný svým jménem již nahrán do paměti, tzn. pokud je nalezen v kolekci Forms.

Function FrmIsLoaded(ByVal FormName As String) As Boolean
  Dim frm As Form
  
  FrmIsLoaded = False
  For Each frm In Forms
    If UCase(frm.Name) = UCase(FormName) Then
      FrmIsLoaded = True
      Exit For
    End If
  Next frm
End Function

Zpět na obsah

Je CombBox rozbalený?

Chcete-li zjistit, zda je rozbalovací část ComboBoxu rozbalena, použijte funkci IsComboDrop. K zjištění této informace využívá funkci API SendMessage.

Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
  (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const CB_GETDROPPEDSTATE = &H157


Function IsComboDrop(cbo As ComboBox) As Boolean
  Dim res As Long
  
  res = SendMessage(cbo.hwnd, CB_GETDROPPEDSTATE, 0&, ByVal 0&)
  IsComboDrop = (res <> 0)
End Function

Zpět na obsah

Převody teplot

Níže uvedené dvě funkce C2F a F2C převádí teplotu ve stupních Celsia na teplotu ve stupních Fahrenheita a opačně.

Function C2F(ByVal Celsius As Double) As Double
  C2F = 32 + Celsius * 9 / 5
End Function

Function F2C(Fahrenheit As Double) As Double
  F2C = (Fahrenheit - 32) * 5 / 9
End Function

Zpět na obsah

Přestupný rok

Chcete-li vědět, zda je přestupný rok, můžete si to buď spočítat sami podle známého algoritmu (což je poněkud pracnější) nebo můžete věřit Visual Basicu, že to umí správně. Oba příklady vám ukážeme.

Function LeapYear(ByVal Year As Long) As Boolean
  LeapYear = Month(DateSerial(Year, 2, 29)) = 2
End Function

'Jestlize je rok delitelny beze zbytku 4, je prestupny, ale pokud je zaroven
'delitelny i 100, neni prestupny, ale pokud je delitelny i 400, prestupny je
Function LeapYear2(ByVal Year As Long) As Boolean
  LeapYear2 = False
  If Year Mod 4 = 0 Then
    If Year Mod 100 = 0 Then
      If Year Mod 400 Then
        LeapYear2 = True
      End If
    Else
      LeapYear2 = True
    End If
  End If
End Function

Zpět na obsah

Má připojená myš kolečko?

Zjistit, zda-li má myš kolečko pro jednodušší ovládání, není žádný problém. Stačí zavolat funkci API GetSystemMetrics s parametrem SM_MOUSEWHEELPRESENT.

Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Const SM_MOUSEWHEELPRESENT = 75

Function IsWheel() As Boolean
  IsWheel = GetSystemMetrics(SM_MOUSEWHEELPRESENT)
End Function

Pokud myš kolečko má, vrátí funkce hodnotu True.

Zpět na obsah

Počet přeskočených řádků při pohybu kolečkem

Otočíte-li kolečkem, pohybujete se v dokumentu, v internetovém prohlíže, prostě kdekoliv, kde je kolečko podporováno, posunete se o určitý počet řádku nahoru nebo dolu. Chcete-li vědět o kolik, nebo dokonce nastavovat tuto hodnotu, zkuste tento příklad.

Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
  (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Long, _
   ByVal fuWinIni As Long) As Long

Const SPI_GETWHEELSCROLLLINES = 104
Const SPI_SETWHEELSCROLLLINES = 105
Const SPIF_SENDWININICHANGE = &H2


'Vrátí počet řádků
Function GetWheelLines() As Long
  Dim ret As Long 
  SystemParametersInfo SPI_GETWHEELSCROLLLINES, 0, ret, 0
  GetWheelLines = ret
End Function

'Nastaví počet řádků
Sub SetWheelLines(ByVal newValue As Long)
  SystemParametersInfo SPI_SETWHEELSCROLLLINES, newValue, 0, SPIF_SENDWININICHANGE
End Sub

Zpět na obsah

Opearace Drag and drop se soubory

Vytváříte-li např. textový editor, musíte uživateli umožnit nějakým způsobem otevírat soubory. Jedna možnost je zvolit klasické menu Soubor/Otevřít atd. Co takhle umožnit otevřít soubor pouhým přetažením na váš spuštěný editor? Není to nic složitého. Textbox, který má hlavní funkci editoru, musí mít vlastnost OLEDropMode nastavenu na hodnotu 1, tj. Manual. Pak již stačí vložit do formuláře tento kód:

Private Sub DropFile(ByVal txt As TextBox, ByVal strFN As String)
  Dim iFile As Integer
  Dim sFile As String
  
  iFile = FreeFile
  Open strFN For Binary Access Read As #iFile
  sFile = Space(LOF(iFile))
  Get #iFile, , sFile
  Close #iFile

  With txt
    .SelStart = Len(txt)
    .SelLength = 0
    .SelText = sFile
  End With
End Sub

Private Sub Text1_OLEDragDrop(Data As DataObject, Effect As Long, _
Button As Integer, Shift As Integer, X As Single, Y As Single)
  Dim f
  If Data.GetFormat(vbCFFiles) Then
    For Each f In Data.Files
      DropFile Text1, f
    Next f
  End If
End Sub

Private Sub Text1_OLEDragOver(Data As DataObject, Effect As Long, _
Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
  If Data.GetFormat(vbCFFiles) Then
    Effect = vbDropEffectCopy And Effect
  Else
    Effect = vbDropEffectNone
  End If
End Sub

Pokud označíte jeden nebo více souborů a "přetáhnete" je myší nad textbox, vloží se do něj jejich obsah. Samozřejmě je asi mnohem lepší pro každý soubor otevřít nové okno, ale to už určitě zvládnete sami.

Zpět na obsah