Dim frm As Form

For Each frm In Forms
  If frm.Name <> "nazevMDIformulare" Then
    If frm.MDIChild Then Unload frm
  End If
Next frm

Dim lstPol As ListItem
Set lstPol = ListView1.Add(Text:="Prvni") 'nova polozka v ListView
lstPol.Bold = True


MsgBox(printer.devicename) 'Nastavená výchozí tiskárna 2
Set Printer = Printers(3) 'Nastavení tisku na tiskárnu 3
MsgBox(printer.devicename) 'Nastavená tiskárna 3
Printer.Print "Text" 'Tento text se už tiskne na výchozí tiskárnu 2
MsgBox(printer.devicename) 'A zde je nastavená výchozí tiskárna 2


Form1.DrawMode = vbXorPen
Form1.BackColor = RGB(0, 0, 0) 'Barva pozadi - cerna
Form1.ForeColor = RGB(255, 0, 0) 'Barva pera - cervena
Form1.Circle (500, 500), 200 'Nakresli kruznici
Form1.Circle (500, 500), 200 'Zrus kruznici


Pro první kružnici je výsledek brán z RGB(0,0,0) XOR RGB(255,0,0) = RGB(255,0,0). Při druhém vykreslení je však již barva pozadí v místě kružnice červená, tj. RGB(255,0,0) a výsledkem RGB(255,0,0) XOR RGB(255,0,0) je RGB(0,0,0), tedy barva pozadí formuláře, tzn. kružnice zmizí.

Dim i As Long

i = 0
Do While i <= List1.ListCount - 1
  If List1.Selected(i) Then
    List1.RemoveItem i
  Else
    i = i + 1
  End If
Loop

Public Declare Function GetSysColor Lib "user32" Alias "GetSysColor" (ByVal nIndex As Long) As Long

Public Const COLOR_BTNFACE = 15
Public Const COLOR_BTNTEXT = 18

barva = GetSysColor(COLOR_BTNFACE)

Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5

Private Sub VypisOkna()
  Dim desktop As Long, hwnd As Long
  Dim title As String, delka As Long

  hwnd = GetWindow(GetDesktopWindow, GW_CHILD)
  Do While hwnd <> 0
    hwnd = GetWindow(hwnd, GW_HWNDNEXT)

    title = String(255, vbNullChar)
    delka = GetWindowText(hwnd, title, 255)
    title = Left(title, delka)

    If delka > 0 Then Debug.Print title
  Loop
End Sub


Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

Private Sub ZobrazSN(ByVal disk As String) 'disk - napr. C:\
  Dim sn As Long, nazev As String, i1 As Long, i2 As Long, i3 As String, hw As Long, lw As Long

  nazev = Space(14): i3 = Space(32)
  GetVolumeInformation "C:\", nazev, Len(nazev), sn, i1, i2, i3, Len(i3)
  hw = HiWord(sn) And &HFFFF&
  lw = LoWord(sn) And &HFFFF&
  MsgBox "Seriové číslo disku: " & Format(Hex(hw), "0000") & "-" & Format(Hex(lw), "0000")
End Sub

Private Function HiWord(ByVal dw As Long) As Integer
  If dw And &H80000000 Then
    HiWord = (dw \ 65535) - 1
  Else
    HiWord = dw \ 65535
  End If
End Function

Private Function LoWord(ByVal dw As Long) As Integer
  If dw And &H8000& Then
    LoWord = &H8000 Or (dw And &H7FFF&)
  Else
    LoWord = dw And &HFFFF&
  End If
End Function

