на сайте на Народ.Ру на Яндексе

1. ОТСЛЕЖИВАНИЕ DOUBLE CLICK ДЛЯ КНОПОК НА ТУЛБАРЕ
2. ОБЪЕМ КАТАЛОГА В БАЙТАХ
3. ПОЛЕЗНАЯ ДИСКОВАЯ ИНФОРМАЦИЯ
4. ИМИТТАЦИЯ НАЖАТИЕ CTRL ДЛЯ ВЫДЕЛЕНИЯ ОТДЕЛЬНЫХ ITEM В LIST
5. ВЫБРАТЬ ВСЕ ФАЙЛЫ ПО МАСКЕ В ПОДДЕРЕВЕ КАТАЛОГОВ
6. ИМЯ ТЕКУЩЕГО КОМПЬЮТЕРА В WINDOWS 95/NT
7. КАК ПОКАЗАТЬ ШРИФТЫ, КОГДА ВЫ ВЫБИРАЕТЕ ИХ
8. ПЕРЕХВАТ ПРАВЫХ КЛИКОВ НА УЗЛАХ TREEVIEW
9. ЗАПУСК VB ПРИ ПОМОЩИ МЕНЮ SENDTO
10. НОВЫЕ "ГОРЯЧИЕ КНОПКИ" ДЛЯ VB
11. КАК ПОЛУЧИТЬ USERID ПОД WINDOWS 95/NT
12. ВЫВОД ПЕСОЧНЫХ ЧАСОВ ВО ВРЕМЯ ОБРАБОТКИ ДАННЫХ
13. ОЦЕНКА ПРОМЕЖУТКА ВРЕМЕНИ(в минутах) МЕЖДУ ДВУМЯ ДАТАМИ
14. ХВАТИТ ПЕЧАТАТЬ!
15. ПОМЕНЯТЬ ЗНАЧЕНИЯ ДВУХ ПЕРЕМЕННЫХ
16. БЫСТРЫЙ ОБСЧЕТ МНОГОЧЛЕНОВ
17. ФОРМАТИРОВАНИЕ И КОПИРОВАНИЕ ДИСКЕТ ЧЕРЕЗ ФУНКЦИИ API
18. ПОСЛЕДОВАТЕЛЬНЫЕ НОМЕРА ВЕРСИЙ
19. ВЫРАВНИВАНИЕ КОНТРОЛОВ ПО ПРАВОМУ КРАЮ
20. VAL НЕ РАБОТАЕТ НА ФОРМАТИРОВАННЫХ ЧИСЛАХ
21. СМЫШЛЕНЫЙ ГЕНЕРАТОР ID
22. ИЗМЕНЕНИЕ РАЗМЕРА ВЫПАДАЮЩЕЙ ОБЛАСТИ НА COMBOBOXE
23. КОЛИЧЕСТВО СВОБОДНОЙ ПАМЯТИ С ПОМОЩЬЮ WIN32
24. СКОЛЬКО ВАМ ЛЕТ?
25. УЗЕЛОК, О КОТОРОМ НЕВОЗМОЖНО ЗАБЫТЬ
26. СОЗДАТЬ НА ЛЕТУ МАССИВ ПРИ ПОМОЩИ ФУНКЦИИ ARRAY
27. НАЙТИ ВЫБРАННЫЙ КОНТРОЛ В МАССИВЕ OPTION BUTTONS
28. УПАКОВКА ЗНАЧЕНИЙ CHECK-BOX В ОДНУ ПЕРЕМЕННУЮ ТИПА INTEGER
29. УСЛОВНАЯ КОМПИЛЯЦИЯ КОДА
30. УМЕНЬШИТЬ МЕРЦАНИЕ ВО ВРЕМЯ ЗАГРУЗКИ ФОРМЫ

31. ОТСЛЕЖИВАНИЕ DOUBLE CLICK ДЛЯ КНОПОК НА ТУЛБАРЕ

VB4 32, VB5
Level: Intermediate
VB4 поддерживает встроенный в Win95 контрол Toolbar, позволяющий юзерам добавлять кнопки на Тулбар. У этих кнопок есть событие ButtonClick, но если Вы хотите отлавливать double-click, то стандартного события ButtonDoubleClick нет. Чтобы исправить это, объявите две переменные уровня формы:

Private mbSingleClicked As Boolean
Private mbDoubleClicked As Boolean

        In the Toolbars ButtonClick event, add this code:
В событии ButtonClick Тулбара добавьте следующий код:

Private Sub Toolbar1_ButtonClick_
        (ByVal Button As Button)
Dim t As Single
t = Timer
If mbSingleClicked = True Then
        mbDoubleClicked = True
        MsgBox "Double Clicked"
Else
        mbSingleClicked = True
        ' позволить юзеру кликнуть еще раз, если он хочет дабл-кликнуть
Do While Timer - t < 1 And mbSingleClicked = True
                DoEvents
        Loop
        ' если юзер сделал DoubleClick, выйти из процедуры
        If mbDoubleClicked = True Then
                mbSingleClicked = False
                mbDoubleClicked = False
                Exit Sub
        End If
End If
If mbDoubleClicked = False Then
        MsgBox "Single Clicked"
End If

'пример обработки этих событий
'If mbDoubleClicked Then
'--------- code
'ElseIf mbSingleClicked Then
'--------- code
'End If

