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
|