Private Sub Main()
  frmSplash.Show
  DoEvents

  If App.Previnstance ... 'nějaké kontroly před spuštěním, otevření DB apod.
  If GetSettings( ...
  otevriDatabazi(cesta) ...
  ...

  Load frmMain
  Unload frmSplash
  frmMain.Show 'hlavní formulář aplikace
End Sub

'====================== kód formuláře ======================
Private Sub Form_Load()
  insertmymenu
End Sub

Private Sub Form_Unload(cancel As Boolean)
  unloadmymenu
End Sub

'====================== kód modulu =========================
Private lngID As Long
Private lngOldProcessID As Long

Public Sub insertmymenu()
  Dim hWndSystemMenu As Long

  hWndSystemMenu = GetSystemMenu(frmMenuSample.hwnd, 0&) 'získej ID systémového menu
  InsertMenu hWndSystemMenu, 0, MF_STRING, mlngID, "moje menu" 'vlož položku menu
  'nastav novou funkci pro obsluhu zpráv
  lngOldProcessID = SetWindowLong(Form1.hwnd, GWL_WNDPROC, AddressOf SystemMenuCallBack)
End Sub

Public Sub unloadmymenu()
  'Nastav původní obsluhu zpráv
  SetWindowLong Form1.hwnd, GWL_WNDPROC, lngOldProcessID
End Sub

Public Function SystemMenuCallBack(ByVal lnghwnd As Long, ByVal lngMessage _
  As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  If lngMessage = WM_SYSCOMMAND Then 'bylo kliknuto na syst. menu
    Select Case wParam 'která položka to byla
      Case lngID
        msgbox "Moje menu"
        Exit Function
      Case Else
    End Select
  End If
  SystemMenuCallBack =CallWindowProc(lngOldProcessID, lnghwnd, lngMessage, wParam, lParam)
End Function

cf.lStructSize = Len(cf)
cf.hwndOwner = Form1.hWnd
cf.hDC = Printer.hDC
cf.Flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
cf.nFontType = REGULAR_FONTTYPE
cf.nSizeMin = 10
cf.nSizeMax = 72

Pokud jde o druhý problém s dialogy pro vyhledávání a nahrazení textu, netuším proč to dělá (kdo víte jak na to, napište).

Dim i As Long, retezec As String

i = FreeFile
Open "C:\pokus1.txt" For Binary As #i
retezec = "prvni" & Chr(13) & Chr(10) & "druhy" & Chr(13) & Chr(10) & "treti"
Put #i, , retezec
Close i

i = FreeFile
Open "C:\pokus2.txt" For Output As #i
Print #i, "prvni"
Print #i, "druhy"
Print #i, "treti"
Close i

Oba dva tyto kódy vytvoří stejný soubor (pouze u druhého bude za posledním znakem ještě znak nového řádku). Pokud pracujete s textovými soubory, doporučoval bych zkusit rozšíření Microsoft Scripting Runtime a jeho objekty FileSystemObject, TextStream a File. Na takovou práci jsou to velmi vhodné objekty.

Dim bi As BROWSEINFO, pidl As Long, path As String

bi.hOwner = Me.hwnd
bi.lpszTitle = "Vyberte adresář pro zálohu a stiskněte tlačítko OK."
bi.ulFlags = BIF_RETURNONLYFSDIRS
pidl = SHBrowseForFolder(bi) 'dialog
path = Space(512)
SHGetPathFromIDList ByVal pidl, ByVal path

Deklarace funkcí a typů pak vypadá takto:

Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000

Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Dim jm As String, ret As Long
jm=Space(255)
ret=GetUserName(jm, 255)

MsgBox "Jméno uživatele: " & jm

Dim filebox As OPENFILENAME

filebox.lStructSize = Len(filebox) 'velikost struktury
filebox.hwndOwner = Form1.hWnd 'handle volajiciho formulare
filebox.lpstrTitle = "Open File" 'titulek
filebox.lpstrFilter = "textové soubory" & vbNullChar & "*.txt" & vbNullChar
& "Všechny soubory" & vbNullChar & "*.*" & vbNullChar & vbNullChar 'filtr
filebox.lpstrFile = Space(255) 'tady naplnime promennou pro vraceni jmena a cesty k souboru
filebox.nMaxFile = 255 'max. delka souboru plus cesta
filebox.lpstrFileTitle = Space(255) ' promenna pro nazev souboru
filebox.nMaxFileTitle = 255 'max. delka nazvu souboru
filebox.flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY 'dalsi nastaveni

Pokud někoho ze čtenářů napadne lepší řešení, napiště nám jej, rádi jej zveřejníme.

Přehled API funkcí bude trochu problém. Buď jde o knihy, které přímo učí programovat ve Windows (např. Programovaní ve Windows 95), ale v těch nenajdete seznam API. Dále vyšla třeba kniha WIN32 API (2. díly), kde je size seznam API funkcí, ale tradičně v jazyce C. Nějaká podobná kniha pro programátory ve Visual Basicu u nás zatím není.

Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const VK_ESCAPE = &H1B
Const KEYEVENTF_KEYUP = &H2

keybd_event VK_ESCAPE, 0, 0, 0 'dolu
keybd_event VK_ESCAPE, 0, KEYEVENTF_KEYUP, 0 'nahoru

Public Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

Místo jiného ovládacího prvku bych použil spíše API funkce SetTimer a KillTimer. Jak je použít najdete v této rubrice v čísle 6/2000.

Declare Function ExitWindowsEx Lib "user32.dll" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long

První parametr nastavte na EWX_POWEROFF = 8 a pokud potřebujete přidejte i EWX_FORCE = 4 (nebude se ptát aplikací jestli je může vypnout nebo ne). Takže asi takto:

ExitWindowsEx EWX_POWEROFF + EWX_FORCE, 0

Ukončit běžící program můžete pomocí API funkce SendMessage se zprávou WM_CLOSE (WM_CLOSE = &H10).

MsgBox Form1.ActiveControl.Name
Form1.ActiveControl.Caption="tlacitko 1"

Pokud nechcete použít vázané prvky a Data prvek, tak stačí vytvořit Recordset s informacemi o autorech a jeho obsah "natáhnout" do seznamu ComboBoxu.

The macros in this project are disabled. Please refer to the online help or documentation of the host application to determine how to enable macros.

Problém je způsoben zákazem provádění maker. Je třeba zapnout antivirovou ochranu (ve Wordu to je menu Nástroje -> Možnosti, záložka Obecné, položka Antivirová ochrana maker) a spustit aplikaci znovu (Word). Když po dotazu dáte povolit makra, mělo by to fungovat.

ret = SHGetSpecialFolderLocation(0, &H6, idl)
If ret = 0 Then
  cesta = Space(255)
  SHGetPathFromIDList idl.mkid.cb, cesta
  MsgBox cesta 'toto je cesta ke složce oblíbené položky
End If

Deklarace funkcí a typů:

Private Type SHITEMID
  cb As Long
  abID As Byte
End Type

Private Type ITEMIDLIST
  mkid As SHITEMID
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long

Pic1.CurrentX = 500
Pic1.CurrentY = 150
Pic1.Print "Text na x 500 a y 150"

Private Type RECT
  left As Long
  top As Long
  right As Long
  bottom As Long
End Type
Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long

Dim r As RECT
r.left = 100
r.right = 200
r.bottom = 200
r.top = 100
ClipCursor r

Pokud to chcete nastavit zpět na celou obrazovku, stačí nastavit zpět na puvodní hodnoty. Nejlépe to lze takto (GetDesktopWindow a GetWindowRect jsou také API funkce, jejich deklaraci naleznete v API Vieweru):

Dim r As RECT, retval As Long, deskhWnd As Long

deskhWnd = GetDesktopWindow()
GetWindowRect deskhWnd, r
ClipCursor r

Záleží na tom, jaký help chcete vytvořit. Pokud klasický HLP, musíte si vytvořit text pomocí nějakého editoru, který umí formát RTF, např. Word. Další věci jako rejstříky apod. se potom vytváří pomocí Help Workshopu. Pomocí něj také zkompilujete výsledný HLP soubor, který se dá potom jednoduše použít ve VB.

Pokud chcete HTML help, vytvoříte normální HTML soubory, které pomocí HTML Help Workshopu zkompilujete do výsledného CHM souboru. Jeho použití je však ve VB zatím poněkud složitější, není pro něj žádná podpora, vše se musí dělat pomocí API. A navíc tento formát nepodporují Windows 95.

Private Sub mnuDel_Click()
  If frmStart.ActiveControl.Name = "txtFind" Then Exit Sub
  .
  .
End Sub

Tj. menu mnuDel se nevyvolá, ale neprovede se ani výmaz textu v TextBoxu. Nevíte jak tohle obejít?

If KeyCode = vbKeyDelete Then
  If Me.ActiveControl.Name <> "txtFind" Then
    mnuDel_Click
  End If
End If

'funkce vrací kolekci, která obsahuje názvy všech požadovaných souborů i s cestou
Public Sub FindFile(ByVal strFolder As String, ByVal strFile As String, colFiles As Collection)
  Dim hSearch As Long, udtFindData As WIN32_FIND_DATA, strTmp As String
  Dim i As Long, ret As Long

  If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"

  hSearch = FindFirstFile(strFolder & "*.*", udtFindData)

  If hSearch = INVALID_HNADLE_VALUE Then Exit Sub

  ret = 1
  Do While ret <> 0
    i = InStr(1, udtFindData.cFileName, Chr(0))
    strTmp = IIf((i = 0), udtFindData.cFileName, Left(udtFindData.cFileName, i - 1))

    If udtFindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY Then
      If strTmp <> "." And strTmp <> ".." Then
        FindFile strFolder & strTmp, strFile, colFiles
      End If
    Else
      If strTmp Like strFile Then
        colFiles.Add strFolder & strTmp
      End If
    End If
    ret = FindNextFile(hSearch, udtFindData)
  Loop

  FindClose hSearch
End Sub

'použití
Dim soubory As New Collection, i As Long

FindFile "D:\", "*.jpg", soubory

For i = 1 To soubory.Count
  Debug.Print soubory(i)
Next i

SendMessage List1.hwnd, LB_SETHORIZONTALEXTENT, lText/Screen.TwipsPerPixelX, 0&

Hodnota lText je nejdelší položka v ListBoxu zjištěná takto:

Dim i As Long, lText As Long, tmp As Long

lText = 0
For i = 0 To List1.ListCount - 1
  tmp = TextWidth(List1.List(i))
  If tmp > lText Then lText = tmp
Next i
lText = lText + TextWidth(" ")

propmpt = "Zadej úplné jméno pro hledání"
searchStr = InputBox(prompt$, "hledaný řetězec")

Data1.Recordset.Index = "NázevFirmy"
Data1.Recordset.Seek "=", searchStr

propmpt = "Zadej úplné jméno pro hledání"
searchStr = InputBox(prompt$, "hledaný řetězec")

Data1.Recordset.FindFirst "NázevFirmy='" & searchStr & "'"

On Error Resume Next

Set fso = CreateObject("Scripting.FileSystemObject")
i = fso.Drives(strDrive).FreeSpace
If Err.Number = 0 Then
  Debug.Print "CD je v mechanice"
End If

On Error GoTo 0

Dim ret As Long, h1 As String

ret = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", 0, KEY_ALL_ACCESS, hKey)
If ret = 0 Then
  h1 = "c:\project1.exe"
  RegSetValueEx hKey, "MujProgram", 0, REG_SZ, h1, Len(h1)
  RegCloseKey hKey
End If

Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")
Kill fso.GetSpecialFolder(2) & "\*.*"

Dim q As New Class1, met As String

met="Metoda1"
CallByName q, met, VbMethod, ..... (..... = parametry metody)

Declare Function SearchTreeForFile Lib "imagehlp.dll" _
  (ByVal sRootPath As String, ByVal InputPathName As String, _
  ByVal OutputPathBuffer As String) As Long

Dim r As RECT

GetWindowRect Form1.hWnd, r
ClipCursor r

myDb.Execute "DELETE * FROM Tabulka1"

U FlexGridu je důležité jak jej používáte, ale pokud pouze na prohlížení s tím, že editace se provádí v jiných prvcích, pomůže vám metoda Refresh prvku Data, na který je FlexGrid připojen.

Inet1.Protocol = icFTP
Inet1.URL = "ftp.xy.cz"
Inet1.UserName = "uzivatel"
Inet1.Password = "heslo"

Inet1.Execute , "GET help.zip C:\help.zip"

Do While Not Data1.Recordset.EOF
  radek = Data1.Recordset!jmeno & chr(9) & Data1.Recordset!prijmeni & vbCrLf
  Printer.Print radek
  Data1.Recordset.MoveNext
Loop

Printer.EndDoc

MSComm1.CommPort = 2 'seriový port, na kterém je připojen modem
MSComm1.Settings = "9600,N,8,1 'nastavení portu (blíže viz. MSDN)
MSComm1.PortOpen = True 'Otevření portu
MSComm1.Output = "ATDT" & cislo & vbCrLf 'Vytočení čísla

Dim x As Long
x = sndPlaySound("c:\windows\media\tada.wav", SND_LOOP)

Dim x As Long
x = sndPlaySound("c:\windows\media\tada.wav", SND_LOOP + SND_ASYNC)