'при выходе из процедуры надо реинитить переменные, иначе мы упремся в SingleClickи
If mbDoubleClicked = False Then
        mbSingleClicked = False
        mbDoubleClicked = False
End If
End Sub

Назад к СОДЕРЖАНИЮ

32. ОБЪЕМ КАТАЛОГА В БАЙТАХ

 VB3, VB4 16/32, VB5
Level: Intermediate

Эта функция возвращает число байт, занятых файлами в каталоге:

Function DirUsedBytes(ByVal dirName As _
        String) As Long
Dim FileName As String
Dim FileSize As Currency

' добавить \, если не было
If Right$(dirName, 1) <> "\" Then
        dirName = dirName & "\"
Endif
FileSize = 0
FileName = Dir$(dirName & "*.*")

Do While FileName <> ""
        FileSize = FileSize + _
                FileLen(dirName & FileName)
        FileName = Dir$
Loop
DirUsedBytes = FileSize

End Function

Пример вызова такой функции:

MsgBox DirUsedBytes("C:\Windows")
 
 

Назад к СОДЕРЖАНИЮ

33. ПОЛЕЗНАЯ ДИСКОВАЯ ИНФОРМАЦИЯ

VB4 32, VB5
Level: Advanced

Эта функция возвращает количество свободного пространства на диске, общий объем диска, долю свободного пространства н адиске, и использванное пространство. Перед вызовом функции, присвойте первому полю структуры DISKSPACEINFO ("RootPath") имя диска:

Dim dsi As DISKSPACEINFO
dsi.RootPath = "C:\"
GetDiskSpace dsi

Функция возвращает все результаты в других полях записи(структуры):

' *** Declaratiosn Section ******
Declare Function GetDiskFreeSpace Lib _
        "kernel32" Alias _
        "GetDiskFreeSpaceA" _
        (ByVal lpRootPathName As String, _
        lpSectorsPerCluster As Long, _
        lpBytesPerSector As Long, _
        lpNumberOfFreeClusters As Long, _
        lpTotalNumberOfClusters As Long) _
        As Long

Type DISKSPACEINFO
        RootPath As String * 3
        FreeBytes As Long
        TotalBytes As Long
        FreePcnt As Single
        UsedPcnt As Single
End Type

' ****** МОДУЛЬ КОДА ******
Function GetDiskSpace(CurDisk As _
        DISKSPACEINFO)
        Dim X As Long
        Dim SxC As Long, BxS As Long
        Dim NOFC As Long, TNOC As Long

        X& = GetDiskFreeSpace_
                (CurDisk.RootPath, SxC, BxS, _
                NOFC, TNOC)
        GetDiskSpace = X&

        If X& Then
                CurDisk.FreeBytes = BxS * _
                        SxC * NOFC
                CurDisk.TotalBytes = BxS * _
                        SxC * TNOC
                CurDisk.FreePcnt = ((CurDisk._
                        TotalBytes CurDisk._
                        FreeBytes) / CurDisk._
                        TotalBytes) * 100
                CurDisk.UsedPcnt = _
                        (CurDisk.FreeBytes / _
                        CurDisk.TotalBytes) * 100
        Else
                CurDisk.FreeBytes = 0
                CurDisk.TotalBytes = 0
                CurDisk.FreePcnt = 0
                CurDisk.UsedPcnt = 0
        End If
End Function

В таком виде, функция работает с драйвами размера где-то до 2Гб, для больших дисков надо использовать переменные типа Single.
 

Назад к СОДЕРЖАНИЮ

34. КАК СЫМИТИРОВАТЬ НАЖАТИЕ КЛАВИШИ CTRL ДЛЯ ВЫДЕЛЕНИЯ НЕСВЯЗАННЫХ КУСКОВ В LIST BOX

 VB4 32, VB5
Level: Advanced

Когда свойство MultiSelect обычного listboxа установлено в 1 - Simple или в 2 - Extended, то юзеру надо жать Ctrl при кликании внутри этого listboxа, чтобы выделять несвязанные (идущие неподряд) элементы. Мой метод позволяет юзеру выбирать несколько элементов, не нажимая при этом Ctrl. Поместите нижеприведенный код в модуль.

Declare Function GetKeyboardState Lib _
        "user32" (pbKeyState As Byte) _
        As Long
Declare Function SetKeyboardState Lib _
        "user32" (lppbKeyState As Byte) _
        As Long
Public Const VK_CONTROL = &H11
Public KeyState(256) As Byte

Этот код засуньте в событие MouseDown Вашего listboxа (назовем его List1), у которого свойство MultiSelect установлено в Simple или Extended:

' «нажимает» Ctrl
GetKeyboardState KeyState(0)
KeyState(VK_CONTROL) = _
        KeyState(VK_CONTROL) Or &H80
SetKeyboardState KeyState(0)

Этот код поместите в процедуру, в которой надо «отжать» Ctrl, например, List1_LostFocus:

' «отжимает» Ctrl
GetKeyboardState KeyState(0)
KeyState(VK_CONTROL) = _
        KeyState(VK_CONTROL) And &H7F
SetKeyboardState KeyState(0)

Назад к СОДЕРЖАНИЮ

35. ВЫБРАТЬ ВСЕ ФАЙЛЫ ПО МАСКЕ В ПОДДЕРЕВЕ КАТАЛОГОВ

VB3, VB4 16/32, VB5
Level: Intermediate

Поскольку этот код не использует API, Вы можете легко перенести его с 16- на 32-разрядную платформу и обратно. Процедура DirWalk позводит Вам просмотреть все поддерево, начиная с заданнного места:

ReDim sArray(0) As String
Call DirWalk("OLE*.DLL", "C:\", sArray)

Эта процедура принимает * и ? в первом аргументе, который задает маску поиска. Вы можете задать несколько масок, разделяя их символом «;», например, "OLE*.DLL; *.TLB". Второй аргумент - место старта, третий аргумент - массив строк.
Эта процедура рекурсивно проходит по всем каталогам и кладет все файлы, удовлетворяющие условию, в массив sArray с указанием полного пути. Этот массив меняет свои размеры в зависимости от количества файлов, удовлетворяющих условиям поиска.
Для использовния DirWalk, пихните два контрола, FileListBox и DirListBox, на форму. Эта процедура подразумевает, что она работает с контролами на текущей форме: : FileListBox по имени File1, и DirListBox по имени Dir1. Для увеличения скорости работы сделайте эти контролы невидимыми. Использование этих контролов не требует приобретения дополнительных тулзов, так как они (контролы) содержатся в базовой библиотеке контролов VB.

Sub DirWalk(ByVal sPattern As String, _
        ByVal CurrDir As String, sFound() _
        As String)
Dim i As Integer
Dim sCurrPath As String
Dim sFile As String
Dim ii As Integer
Dim iFiles As Integer
Dim iLen As Integer

If Right$(CurrDir, 1) <> "\" Then
        Dir1.Path = CurrDir & "\"
Else
        Dir1.Path = CurrDir
End If
For i = 0 To Dir1.ListCount
        If Dir1.List(i) <> "" Then
                DoEvents
                Call DirWalk(sPattern, _
                        Dir1.List(i), sFound())
        Else
                If Right$(Dir1.Path, 1) = "\" _
                        Then
                        sCurrPath = Left(Dir1.Path, _
                                Len(Dir1.Path) - 1)
                Else
                        sCurrPath = Dir1.Path
                End If
                File1.Path = sCurrPath
                File1.Pattern = sPattern
                If File1.ListCount > 0 Then
                        ' нужные файлы найдены в каталоге
                        For ii = 0 To File1._
                                ListCount - 1
                                ReDim Preserve _
                                        sFound(UBound(sFound) _
                                        + 1)
                                sFound(UBound(sFound) - _
                                        1) = sCurrPath & _
                                        "\" & File1.List(ii)
                        Next ii
                End If
                iLen = Len(Dir1.Path)
                Do While Mid(Dir1.Path, iLen, _
                        1) <> "\"
                        iLen = iLen - 1
                Loop
                Dir1.Path = Mid(Dir1.Path, 1, _
                        iLen)
        End If
Next i
End Sub

Назад к СОДЕРЖАНИ

36. ИМЯ ТЕКУЩЕГО КОМПЬЮТЕРА В WINDOWS 95/NT

VB4 32, VB5
Level: Advanced

Часто Вам надо знать имя текущего компа под WINDOWS 95/NT из Вашей VB проги. Используйте эту простенькую функцию API из kernel32.dll:

Private Declare Function GetComputerNameA Lib "kernel32"_
        (ByVal lpBuffer As String, nSize _
        As Long) As Long

Public Function GetMachineName() As _
        String
        Dim sBuffer As String * 255
        If GetComputerNameA(sBuffer, 255&) _
                <> 0 Then
                GetMachineName = Left$(sBuffer, _
                        InStr(sBuffer, vbNullChar) _
                        - 1)
        Else
                GetMachineName = "(Not Known)"
        End If
End Function
 

Назад к СОДЕРЖАНИЮ

37. КАК ПОКАЗАТЬ ШРИФТЫ, КОГДА ВЫ ВЫБИРАЕТЕ ИХ

VB3, VB4 16/32, VB5
Level: Intermediate
Чтобы юзер мог изменить имя шрифта, загрузите все шрифты в комбобокс:

Private Sub Form_Load()
        ' определить количество экранных шрифтов.
        For I = 0 To Screen.FontCount - 1
                ' засунуть все шрифты в листбокс.
                cboFont.AddItem Screen.Fonts(I)
        Next I
End Sub

Украсьте процедуру, позволив юзеру сразу видеть результат своего выбора, без необходимости печатать «что-нибудь» в качестве теста:

Private Sub cboFont_Click()
        ' сделать выбранный FontName шрифтом combobox
        cboFont.FontName = cboFont.Text
End Sub
 

Назад к СОДЕРЖАНИЮ

38. ПЕРЕХВАТ ПРАВЫХ КЛИКОВ НА УЗЛАХ TREEVIEW

 
VB4 32, VB5
Level: Intermediate

Контрол TreeView придает Вашей аппликухе законченный вид Windows 95. Однако, в учебниках по VB не сказано, как перехватывать правый мышиный клик на узле (node) дерева. Событие Treeview_MouseDown происходит до события NodeClick. Чтобы показать контекстное меню над узлом, используйте этот код и определите ключ (Key) для для каждого узла в виде буквы и идущим за ней числом.

+ Root (R01)                    ' the letter gives
|--- Child 1 (C01)      ' the indication to
|--+ Child 2 (C02)      ' the context menu
|  |--- Child 2.1 (H01)
|  |--- Child 2.2 (H02)

Dim bRightMouseDown as Boolean

Private Sub Form_Load()
        bRightMouseDown = False
End Sub

Private Sub treeview1_MouseDown_
        (Button As Integer, Shift As _
        Integer, X As Single, Y As Single)
        If Button And vbRightButton Then
                bRightMouseDown = True
        Else
                bRightMouseDown = False
        End If
End Sub

Private Sub treeview1_MouseUp_
        (Button As Integer, Shift As _
        Integer, X As Single, Y As Single)
                bRightMouseDown = False
End Sub

Private Sub treeview1_NodeClick_
        (ByVal Node As Node)
        Select Case Left(Node.Key, 1)
                Case "R"
                        If Not bRightMouseDown Then
                                ' do the normal node click,
                                ' so you must here the code
                                ' for the node code click
                        Else
                                ' выбор узла
                               treeview1.Nodes(Node.Key).Selected  = True
                                ' показать контекстное меню
                                PopupMenu mnuContext1
                End If
 
                Case "C"
                        If Not bRightMouseDown Then
                                ' do the normal node click,
                                ' so you must here the code
                                ' for the node code click
                        Else
                                ' выбор узла
                                treeview1.Nodes(Node.Key).Selected  = True
                                ' показать контекстное меню
                                PopupMenu mnuContext2
                End If

                ' то же с остальными узлами
                ' ....
        End Select
End Sub
 

Назад к СОДЕРЖАНИЮ

39. ЗАПУСК VB ПРИ ПОМОЩИ МЕНЮ SENDTO

VB3, VB4 16/32, VB5
Level: Intermediate
Добавление ярлыка "Shortcut to VB.exe" и "Shortcut to VB32.exe" в меню "Send To" позволяет Вам right-clickом на любом VBP проекте открывать его в VB4 16/32 или в VB5 - на выбор.
Зайдите в Ваш VB каталог, right-clickните на VB32.exe, и выберите "Create shortcut.". Когда ярлык будет создан, переместите его в каталог C:\Windows\Sendto. Теперь при right-clickе на проекте Вы сможете выбрать, куда «переслать» Ваш проект. Вы можете добавить ярлыки для WordPad, Word, Excel или любой другой программы, допускающей использование входного файла в качестве параметра запуска.
 
 

Назад к СОДЕРЖАНИЮ

40. НОВЫЕ “ГОРЯЧИЕ КНОПКИ” ДЛЯ VB

VB4 16/32, VB5
Level: Intermediate

1) В VB5, нажмите Ctrl-F3 когда курсор находится над каким-либо словом. При этом автоматически будет найдено следующее вхождение этого слова в тексте, минуя диалог поиска. Курсор должен стоять как минимум за первой буквой слова, чтобы эта фича работала правильно.

2) В VB4/5 нажатием Ctrl-Tab можно перемещаться между всеми открытыми окнами в IDE, это часто оказывается быстрее, чем идти в меню Window.
 

Назад к СОДЕРЖАНИЮ

41. КАК ПОЛУЧИТЬ USERID ПОД WINDOWS 95/NT

VB4 32, VB5
Level: Intermediate

Часто Вам надо получить userID текущего юзера, работающего с Вашей программой. Используйте для этого модификацию одной из функций API:

Option Explicit

Private Declare Function WNetGetUserA _
        Lib "mpr" (ByVal lpName As String, _
        ByVal lpUserName As String, _
        lpnLength As Long) As Long

Function GetUser() As String
        Dim sUserNameBuff As String * 255
        sUserNameBuff = Space(255)
        Call WNetGetUserA(vbNullString, _
                sUserNameBuff, 255&)
        GetUser = Left$(sUserNameBuff, _
                InStr(sUserNameBuff, _
                vbNullChar) - 1)
End Function

Назад к СОДЕРЖАНИЮ

42 ВЫВОД ПЕСОЧНЫХ ЧАСОВ ВО ВРЕМЯ ОБРАБОТКИ ДАННЫХ

VB4 32, VB5
Level: Advanced

Нижеуказанная методика упрощает переключение MousePointerа, без добавления спец. кода в конце каждой процедуры/функции. Когда Вы созадете объект из какого-либо класса, генерируется событие Initialize. Затем исполняется код соответствующей процедуры. Это первый код, исполняемый для данного объекта, он исполняется до присвоения каких-либо свойств объекту и до выполнения методов объекта. Когда переменная выходит из области видимости, все ссылки на объект уничтожаются, и выполняется код для события Terminate.

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

' пример процедуры, использующей класс CHourGlass
Private Sub ProcessData()
        Dim MyHourGlass As CHourGlass
        Set MyHourGlass = New CHourGlass
        ' здесь вставляется код обработки данных
        Sleep 5000 ' Это моделирует обработку данных
        ' продолжение кода
End Sub

' создание класса CHourGlass:
Private Sub Class_Initialize()
        ' Показать HourGlass
        Screen.MousePointer = vbHourglass
End Sub

Private Sub Class_Terminate()
        ' Восстановить MousePointer
        Screen.MousePointer = vbDefault
End Sub
 

Назад к СОДЕРЖАНИЮ

43. ОЦЕНКА ПРОМЕЖУТКА ВРЕМЕНИ(в минутах)  МЕЖДУ ДВУМЯ ДАТАМИ

VB4 16/32, VB5
Level: Beginning
Вам может понадобиться число прошедших минут между двумя событиями. Код:

lTotalMinutes = Minutes(Now) - _
        Minutes(datStartTime)

Эта функция возвращает количество минут с 01/01/1900:

Public Function Minutes(d As Date) _
        As Long
        ' Минуты, прошедшие с 1900
        Dim lPreviousDays As Long
        Dim lTotalMinutes As Long

        lPreviousDays = d - #1/1/1900#
        lTotalMinutes = _
                (lPreviousDays * 24) * 60
        lTotalMinutes = lTotalMinutes + _
                Hour(d) * 60
        lTotalMinutes = lTotalMinutes + _
                Minute(d)

        Minutes = lTotalMinutes
End Function
 

Назад к СОДЕРЖАНИЮ

44. ХВАТИТ ПЕЧАТАТЬ!

VB3, VB4 16/32, VB5
Level: Beginning

Иногда мне хочется распечатать данные из recordsetа, строка за строкой. Однако, довольно трудно пркратить этот процесс до того как весь recordset уйдет в очередь принтера. Используйте кнопку Cancel, которая устанавливает флаг. Кроме кнопки, посылающей задание на печать, создайте еще одну, под названием Cancel. Вы также можете присвоить ее свойству Cancel значение True, чтобы юзер мог остановить печать нажатием на Esc. Добавьте еще одну переменную в модуль:

Dim CancelNow As Integer

Put this code in the Click event of the Cancel button:
Добавьте этот код в событие Click кнопки Cancel:

Sub cCancel_Click ()
        CancelNow = -1
        DoEvents
End Sub

Вы можете даже обойтись без кнопки и ловить только нажатие на Escape. В этом случае, установите свойство KeyPreview формы в True и вставьте следующий код:

Sub Form_KeyPress (KeyAscii As Integer)
        ' если юзер жмет ESC
        If KeyAscii = (27) Then
                CancelNow = -1
                DoEvents
        End If
End sub

Наконец, вставьте проверку флага внутри цикла печати:

'... какой-то код...
' печать recordset из database
Do While Not MyRecordSet.EOF
        Printer.Print MyRecordSet!SomeRecord
        MyRecordSet.MoveNext
        DoEvents
        ' остановка, если был нажат Cancel
        If CancelNow then Exit Do
Loop
Printer.EndDoc
'... код далее...

Назад к СОДЕРЖАНИЮ

45. ПОМЕНЯТЬ ЗНАЧЕНИЯ ДВУХ ПЕРЕМЕННЫХ

VB3, VB4 16/32, VB5
Level: Intermediate

Use this algorithm to swap two integer variables:
Собственно, вот:

a = a Xor b
b = a Xor b
a = a Xor b

 
Назад к СОДЕРЖАНИ

46. БЫСТРЫЙ ОБСЧЕТ МНОГОЧЛЕНОВ

VB3, VB4 16/32, VB5
Level: Intermediate

Хорошо известная формула Горнера позволяет быстро считать полиномиальные выражения. Для того, чтобы посчитать
A*x^N + B*x^(N-1) + … + Y*x + Z ( ^ означает степень ), напишите :
(…((A*x + B)*x + C)*x + … +Y)*x + Z.
 

Назад к СОДЕРЖАНИЮ

47. ФОРМАТИРОВАНИЕ И КОПИРОВАНИЕ ДИСКЕТ ЧЕРЕЗ ФУНКЦИИ API

VB4 32, VB5
Level: Advanced

В Win32 API есть парочка функций, позволяющих форматировать и копировать дискеты из программы:

Private Declare Function SHFormatDrive _
        Lib "shell32" (ByVal hwnd As Long, _
        ByVal Drive As Long, _
        ByVal fmtID As Long, _
        ByVal options As Long) As Long
Private Declare Function GetDriveType _
        Lib "kernel32" _
        Alias "GetDriveTypeA" _
        (ByVal nDrive As String) As Long

Добавьте две command buttons в форму, назовите их cmdDiskCopy и cmdFormatDrive, и засуньте в их события Click следующие фрагменты кода:

Private Sub cmdDiskCopy_Click()
        ' DiskCopyRunDll требует два параметра - From и To
        Dim DriveLetter$, DriveNumber&, _
                DriveType&
        Dim RetVal&, RetFromMsg&
        DriveLetter = UCase(Drive1.Drive)
        DriveNumber = (Asc(DriveLetter) - _
                65)
        DriveType = GetDriveType_
                (DriveLetter)
        If DriveType = 2 Then  'Floppies, _
                etc
                RetVal = Shell_
                        ("rundll32.exe " & _
                        "diskcopy.dll," _
                        & "DiskCopyRunDll " & _
                        DriveNumber & "," & _
                        DriveNumber, 1)
        Else   ' Just in case
                RetFromMsg = MsgBox_
                        ("Only floppies can be " & _
                        "copied", 64, _
                        "DiskCopy Example")
        End If
End Sub

Private Sub cmdFormatDrive_Click()
        Dim DriveLetter$, DriveNumber&, _
                DriveType&
        Dim RetVal&, RetFromMsg%
                DriveLetter = UCase(Drive1.Drive)
        DriveNumber = (Asc(DriveLetter) - _
                65)
        ' Заменить букву на цифру: A=0
        DriveType = GetDriveType_
                (DriveLetter)
        If DriveType = 2 Then  _
                ' т.е. флоп
                RetVal = SHFormatDrive(Me.hwnd, _
                        DriveNumber, 0&, 0&)
        Else
                RetFromMsg = MsgBox_
                        ("This drive is NOT a " & _
                        "removeable drive! " & _
                        "Format this drive?", _
                        276, "SHFormatDrive Example")
                If RetFromMsg = 6 Then
                        ' Раскомментируйте и увидите...
                        'RetVal = SHFormatDrive_
                                (Me.hwnd, _
                                '   DriveNumber, 0&, 0&)
                End If
        End If
End Sub

Добавьте контрол DriveListBox под именем Drive1:

Private Sub Drive1_Change()
        Dim DriveLetter$, DriveNumber&, _
                DriveType&
        DriveLetter = UCase(Drive1.Drive)
        DriveNumber = (Asc(DriveLetter) - _
                65)
        DriveType = GetDriveType_
                (DriveLetter)
        If DriveType <> 2 Then  _
                'Floppies, etc
                cmdDiskCopy.Enabled = False
        Else
                cmdDiskCopy.Enabled = True
        End If
End Sub

Будьте осторожны: так недолго и винт запороть.
 
 

Назад к СОДЕРЖАНИЮ

48. ПОСЛЕДОВАТЕЛЬНЫЕ НОМЕРА ВЕРСИЙ

VB4 16/32, VB5
Level: Intermediate

Для слежения за последовательностью версий, используйте эту процедуру, если Вы используете номер версии:

Public Function GetMyVersion() As String
        ' конвертирует номер версии в нечто вроде"1.02.0001"
        Static strMyVer As String
        If strMyVer = "" Then
                strMyVer = Trim$(Str$(App.Major)) & "." & _
                        Format$(App.Minor, "##00") _
                        & "." Format$(App.Revision, "000")
        End If
        GetMyVersion = strMyVer
End Function
 

Назад к СОДЕРЖАНИЮ

49. ВЫРАВНИВАНИЕ КОНТРОЛОВ ПО ПРАВОМУ КРАЮ

VB3, VB4 16/32, VB5
Level: Beginning

При создании форм с нефиксированными размерами, я предпочитаю помещать все контролы в правый нижний и правый верхний углы. Например, на формах, где вводятся данные, я ставлю кнопки навигации по записям в левую нижнюю часть формы вместе с кнопками Add New Record, Delete Record, и Find Record. В нижнем правом углу я ставлю кнопки print preview и закрытия формы. Поместите эту процедуру в модуль или general declarations формы. Параметром Offset Вы можете изменять дистанцию от правого края формы, то есть Вы можете выравнивать по правому краю Ваши контролы.

Sub ButtonRight(X As Control, _
        Frm As Form, Offset as Integer)
                X.Left = Frm.ScaleWidth - _
                        X.Width - Offset
End Sub

Поместите два command buttonа на форму. В событии Form_Resize, добавьте примерно такой код:

Private Sub Form_Resize()
        ButtonRight Command1, Me, 0
        ButtonRight Command2, Me, _
                Command1.Width
End Sub

Назад к СОДЕРЖАНИЮ

50. VAL( ) НЕ РАБОТАЕТ НА ФОРМАТИРОВАННЫХ ЧИСЛАХ

VB3, VB4 16/32, VB5
Level: Intermediate

Осторожнее с функцией Val(). Она некорректно распознает форматированные числа. Используйте вместо этого CInt(), CDbl().

FormattedString = Format(1250, _
        "General")
        ' = "1,250.00"
Debug.Print Val(FormattedString)
        ' напечатает 1 !
Debug.Print cDbl(FormattedString)
        ' напечатает 1250

Назад к СОДЕРЖАНИЮ

51. CМЫШЛЕНЫЙ ГЕНЕРАТОР ID

VB3, VB4 16/32, VB5
Level: Intermediate

Я написал генератор для создания уникальных номиров , типа номера акаунта, или ID в вашеи приложении. Я использую это вместе с фенкцией CheckForValid, например CheckForValid вернет True  для номера "203931." И вернет False для "209331."
 

Function CheckForValid(Num As Long) _
        As Boolean
' Check for valid number
Result = Num Mod 13
If Result <> 0 Then
        CheckForValid = False
        ' if false then the number is wrong
Else
        CheckForValid = True
        'if true the number is OK
End If
End Function

Function Generate(Num As Long) As Long
'Generates the successor of a valid
'number
If CheckForValid(Num) Then
        Generate = Num + 13
        'if valid Generate
Else
        Generate = -1
        ' Otherwise return -1
End If
End Function

Назад к СОДЕРЖАНИЮ

52. ИЗМЕНЕНИЕ РАЗМЕРА ВЫПАДАЮЩЕЙ ОБЛАСТИ НА COMBOBOXE

VB4 32, VB5
Level: Advanced
В VB нет свойства ListRows, т.е. если Вам надо изобразить более чем 8 дефолтовых строк на выпадающем списке comboboxа, то используйте эту процедуру для увеличения размера окна comboboxа:

Option Explicit

Type POINTAPI
        x As Long
        y As Long
End Type

Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Declare Function MoveWindow Lib _
        "user32" (ByVal hwnd As Long, _
        ByVal x As Long, ByVal y As Long, _
        ByVal nWidth As Long, _
        ByVal nHeight As Long, _
        ByVal bRepaint As Long) As Long
Declare Function GetWindowRect Lib _
        "user32" (ByVal hwnd As Long, _
        lpRect As RECT) As Long
Declare Function ScreenToClient Lib _
        "user32" (ByVal hwnd As Long, _
        lpPoint As POINTAPI) As Long

Public Sub Size_Combo(rForm As Form, _
        rCbo As ComboBox)
        Dim pt As POINTAPI
        Dim rec As RECT
        Dim iItemWidth As Integer
        Dim iItemHeight As Integer
        Dim iOldScaleMode As Integer

        ' Смена Scale Mode формы на Pixels
        iOldScaleMode = rForm.ScaleMode
        rForm.ScaleMode = 3
        iItemWidth = rCbo.Width

        ' Установка новой высоты comboboxа
        iItemHeight = rForm.ScaleHeight - rCbo.Top - 5
        rForm.ScaleMode = iOldScaleMode

        ' Получение координат по отношению к экрану
        Call GetWindowRect(rCbo.hwnd, rec)
        pt.x = rec.Left
        pt.y = rec.Top

        ' затем координаты в форме
        Call ScreenToClient(rForm.hwnd, pt)

        ' Изменение размера comboboxа
        Call MoveWindow(rCbo.hwnd, pt.x, _
                pt.y, iItemWidth, iItemHeight, 1)
End Sub
 

Назад к СОДЕРЖАНИЮ

53. КОЛИЧЕСТВО СВОБОДНОЙ ПАМЯТИ С ПОМОЩЬЮ WIN32

 VB4 32, VB5
Level: Advanced

Если Вам надо показать юзерам, сколько свободной памяти доступно на машине, и Вы перешли с 16бит на 32 бит платформу, то Вы заметите, что функция API GetFreeSystemResources исяезла. Но это не беда. Вам надо всего лишь объявить API функцию и следующий тип в модуле:

Declare Sub GlobalMemoryStatus Lib _
        "kernel32" (lpBuffer As _
        MEMORYSTATUS)

Type MEMORYSTATUS
        dwLength As Long
        dwMemoryLoad As Long
        dwTotalPhys As Long
        dwAvailPhys As Long
        dwTotalPageFile As Long
        dwAvailPageFile As Long
        dwTotalVirtual As Long
        dwAvailVirtual As Long
End Type

Занесите в поле dwlength размер типа MEMORYSTATUS. Переменная типа Long берет 4 байта, так что всего выйдет 4*8=32 байта:

Dim ms As MEMORYSTATUS

ms.dwLength = Len(ms)
GlobalMemoryStatus ms
MsgBox "Total physical memory:" & _
        ms.dwTotalPhys & vbCr _
        & "Available physical memory:" & _
        ms.dwAvailPhys & vbCr & _
        "Memory load:" & ms.dwMemoryLoad

Вы можете даже написать класс, в котором инкапсулировать все вышеизложенное.
 

Назад к СОДЕРЖАНИЮ

54. СКОЛЬКО ВАМ ЛЕТ?

VB5
Level: Intermediate

Эта функция возвращает разницу между двумя датами в годах, месяцах и днях:

Function GetAge(dtDOB As Date, _
        Optional dtDateTo As Date = 0) _
        As String
                ' dtDateto передана?
                If dtDateTo = 0 Then
                        dtDateTo = Date
                End If
                GetAge = Format$(dtDateTo - _
                        dtDOB, "yy - mm - dd")
End Function
 

Назад к СОДЕРЖАНИЮ

55. УЗЕЛОК, О КОТОРОМ НЕВОЗМОЖНО ЗАБЫТЬ

VB3, VB4 16/32, VB5
Level: Intermediate

Я часто работаю над несколькими проектами одновременно. Прыгая с одного проекта на другой и обратно, иногда я теряю след, в какой программе в каком месте я остановился. Для решения этой проблемы, возьмите да и напечатайте какую-нибудь фразу без кавычек комментария.
В следующий раз, когда Вы запустите проект, выберите пункт "Start With Full Compile". Если эта фраза будет первой ошибкой в проекте, Вы сразу увидите ее подсвеченной и Ваша память освежится.

Назад к СОДЕРЖАНИ

56. СОЗДАТЬ НА ЛЕТУ МАССИВ ПРИ ПОМОЩИ ФУНКЦИИ ARRAY

VB4 16/32, VB5
Level: Intermediate

Метод GetRows копирует строки Recordsetа (JET) или rdoResultsetа (RDO) в массив. Я часто использую эту фичу для передачи данных между OLE Serverом и клиентскими аппликухами. Этот метод использует переменную типа Variant в качестве параметра для хранения возвращаемых данных. Это двумерный массив (по внутреннему представлению VB)

Dim A As Variant
A = Array(10,2)
 
 
 

Назад к СОДЕРЖАНИЮ

57. НАЙТИ ВЫБРАННЫЙ КОНТРОЛ В МАССИВЕ OPTION BUTTONS

VB4 16/32, VB5
Level: Intermediate
Используйте этот код для нахождения индекса выбранного контрола из массива option buttons

Function WhichOption(Options As _
        Object) As Integer

' Эта функция возвращает индекс Option Button, чье значение true.

        Dim i
        ' Если Options - не тот объект, или не объект вообще
        On Error GoTo WhichOptErr
        ' Default to failed
        WhichOption = -1
        ' проверяет каждый OptionButton в массиве. Прошу отметить, что функция выдает
        ' неправильное значение, если индексы идут не подряд
        For i = Options.lbound To _
                Options.ubound
                If Options(i) Then
                        ' запомнить значение найденного индекса
                        WhichOption = i
                        ' и выйти
                        Exit For
                End If
        Next
WhichOptErr:

End Function

Учтите, что iCurOptIndex имеет тип integer, а Option1 это имя массива контролов OptionButton.

iCurOptIndex = WhichOption(Option1)

Важно: параметр функции - объект. Она будет работать только с параметрами-объектами или типа variant.
 

Назад к СОДЕРЖАНИЮ

58. УПАКОВКА ЗНАЧЕНИЙ CHECK-BOX В ОДНУ ПЕРЕМЕННУЮ ТИПА INTEGER

VB4 16/32, VB5
Level: Intermediate

Используя следующий код, можно вывести двоичное представление зачеркнутых check boxов:

Function WhichCheck(ctrl As Object) As _
        Integer
' Эта функция возвращает двоичное представление массива контролов,
' где каждый зачеркнутый чекбокс представляется двойкой в степени своего индекса в
' массиве, напр.элемент 0 : 2 ^ 0 = 1,
'элементы 0 и 2 : 2^0 + 2^2 = 5

        Dim i
        Dim iHolder
        ' если некорректный параметр передан в процедуру
        ' возвращается 0
On Error GoTo WhichCheckErr

        ' двоичное представление
        ' массива чекбоксов
        For i = ctrl.LBound To ctrl.UBound
                If ctrl(i) = 1 Then
                        ' если зачеркнут, добавить его двоичное представление
                        iHolder = iHolder Or 2 ^ i
                End If
        Next
WhichCheckErr:
        WhichCheck = iHolder

End Function

Функция вызывается следующим образом:

iCurChecked = WhichCheck(Check1)

Check1 - массив чекбоксов, iCurChecked - переменная integer. Ниже приведена «двойственная» процедура, устанавливающая все чекбоксы согласно переменной, в которой хранятся их двоичные представления.

Sub SetChecked(ctrl As Object, _
        iCurCheck%)
' This sub sets the binary value of an
' array of controls where iCurChecked is
' 2 raised to the index of each checked
' control
        Dim i
        ' in case ctrl is not a valid object
        On Error GoTo SetCheckErr
        ' use the binary representation to
        ' set individual check box controls
        For i = ctrl.LBound To ctrl.UBound
                If iCurCheck And (2 ^ i) Then
                        ' if it is checked add in its
                        ' binary value
                        ctrl(i).Value = 1
                Else
                        ctrl(i).Value = 0
                End If
        Next
SetCheckErr:

End Sub

Эта процедура вызывается так:

Call SetChecked(Check1, iDesired)

Check1 - массив чекбоксов, iDesired- переменная, хранящая двоичное представление состояния чекбоксов.

Назад к СОДЕРЖАНИЮ

59. УСЛОВНАЯ КОМПИЛЯЦИЯ КОДА

VB4 16/32, VB5
Level: Intermediate

Большинству разработчиков известна фича Conditional Compilation из VB4, когда Вы можете объявлять процедуры Windows API для 16- или 32-разрядных ОС:

#If Win#32 then
        ' если 32-разрядная ОС
        Declare SomeApi....
#Else
        ' если запущена 16-разрядная ОС
        Declare SomeApi
#End IF
Эта же фича может работать не только с функциями Windows API, но и с Вашими собственными функциями:

#If Win32 Then
        Dim lRc&
        lRc& = ReturnSomeNumber(35000)
#Else
        Dim lRc%
        lRc% = ReturnSomeNumber(30000)
#End If

#If Win32 Then
        Private Function ReturnSomeNumber_
                (lVar&) As Long
                ReturnSomeNumber = 399999
#Else
        Private Function ReturnSomeNumber_
                (lVar%) As Integer
                ReturnSomeNumber = 30000
#End If

End Function
 

Назад к СОДЕРЖАНИЮ

60. УМЕНЬШИТЬ МЕРЦАНИЕ ВО ВРЕМЯ ЗАГРУЗКИ ФОРМЫ

 VB4, VB5
Level: Intermediate

Во время загрузки формы, следующий код поможет уменьшить мерцание и мелькание GUI при помощи функций API:

'Declarations Section
#If Win32 Then
        Declare Function LockWindowUpdate _
                Lib "user32" _
                (ByVal hwndLock As Long) As Long
#Else
        Declare Function LockWindowUpdate _
                Lib "User" _
                (ByVal hwndLock As Integer) _
                As Integer
#End If

Public Sub LoadSomeForm()

        ' Во время загрузки формы запрещает обновление состояния окна
        ' чтобы избавиться от мерцания.
        ' запрещаетобновление GUI
        LockWindowUpdate frmTest.hWnd
        ' показывает форму
        frmTest.Show
        ' здесь код, относящийся к загрузка формы и т.п.
 
        ' Никогда не забывайте разрешить обратно обновление окна
        LockWindowUpdate 0
End Sub

Назад к СОДЕРЖАНИЮ